From 62ea1ded1a9982e09b7ada0a7bc5c8c4398b3b29 Mon Sep 17 00:00:00 2001 From: Kevin Lyda Date: Sat, 30 Jan 2016 23:55:15 +0000 Subject: [PATCH] Unpack and add zoo file contents. --- decus/lt89b1/bulletin/allmacs.mar | 270 ++ decus/lt89b1/bulletin/bulldir.inc | 33 + decus/lt89b1/bulletin/bulletin.for | 1413 +++++++++++ decus/lt89b1/bulletin/bulletin0.for | 1453 +++++++++++ decus/lt89b1/bulletin/bulletin1.for | 1565 ++++++++++++ decus/lt89b1/bulletin/bulletin2.for | 1499 +++++++++++ decus/lt89b1/bulletin/bulletin3.for | 1589 ++++++++++++ decus/lt89b1/bulletin/bulletin4.for | 1703 +++++++++++++ decus/lt89b1/bulletin/bulletin5.for | 1606 ++++++++++++ decus/lt89b1/bulletin/bulletin6.for | 1586 ++++++++++++ decus/lt89b1/bulletin/bulletin7.for | 1763 +++++++++++++ decus/lt89b1/bulletin/bulletin8.for | 1556 ++++++++++++ decus/lt89b1/bulletin/bulletin9.for | 1826 ++++++++++++++ decus/lt89b1/bulletin/bullfiles.inc | 28 + decus/lt89b1/bulletin/bullfolder.inc | 46 + decus/lt89b1/bulletin/bulluser.inc | 42 + decus/vax89a2/nieland/bulletin/allmacs.mar | Bin 9322 -> 8878 bytes decus/vax89a2/nieland/bulletin/bulldir.inc | 33 + decus/vax89a2/nieland/bulletin/bullet1.com | 782 ++++++ decus/vax89a2/nieland/bulletin/bullet2.com | 1067 ++++++++ decus/vax89a2/nieland/bulletin/bulletin.com | Bin 40 -> 38 bytes decus/vax89a2/nieland/bulletin/bulletin.for | 1400 +++++++++++ decus/vax89a2/nieland/bulletin/bulletin0.for | 1418 +++++++++++ decus/vax89a2/nieland/bulletin/bulletin1.for | 1543 ++++++++++++ decus/vax89a2/nieland/bulletin/bulletin2.for | 1520 ++++++++++++ decus/vax89a2/nieland/bulletin/bulletin3.for | 1588 ++++++++++++ decus/vax89a2/nieland/bulletin/bulletin4.for | 1676 +++++++++++++ decus/vax89a2/nieland/bulletin/bulletin5.for | 1596 ++++++++++++ decus/vax89a2/nieland/bulletin/bulletin6.for | 1502 +++++++++++ decus/vax89a2/nieland/bulletin/bulletin7.for | 1750 +++++++++++++ decus/vax89a2/nieland/bulletin/bulletin8.for | 1460 +++++++++++ decus/vax89a2/nieland/bulletin/bulletin9.for | 1763 +++++++++++++ decus/vax89a2/nieland/bulletin/bullfiles.inc | 28 + decus/vax89a2/nieland/bulletin/bullfolder.inc | 46 + decus/vax89a2/nieland/bulletin/bulluser.inc | 42 + decus/vax90a/bulletin/allmacs.mar | 270 ++ decus/vax90a/bulletin/bullcom.cld | 419 ++++ decus/vax90a/bulletin/bulletin.for | 1436 +++++++++++ decus/vax90a/bulletin/bulletin0.for | 1494 +++++++++++ decus/vax90a/bulletin/bulletin1.for | 1565 ++++++++++++ decus/vax90a/bulletin/bulletin2.for | 1518 ++++++++++++ decus/vax90a/bulletin/bulletin3.for | 1594 ++++++++++++ decus/vax90a/bulletin/bulletin4.for | 1703 +++++++++++++ decus/vax90a/bulletin/bulletin5.for | 1614 ++++++++++++ decus/vax90a/bulletin/bulletin6.for | 1586 ++++++++++++ decus/vax90a/bulletin/bulletin7.for | 1845 ++++++++++++++ decus/vax90a/bulletin/bulletin8.for | 1567 ++++++++++++ decus/vax90a/bulletin/bulletin9.for | 1860 ++++++++++++++ decus/vax90a/bulletin/bullmain.cld | 26 + .../bulletin/vlt90b/bulletin/allmacs.mar | 270 ++ .../bulletin/vlt90b/bulletin/bulldir.inc | 33 + .../bulletin/vlt90b/bulletin/bulletin.for | 1623 ++++++++++++ .../bulletin/vlt90b/bulletin/bulletin0.for | 1636 ++++++++++++ .../bulletin/vlt90b/bulletin/bulletin1.for | 1603 ++++++++++++ .../bulletin/vlt90b/bulletin/bulletin2.for | 1638 ++++++++++++ .../bulletin/vlt90b/bulletin/bulletin3.for | 1738 +++++++++++++ .../bulletin/vlt90b/bulletin/bulletin4.for | 1776 +++++++++++++ .../bulletin/vlt90b/bulletin/bulletin5.for | 1859 ++++++++++++++ .../bulletin/vlt90b/bulletin/bulletin6.for | 1603 ++++++++++++ .../bulletin/vlt90b/bulletin/bulletin7.for | 1929 +++++++++++++++ .../bulletin/vlt90b/bulletin/bulletin8.for | 1654 +++++++++++++ .../bulletin/vlt90b/bulletin/bulletin9.for | 1950 +++++++++++++++ .../bulletin/vlt90b/bulletin/bullfiles.inc | 28 + .../bulletin/vlt90b/bulletin/bullfolder.inc | 46 + .../bulletin/vlt90b/bulletin/bulluser.inc | 44 + decus/vax91b/gce91b/net91b/allmacs.mar | 345 +++ decus/vax91b/gce91b/net91b/bull_ann.txt | 412 ++++ decus/vax91b/gce91b/net91b/bullcoms1.hlp | 906 +++++++ decus/vax91b/gce91b/net91b/bullcoms2.hlp | 1025 ++++++++ decus/vax91b/gce91b/net91b/bullet1.com | 1452 +++++++++++ decus/vax91b/gce91b/net91b/bullet2.com | 1599 ++++++++++++ decus/vax91b/gce91b/net91b/bulletin.for | 1768 +++++++++++++ .../vax91b/gce91b/net91b/bulletin.for_gcemod | 1778 ++++++++++++++ decus/vax91b/gce91b/net91b/bulletin0.for | 1746 +++++++++++++ decus/vax91b/gce91b/net91b/bulletin1.for | 1925 +++++++++++++++ decus/vax91b/gce91b/net91b/bulletin10.for | 2186 +++++++++++++++++ decus/vax91b/gce91b/net91b/bulletin11.for | 1385 +++++++++++ decus/vax91b/gce91b/net91b/bulletin2.for | 2147 ++++++++++++++++ decus/vax91b/gce91b/net91b/bulletin3.for | 1921 +++++++++++++++ decus/vax91b/gce91b/net91b/bulletin4.for | 1807 ++++++++++++++ decus/vax91b/gce91b/net91b/bulletin5.for | 2139 ++++++++++++++++ decus/vax91b/gce91b/net91b/bulletin6.for | 1700 +++++++++++++ decus/vax91b/gce91b/net91b/bulletin7.for | 2044 +++++++++++++++ decus/vax91b/gce91b/net91b/bulletin8.for | 1884 ++++++++++++++ decus/vax91b/gce91b/net91b/bulletin9.for | 1802 ++++++++++++++ decus/vax91b/gce91b/net91b/mx.com | 958 ++++++++ decus/vax91b/gce91b/net91b/pmdf.com | 1029 ++++++++ 87 files changed, 109077 insertions(+) create mode 100644 decus/lt89b1/bulletin/allmacs.mar create mode 100644 decus/lt89b1/bulletin/bulldir.inc create mode 100644 decus/lt89b1/bulletin/bulletin.for create mode 100644 decus/lt89b1/bulletin/bulletin0.for create mode 100644 decus/lt89b1/bulletin/bulletin1.for create mode 100644 decus/lt89b1/bulletin/bulletin2.for create mode 100644 decus/lt89b1/bulletin/bulletin3.for create mode 100644 decus/lt89b1/bulletin/bulletin4.for create mode 100644 decus/lt89b1/bulletin/bulletin5.for create mode 100644 decus/lt89b1/bulletin/bulletin6.for create mode 100644 decus/lt89b1/bulletin/bulletin7.for create mode 100644 decus/lt89b1/bulletin/bulletin8.for create mode 100644 decus/lt89b1/bulletin/bulletin9.for create mode 100644 decus/lt89b1/bulletin/bullfiles.inc create mode 100644 decus/lt89b1/bulletin/bullfolder.inc create mode 100644 decus/lt89b1/bulletin/bulluser.inc create mode 100644 decus/vax89a2/nieland/bulletin/bulldir.inc create mode 100644 decus/vax89a2/nieland/bulletin/bullet1.com create mode 100644 decus/vax89a2/nieland/bulletin/bullet2.com create mode 100644 decus/vax89a2/nieland/bulletin/bulletin.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin0.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin1.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin2.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin3.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin4.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin5.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin6.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin7.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin8.for create mode 100644 decus/vax89a2/nieland/bulletin/bulletin9.for create mode 100644 decus/vax89a2/nieland/bulletin/bullfiles.inc create mode 100644 decus/vax89a2/nieland/bulletin/bullfolder.inc create mode 100644 decus/vax89a2/nieland/bulletin/bulluser.inc create mode 100644 decus/vax90a/bulletin/allmacs.mar create mode 100644 decus/vax90a/bulletin/bullcom.cld create mode 100644 decus/vax90a/bulletin/bulletin.for create mode 100644 decus/vax90a/bulletin/bulletin0.for create mode 100644 decus/vax90a/bulletin/bulletin1.for create mode 100644 decus/vax90a/bulletin/bulletin2.for create mode 100644 decus/vax90a/bulletin/bulletin3.for create mode 100644 decus/vax90a/bulletin/bulletin4.for create mode 100644 decus/vax90a/bulletin/bulletin5.for create mode 100644 decus/vax90a/bulletin/bulletin6.for create mode 100644 decus/vax90a/bulletin/bulletin7.for create mode 100644 decus/vax90a/bulletin/bulletin8.for create mode 100644 decus/vax90a/bulletin/bulletin9.for create mode 100644 decus/vax90a/bulletin/bullmain.cld create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/allmacs.mar create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulldir.inc create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin0.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin1.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin2.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin3.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin4.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin5.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin6.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin7.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin8.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulletin9.for create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bullfiles.inc create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bullfolder.inc create mode 100644 decus/vax90b1/bulletin/vlt90b/bulletin/bulluser.inc create mode 100644 decus/vax91b/gce91b/net91b/allmacs.mar create mode 100644 decus/vax91b/gce91b/net91b/bull_ann.txt create mode 100644 decus/vax91b/gce91b/net91b/bullcoms1.hlp create mode 100644 decus/vax91b/gce91b/net91b/bullcoms2.hlp create mode 100644 decus/vax91b/gce91b/net91b/bullet1.com create mode 100644 decus/vax91b/gce91b/net91b/bullet2.com create mode 100644 decus/vax91b/gce91b/net91b/bulletin.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin.for_gcemod create mode 100644 decus/vax91b/gce91b/net91b/bulletin0.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin1.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin10.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin11.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin2.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin3.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin4.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin5.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin6.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin7.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin8.for create mode 100644 decus/vax91b/gce91b/net91b/bulletin9.for create mode 100644 decus/vax91b/gce91b/net91b/mx.com create mode 100644 decus/vax91b/gce91b/net91b/pmdf.com diff --git a/decus/lt89b1/bulletin/allmacs.mar b/decus/lt89b1/bulletin/allmacs.mar new file mode 100644 index 0000000..f8a6793 --- /dev/null +++ b/decus/lt89b1/bulletin/allmacs.mar @@ -0,0 +1,270 @@ +; +; Name: SETACC.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: Jan 26, 1983 +; +; Purpose: To set the account name of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETACC(account) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; account - Character string containing account name +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETACC + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF + $JIBDEF +; +; local variables: +; + + .PSECT DATA,NOEXE + +NEWACC: .BLKB 12 ; Contains new account name +; +; Executable: +; + .PSECT CODE,EXE,NOWRT ; Executable code + + .ENTRY SETACC,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R6 ; Get number of arguments + CMPL R6,#1 ; Correct number of arguments? + BNEQ 5$ ; If not, return + MOVZBL @4(AP),R6 ; Get size of string + MOVL 4(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#8,NEWACC ; Get new account name string + $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R6 ; Address of current process + MOVL PCB$L_JIB(R6),R6 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + MOVC3 #8,NEWACC,JIB$T_ACCOUNT(R6) ; change account JIB + MOVC3 #8,NEWACC,CTL$T_ACCOUNT ; change account in P1 + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +; +; Name: SETUIC.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: May 31, 1983 +; +; Purpose: To set the UIC of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETUIC(group number, user number) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; group number - longword containing UIC group number +; user number - longword containing UIC user number +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETUIC Set uic + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF +; +; Executable: +; + .PSECT SETUIC_CODE,EXE,NOWRT ; Executable code + + .ENTRY SETUIC,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R2 ; Get number of arguments + CMPL R2,#2 ; Are there 2 arguments + BNEQ 5$ ; If not, return + MOVL @4(AP),R3 ; Group number into R3 + ROTL #16,R3,R3 ; Move to upper half of R3 + ADDL2 @8(AP),R3 ; User number to top half of R3 + $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R2 ; Address of current process + MOVL R3,PCB$L_UIC(R2) ; Set UIC to specified + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +; +; Name: SETUSER.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: Jan 26, 1983 +; +; Purpose: To set the Username of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETUSER(username) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; username - Character string containing username +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETUSER Set uic + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF + $JIBDEF +; +; local variables: +; + + .PSECT SETUSER_DATA,NOEXE + +NEWUSE: .BLKB 12 ; Contains new username +OLDUSE: .BLKB 12 ; Contains old username +; +; Executable: +; + .PSECT SETUSER_CODE,EXE,NOWRT ; Executable code + + .ENTRY SETUSER,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R8 ; Get number of arguments + CMPL R8,#1 ; Correct number of arguments + BLSS 5$ ; If not, return + MOVZBL @4(AP),R6 ; Get size of string + MOVL 4(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#12,NEWUSE ; Get new username string + CMPL R8,#2 ; Old username given? + BLSS 2$ ; No + MOVZBL @8(AP),R6 ; Get size of string + MOVL 8(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#12,OLDUSE ; Get old username string + $CMKRNL_S ROUTIN=20$ ; Must run in kernel mode + TSTL R0 ; If old username is checks with + BEQL 2$ ; present process name, change + MOVL #2,R0 ; to new username, else flag + RET ; error and return +2$: $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R7 ; Address of current process + MOVL PCB$L_JIB(R7),R7 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + MOVC3 #12,NEWUSE,JIB$T_USERNAME(R7) ; change username JIB + MOVC3 #12,NEWUSE,CTL$T_USERNAME ; change username in P1 + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +20$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R7 ; Address of current process + MOVL PCB$L_JIB(R7),R7 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + CMPC R6,OLDUSE,JIB$T_USERNAME(R7) ; change username JIB + RET + + + .TITLE READ_HEADER - Read Image Header + .IDENT /1-001/ + +; This subroutine returns the image identification and link time. +; +; Format: +; +; status.wlc.v = READ_HEADER( ident.wt.ds [,time.wt.ds] ) +; +; Parameters: +; +; ident The image identification text. +; +; time The image link time (text format). + + +; Date By Comments +; 4/10/87 D.E. Greenwood Originally written by John Miano, 24-June-1986 - +; obtained from April 87 DECUS L&T Sig Newsletter + .LIBRARY "SYS$LIBRARY:LIB" + + $DSCDEF + $IHDDEF + $IHIDEF + $SSDEF + +; Argument pointer offsets + + $OFFSET 4,POSITIVE, + + .PSECT READ_HEADER, RD, NOWRT, EXE, LONG + .ENTRY READ_HEADER, ^M< R2, R3, R4, R5, R6, R7, R8, R11 > + + CMPL (AP),#1 ; Make sure that there is at least + BGEQ ENOUGH_ARGUMENTS ; one argument to this routine + MOVL #SS$_INSFARG, R0 + RET + +ENOUGH_ARGUMENTS: + +; Get the identification of the image. + + MOVL @#CTL$GL_IMGHDRBF, R11 ; R11 - Address of image buffer + MOVL (R11), R6 ; R6 - Address of image header + + CVTWL IHD$W_IMGIDOFF(R6), R7 + MOVAB (R6)[R7], R7 ; R7 - Address of ID Block + + CVTBL IHI$T_IMGID(R7),R0 ; Length of the ID string + MOVL IDENT(AP), R8 + MOVC5 R0, (R7), #32, - + DSC$W_LENGTH(R8), @DSC$A_POINTER(R8) + + CMPL (AP), #2 + BGEQ RETURN_TIME + MOVZBL #1, R0 + RET + +RETURN_TIME: + +; Get the time the image was linked and convert it to ASCII + + $ASCTIM_S - + TIMBUF=@TIME(AP), - + TIMADR=IHI$Q_LINKTIME(R7) + + RET + + .END diff --git a/decus/lt89b1/bulletin/bulldir.inc b/decus/lt89b1/bulletin/bulldir.inc new file mode 100644 index 0000000..640dc6c --- /dev/null +++ b/decus/lt89b1/bulletin/bulldir.inc @@ -0,0 +1,33 @@ + PARAMETER DIR_RECORD_LENGTH = ((97+3)/4)*4 + + COMMON /BULL_DIR/ MSG_BTIM,MSG_NUM,DESCRIP,FROM,LENGTH,EX_BTIM + & ,SYSTEM,BLOCK,HEADER_BTIM,HEADER_NUM,NEWEST_EXBTIM,NEWEST_MSGBTIM + & ,NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_BTIM,NEMPTY + & ,DATE,TIME,EXDATE,EXTIME,NEWEST_EXDATE,NEWEST_EXTIME + & ,NEWEST_DATE,NEWEST_TIME,SHUTDOWN_DATE,SHUTDOWN_TIME + CHARACTER*53 DESCRIP + CHARACTER*12 FROM + LOGICAL SYSTEM + + CHARACTER*11 DATE,EXDATE,NEWEST_EXDATE,NEWEST_DATE,SHUTDOWN_DATE + CHARACTER*11 TIME,EXTIME,NEWEST_EXTIME,NEWEST_TIME,SHUTDOWN_TIME + + INTEGER MSG_BTIM(2),EX_BTIM(2),HEADER_BTIM(2) + INTEGER NEWEST_EXBTIM(2),NEWEST_MSGBTIM(2),SHUTDOWN_BTIM(2) + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY + EQUIVALENCE (MSG_BTIM,BULLDIR_ENTRY) + + CHARACTER*52 BULLDIR_HEADER + EQUIVALENCE (HEADER_BTIM,BULLDIR_HEADER) + + DATA HEADER_BTIM/0,0/,HEADER_NUM/0/ + + CHARACTER MSG_KEY*8 + + EQUIVALENCE (MSG_BTIM,MSG_KEY) + + PARAMETER LINE_LENGTH=255 + + COMMON /INPUT_BUFFER/ INPUT + CHARACTER INPUT*(LINE_LENGTH) diff --git a/decus/lt89b1/bulletin/bulletin.for b/decus/lt89b1/bulletin/bulletin.for new file mode 100644 index 0000000..3c598b4 --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin.for @@ -0,0 +1,1413 @@ +C +C BULLETIN.FOR, Version 10/24/89 +C Purpose: Bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /POINT/ BULL_POINT + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING /.FALSE./ + + COMMON /CTRLY/ CTRLY + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + EXTERNAL ERROR_TRAP + EXTERNAL BULLETIN_SUBCOMMANDS,LIB$GET_INPUT + EXTERNAL BULLETIN_MAINCOMMANDS,ENABLE_CTRL_EXIT + EXTERNAL CLI$_ABSENT,CLI$_NOCOMD + + PARAMETER PCB$M_BATCH = '4000'X + PARAMETER PCB$M_NETWRK = '200000'X + PARAMETER LIB$M_CLI_CTRLY = '2000000'X + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER HELP_DIRECTORY*64,SAVE_FOLDER*25 + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + CALL LIB$ESTABLISH(ERROR_TRAP) + IF (.NOT.CLI$GET_VALUE('PROMPT',COMMAND_PROMPT,ILEN)) THEN + CALL LIB$GET_FOREIGN(INCMD) + CALL CLI$DCL_PARSE('BULLETIN '//INCMD,BULLETIN_MAINCOMMANDS) + CALL CLI$GET_VALUE('$LINE',COMMAND_PROMPT,ILEN) + END IF + CALL LIB$REVERT + + READIT = 0 + LOGIN_SWITCH = CLI$PRESENT('LOGIN') + SYSTEM_SWITCH = CLI$PRESENT('SYSTEM') + REVERSE_SWITCH = CLI$PRESENT('REVERSE') + + IER = LIB$SYS_TRNLOG('BULL_DISABLE',LEN_P,BULL_PARAMETER) + IF (IER.EQ.1.AND.LEN_P.GT.0.AND..NOT.CLI$PRESENT('STOP')) THEN + IF (.NOT.LOGIN_SWITCH) THEN + WRITE (6,'('' BULLETIN temporarily disabled. Try later.'')') + END IF + CALL EXIT + END IF + + CALL SYS$SETDFPROT(,ORIGINAL_DEF_PROT) + ! Save original default protection in case it gets changed + + CALL DCLEXH(%LOC(ENABLE_CTRL_EXIT)) ! Declare exit handler + +C +C Check to see if CONTROL Y disabled. If so, then never disable CONTROL Y. +C Disabling and enabling CONTROL Y is done so that a person can not break +C while one of the data files is opened, as that would not allow anyone +C else to modify the files. However, if CONTROL Y is already disabled, +C this is not necessary, and should not be done! +C + + CALL LIB$DISABLE_CTRL(LIB$M_CLI_CTRLY,CTRLY) ! Disable CTRL-Y & -C + CTRLY = CTRLY .AND. LIB$M_CLI_CTRLY + CALL GETPRIV ! Check privileges + CALL CHECK_PRIV_IO(ERR) ! Check privileges on output I/O + CALL LIB$ENABLE_CTRL(CTRLY,) ! Renable CTRLY-Y & -C + + IF (ERR.EQ.1) CALL EXIT ! I/O privilege error, so exit + + CALL GETUSER(USERNAME) ! Get the process's username + + I = 1 ! Strip off folder name if specified + DO WHILE (I.LE.ILEN) + IF (COMMAND_PROMPT(I:I).EQ.' ') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + I = ILEN + 1 + ELSE + I = I + 1 + END IF + END DO + ILEN = 1 ! Get executable name to use as prompt + DO WHILE (ILEN.GT.0) + ILEN = MAX(INDEX(COMMAND_PROMPT,':'),INDEX(COMMAND_PROMPT,']')) + IF (ILEN.GT.0) THEN + COMMAND_PROMPT = COMMAND_PROMPT(ILEN+1:) + ELSE + DO I=TRIM(COMMAND_PROMPT),1,-1 + IF (COMMAND_PROMPT(I:I).LT.'A'.OR. + & COMMAND_PROMPT(I:I).GT.'Z') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + END IF + END DO + END IF + END DO + COMMAND_PROMPT = COMMAND_PROMPT(:TRIM(COMMAND_PROMPT))//'> ' + IF (COMMAND_PROMPT.EQ.'RUN> ') COMMAND_PROMPT = 'BULLETIN> ' + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + + CALL CLI$GET_VALUE('SEPARATE',SEPARATE) + + IF (CLI$PRESENT('EDIT')) EDIT_DEFAULT = .TRUE. ! /EDIT switch test + + CALL FIND_BULLCP ! See if BULLCP is running + + IF (CLI$PRESENT('CLEANUP')) THEN ! Test for /CLEANUP switch + CALL CLI$GET_VALUE('CLEANUP',BULL_PARAMETER,LEN_P) ! Get folder # + READ (BULL_PARAMETER,'(I)') FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + CALL EXIT ! all done with cleanup + ELSE IF (CLI$PRESENT('BBOARD')) THEN ! Test for /BBOARD switch + CALL BBOARD ! look for BBOARD mail + CALL EXIT ! all done with BBOARD + ELSE IF (CLI$PRESENT('STARTUP').OR. ! BULLCP process control + & CLI$PRESENT('STOP')) THEN + CALL CREATE_BULLCP + ELSE IF (CLI$PRESENT('BULLCP')) THEN ! This is BULLCP, so start + CALL RUN_BULLCP ! doing what BULLCP does! + END IF + + CALL GETSTS(STS) ! Get process status word + + IF (SYSTEM_SWITCH.OR.LOGIN_SWITCH) THEN ! If BULLETIN/LOGIN or /SYSTEM + IF ((STS.AND.PCB$M_BATCH).GT.0) CALL EXIT ! If BATCH, exit + CALL CRELNM('SYS$INPUT','TT') ! Take input from terminal + END IF + + IF ((STS.AND.PCB$M_NETWRK).EQ.0) THEN + DECNET_PROC = .FALSE. + ERROR_UNIT = 6 + + CALL ASSIGN_TERMINAL ! Assign terminal + + INCMD = 'SELECT' ! Causes nearest folder name to be selected + CALL SELECT_FOLDER(.FALSE.,IER) ! Select GENERAL folder + IF (.NOT.IER) RETURN ! If can't access, exit + + IF (.NOT.TEST_BULLCP()) CALL DELETE_EXPIRED + ! Delete expired messages + +C +C Get page size for the terminal. +C + + CALL GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) + + IF (CLI$PRESENT('PAGE')) PAGING = .TRUE. + + IF (SYSTEM_SWITCH) THEN + IER = CLI$GET_VALUE('SYSTEM',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Days specified? + CALL SUBTIME(SYSTEM_LOGIN_BTIM,BULL_PARAMETER(:LEN_P),IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Invalid parameter in /SYSTEM.'')') + CALL EXIT + END IF + END IF + IF (.NOT.LOGIN_SWITCH) THEN + CALL MODIFY_SYSTEM_LIST(0) + CALL SHOW_SYSTEM + CALL EXIT + END IF + END IF + +C +C Get user info stored in SYS$LOGIN. Currently, this simply stores +C the time of the latest message read for each folder. +C + + CALL OPEN_USERINFO + +C +C If /LOGIN, display SYSTEM bulletins and subject of non-SYSTEM bulletins. +C + + IF (LOGIN_SWITCH.OR.SYSTEM_SWITCH) THEN ! Is /LOGIN present? + CALL LOGIN ! Display SYSTEM bulletins + IF (READIT.EQ.0) CALL EXIT ! If no READNEWs not set, exit + END IF + +C +C If new bulletins have been added since the last time bulletins have been +C read, position bulletin pointer so that next bulletin read is the first new +C bulletin, and alert user. If READNEW set and no new bulletins, just exit. +C + + CALL NEW_MESSAGE_NOTIFICATION + + CALL OPEN_OLD_TAG + + ELSE + IF (TEST_BULLCP()) CALL EXIT + DECNET_PROC = .TRUE. + ERROR_UNIT = 5 + END IF + +C +C The MAIN loop for processing bulletin commands. +C + + DIR_COUNT = 0 ! # directory entry to continue bulletin read from + READ_COUNT = 0 ! # block that bulletin READ is to continue from + FOLDER_COUNT = 0 ! # folder entry to continue SHOW/ALL folder from + INDEX_COUNT = 0 + + IER = LIB$SYS_TRNLOG('BULL_HELP',HLEN,HELP_DIRECTORY) + IF (IER.NE.1) THEN + HELP_DIRECTORY = 'SYS$HELP:' + HLEN = 9 + ELSE IF (HELP_DIRECTORY(HLEN:HLEN).NE.':'.AND. + & HELP_DIRECTORY(HLEN:HLEN).NE.']') THEN + HELP_DIRECTORY = HELP_DIRECTORY(:HLEN)//':' + HLEN = HLEN + 1 + END IF + + DO WHILE (1) + + CALL GET_INPUT_PROMPT(INCMD,IER, + & CHAR(10)//COMMAND_PROMPT(:TRIM(COMMAND_PROMPT)+1)) + + IF (IER.EQ.-2) THEN + IER = RMS$_EOF + ELSE IF (IER.LE.0) THEN + IER = %LOC(CLI$_NOCOMD) + ELSE + DO WHILE (IER.GT.0.AND.INCMD(:1).EQ.' ') + INCMD = INCMD(2:IER) + IER = IER - 1 + END DO + DO WHILE (IER.GT.0.AND. + & INCMD(IER:IER).GE.'0'.AND.INCMD(IER:IER).LE.'9') + IER = IER - 1 + END DO + IF (IER.EQ.0) INCMD = 'READ '//INCMD + IER=CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS,LIB$GET_INPUT) + END IF + + IF (IER.EQ.RMS$_EOF) THEN + GO TO 999 ! If no command, exit + ELSE IF (IER.EQ.%LOC(CLI$_NOCOMD)) THEN ! If just RETURN entered + LEN_P = 0 ! Indicate no parameter in command + IF (DIR_COUNT.GT.0) THEN ! If still more dir entries + CALL DIRECTORY(DIR_COUNT) ! continue outputting them + ELSE IF (INDEX_COUNT.GT.0) THEN + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (FOLDER_COUNT.GT.0) THEN ! If more folder entries + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! continue outputting them + ELSE ! Else try to read next bulletin + CALL READ(READ_COUNT,BULL_POINT+1) ! or finish old one + END IF + GO TO 100 ! Loop to read new command + ELSE IF (.NOT.IER) THEN ! If command has error + GO TO 100 ! ask for new command + END IF + + DIR_COUNT = 0 ! Reinit display pointers + READ_COUNT = 0 + FOLDER_COUNT = 0 + INDEX_COUNT = 0 + + IER = MIN(INDEX(INCMD(:TRIM(INCMD)),' '),INDEX(INCMD,'/')) + IF (IER.GT.0) INCMD = ' '//INCMD(IER:) ! Save qualifiers + CALL CLI$GET_VALUE('$VERB',INCMD(:4)) ! Get user's command. + IF (READ_ONLY.AND.(INCMD(:3).EQ.'ADD'.OR.INCMD(:3).EQ.'DEL' + & .OR.INCMD(:3).EQ.'CHA'.OR.INCMD(:3).EQ.'REP')) THEN + ! FOLDER can only be read? + WRITE (6,'('' ERROR: Access to folder limited to reading.'')') + ELSE IF (INCMD(:3).EQ.'ADD') THEN ! ADD? + CALL ADD + ELSE IF (INCMD(:4).EQ.'BACK') THEN ! BACK? + IF (BULL_POINT.LE.1) THEN + WRITE(6,1060) + ELSE + CALL READ(READ_COUNT,BULL_POINT-1) ! Try to read previous bull + END IF + ELSE IF (INCMD(:4).EQ.'CHAN') THEN ! CHANGE? + CALL REPLACE ! Replace old bulletin + ELSE IF (INCMD(:4).EQ.'COPY') THEN ! COPY? + CALL MOVE(.FALSE.) + ELSE IF (INCMD(:4).EQ.'CREA') THEN ! CREATE? + CALL CREATE_FOLDER ! Go create the folder + ELSE IF (INCMD(:4).EQ.'CURR') THEN ! CURRENT? + READ_COUNT = -1 ! Reread current message from beginning. + CALL READ(READ_COUNT,BULL_POINT) + ELSE IF (INCMD(:4).EQ.'DELE') THEN ! DELETE? + CALL DELETE ! Go delete bulletin + ELSE IF (INCMD(:4).EQ.'DIRE') THEN ! DIRECTORY? + IF (CLI$PRESENT('FOLDER')) THEN ! /FOLDER specified? + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! Show all folders + ELSE IF (CLI$PRESENT('SELECT_FOLDER')) THEN! Folder specified? + CALL SELECT_FOLDER(.TRUE.,IER) ! Try to select folder + IF (IER) THEN ! If successful + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE IF (INCMD(:4).EQ.'FILE'.OR. + & INCMD(:4).EQ.'EXTR') THEN ! FILE? + CALL FILE ! Copy bulletin to file + ELSE IF (INCMD(:1).EQ.'E'.OR. + & INCMD(:4).EQ.'QUIT') THEN ! EXIT? + GO TO 999 ! Exit from program + ELSE IF (INCMD(:4).EQ.'HELP') THEN ! HELP? + CALL HELP(HELP_DIRECTORY(:HLEN)//'BULL.HLB') ! Get help + ELSE IF (INCMD(:3).EQ.'IND') THEN ! INDEX? + INDEX_COUNT = 1 + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (INCMD(:4).EQ.'LAST') THEN ! LAST? + READ_COUNT = -1 + BULL_READ = 99999 + CALL READ(READ_COUNT,BULL_READ) + ELSE IF (INCMD(:4).EQ.'MARK') THEN ! MARK? + CALL TAG(.TRUE.) + ELSE IF (INCMD(:4).EQ.'MAIL') THEN ! MAIL? + CALL MAIL(MAIL_STATUS) + ELSE IF (INCMD(:3).EQ.'MOD') THEN ! MODIFY? + CALL MODIFY_FOLDER + ELSE IF (INCMD(:4).EQ.'MOVE') THEN ! MOVE? + CALL MOVE(.TRUE.) + ELSE IF (INCMD(:4).EQ.'NEXT') THEN ! NEXT? + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + ELSE IF (INCMD(:4).EQ.'POST') THEN ! POST? + CALL RESPOND(MAIL_STATUS) + ELSE IF (INCMD(:4).EQ.'PRIN') THEN ! PRINT? + CALL PRINT ! Printout bulletin + ELSE IF (INCMD(:4).EQ.'READ') THEN ! READ? + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Bulletin specified? + DECODE(LEN_P,'(I)',BULL_PARAMETER) BULL_READ ! Yes + READ_COUNT = -1 + CALL READ(READ_COUNT,BULL_READ) + ELSE + CALL READ(READ_COUNT,BULL_POINT+1) + END IF + ELSE IF (INCMD(:3).EQ.'REM') THEN ! REMOVE? + CALL REMOVE_FOLDER + ELSE IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + CALL REPLY + ELSE IF (INCMD(:3).EQ.'RES') THEN ! RESPOND? + CALL RESPOND(MAIL_STATUS) + ELSE IF (INCMD(:3).EQ.'SEA') THEN ! SEARCH? + CALL SEARCH(READ_COUNT) + ELSE IF (INCMD(:3).EQ.'SEL') THEN ! SELECT? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (INCMD(:3).EQ.'SET') THEN ! SET? + CALL CLI$GET_VALUE('SET_PARAM1',BULL_PARAMETER) + IF (BULL_PARAMETER(:1).EQ.'F') THEN ! SET FOLDER? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRI') THEN ! SET PRIVS? + CALL SET_PRIV + ELSE IF (BULL_PARAMETER(:2).EQ.'PA') THEN ! SET PAGE? + PAGING = .TRUE. + WRITE (6,'('' PAGE has been set.'')') + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SET KEYPAD? + CALL SET_KEYPAD + ELSE IF (BULL_PARAMETER(:3).EQ.'NOK') THEN ! SET NOKEYPAD? + CALL SET_NOKEYPAD + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPA') THEN ! SET NOPAGE? + PAGING = .FALSE. + WRITE (6,'('' NOPAGE has been set.'')') + ELSE IF (FOLDER_NUMBER.EQ.-1) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + ELSE IF (BULL_PARAMETER(:2).EQ.'SY') THEN ! SET SYSTEM? + CALL SET_SYSTEM(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOSY') THEN ! SET NOSYSTEM? + CALL SET_SYSTEM(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'BB') THEN ! SET BBOARD? + CALL SET_BBOARD(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBB') THEN ! SET NOBBOARD? + CALL SET_BBOARD(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'DU') THEN ! SET DUMP? + CALL SET_FOLDER_FLAG(.TRUE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODU') THEN ! SET NODUMP? + CALL SET_FOLDER_FLAG(.FALSE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:2).EQ.'ST') THEN ! SET STRIP? + CALL SET_FOLDER_FLAG(.TRUE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOST') THEN ! SET NOSTRIP? + CALL SET_FOLDER_FLAG(.FALSE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:2).EQ.'DI') THEN ! SET DIGEST? + CALL SET_FOLDER_FLAG(.TRUE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODI') THEN ! SET NODIGEST? + CALL SET_FOLDER_FLAG(.FALSE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOTI') THEN ! SET NOTIFY? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(1,-1,-1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(1,-2,-2) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(1,4) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'E') THEN ! SET EXPIRE? + IER = CLI$GET_VALUE('EXPIRATION',BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.3) THEN + READ (BULL_PARAMETER,'(I)') LIMIT + CALL SET_FOLDER_EXPIRE_LIMIT(LIMIT) + ELSE + WRITE (6,'('' ERROR: Invalid expiration specified.'')') + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NODE') THEN ! SET NODE? + CALL SET_NODE(.TRUE.) + ELSE IF (BULL_PARAMETER(:6).EQ.'NONODE') THEN ! SET NONODE? + CALL SET_NODE(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOE') THEN ! SET NOEXPIRE? + CALL SET_FOLDER_EXPIRE_LIMIT(0) + ELSE IF (BULL_PARAMETER(:5).EQ.'NONOT') THEN ! SET NONOTIFY? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(0,-1,-1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(0,-2,-2) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,4) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'S') THEN ! SET SHOWNEW? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET SHOWNEW not allowed for GENERAL folder.'')') + ELSE IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,1) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(1,3) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOS') THEN ! SET NOSHOWNEW? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET NOSHOWNEW not allowed for GENERAL folder.'')') + ELSE IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(0,3) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'R') THEN ! SET READNEW? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,1,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,1,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(1,2) + CALL CHANGE_FLAG(0,3) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOR') THEN ! SET NOREADNEW? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(0,3) + END IF + ELSE IF (BULL_PARAMETER(:2).EQ.'BR') THEN ! SET BRIEF? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET BRIEF not allowed for GENERAL folder.'')') + ELSE + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,1,1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,1,1) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(1,2) + CALL CHANGE_FLAG(1,3) + END IF + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBR') THEN ! SET NOBRIEF? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET NOBRIEF not allowed for GENERAL folder.'')') + ELSE + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(0,3) + END IF + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'A') THEN ! SET ACCESS? + CALL SET_ACCESS(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOA') THEN ! SET NOACCESS? + CALL SET_ACCESS(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'G') THEN ! SET GENERIC? + CALL SET_GENERIC(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOG') THEN ! SET NOGENERIC? + CALL SET_GENERIC(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'L') THEN ! SET LOGIN? + CALL SET_LOGIN(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOL') THEN ! SET NOLOGIN? + CALL SET_LOGIN(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRO') THEN ! SET PROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.FALSE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPR') THEN ! SET NOPROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.TRUE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:3).EQ.'DEF') THEN ! SET DEFAULT_EXPIRE? + CALL SET_DEFAULT_EXPIRE + END IF + ELSE IF (INCMD(:4).EQ.'SHOW') THEN ! SHOW? + CALL CLI$GET_VALUE('SHOW_PARAM1',BULL_PARAMETER,LEN_P) + IF (BULL_PARAMETER(:2).EQ.'FL') THEN ! SHOW FLAGS? + CALL SHOW_FLAGS + ELSE IF (BULL_PARAMETER(:2).EQ.'FO') THEN ! SHOW FOLDER? + CALL SHOW_FOLDER + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SHOW KEYPAD + CALL SHOW_KEYPAD(HELP_DIRECTORY(:HLEN)//'BULL.HLB') + ELSE IF (BULL_PARAMETER(:1).EQ.'N') THEN ! SHOW NEW? + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + SAVE_FOLDER = FOLDER + DO FOLDER_NUMBER = 0,FOLDER_MAX-1 + IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + CALL SELECT_FOLDER(.FALSE.,IER) + IF (NBULL.GT.0) THEN + DIFF = COMPARE_BTIM( + & LAST_READ_BTIM(1,FOLDER_NUMBER+1),F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN + WRITE (6,'('' There are new messages in folder '' + & ,A,''.'')') FOLDER(:TRIM(FOLDER)) + END IF + END IF + END IF + END DO + FOLDER1 = SAVE_FOLDER + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE IF (BULL_PARAMETER(:1).EQ.'P') THEN ! SHOW PRIVILEGES? + CALL SHOW_PRIV + ELSE IF (BULL_PARAMETER(:1).EQ.'U') THEN ! SHOW USER? + CALL SHOW_USER + ELSE IF (BULL_PARAMETER(:1).EQ.'V') THEN ! SHOW VERSION? + CALL SHOW_VERSION + END IF + ELSE IF (INCMD(:4).EQ.'SPAW') THEN ! SPAWN command? + CALL SPAWN_PROCESS + ELSE IF (INCMD(:4).EQ.'UNDE') THEN ! UNDELETE? + CALL UNDELETE + ELSE IF (INCMD(:3).EQ.'UNM') THEN ! UNMARK? + CALL TAG(.FALSE.) + END IF + +100 CONTINUE + + END DO + +999 CALL EXIT + +1010 FORMAT(Q,A) +1060 FORMAT(' ERROR: There are no more messages.') + + END + + + + + + SUBROUTINE ADD +C +C SUBROUTINE ADD +C +C FUNCTION: Adds bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER INEXDATE*11,INEXTIME*11 + CHARACTER*(LINE_LENGTH) INDESCRIP + + CHARACTER INLINE*80,OLD_FOLDER*25,LOCAL_NODE*8 + CHARACTER PASSWORD*31,DEFAULT_USER*12 + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + ALLOW = SETPRV_PRIV() + + OLD_FOLDER_NUMBER = FOLDER_NUMBER + OLD_FOLDER = FOLDER + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (.NOT.ALLOW) THEN ! If no SETPRV privileges, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD',READONLY, + & SHARED,ERR=920,FORM='FORMATTED') ! Try opening the file + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + ELSE IF (CLI$PRESENT('TEXT')) THEN + BULL_PARAMETER = 'SYS$LOGIN:BULL.SCR' + LEN_P = TRIM(BULL_PARAMETER) + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH, + & STATUS='NEW',CARRIAGECONTROL='LIST',FORM='FORMATTED') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + +90 CALL CLOSE_BULLFIL + END IF + + SELECT_FOLDERS = .FALSE. + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL GET_FOLDER_INFO(IER) + IF (.NOT.IER) GO TO 910 + SELECT_FOLDERS = .TRUE. + ELSE + NODE_NUM = 1 + NODES(1) = OLD_FOLDER + END IF + + IER = CLI$GET_VALUE('USERNAME',DEFAULT_USER) + IF (.NOT.IER) DEFAULT_USER = USERNAME + IF (DECNET_PROC) THEN ! Running via DECNET? + USERNAME = DEFAULT_USER + CALL CONFIRM_PRIV(USERNAME,ALLOW) + END IF + + IF (FOLDER_NUMBER.GT.0.AND. ! If folder set and + & CLI$PRESENT('NODES')) THEN ! Decnet nodes specified? + WRITE (6,'('' ERROR: /NODES cannot be used with folder set.'')') + GO TO 910 + END IF + + IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0.AND. + & (CLI$PRESENT('SYSTEM').OR. ! Is /SYSTEM switch present? + & CLI$PRESENT('BROADCAST').OR. ! Is /BROADCAST swtich present? + & CLI$PRESENT('SHUTDOWN'))) THEN ! Is /SHUTDOWN switch present? + WRITE (6,'('' ERROR: Folder is not a SYSTEM folder.'')') + GO TO 910 + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN ! Is /SYSTEM switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1070) ! Tell user + GO TO 910 ! and abort + END IF + SYSTEM = 1 ! Set system bit + ELSE + SYSTEM = 0 ! Clear system bit + END IF + + IF (CLI$PRESENT('BROADCAST')) THEN ! Is /BROADCAST switch present? + IF (.NOT.(ALLOW.OR.OPER_PRIV())) THEN ! If no privileges + WRITE(ERROR_UNIT,1080) ! Tell user + GO TO 910 ! and abort + END IF + END IF + + IF (CLI$PRESENT('PERMANENT')) THEN ! Is /PERMANENT switch present? + IF (.NOT.ALLOW.AND..NOT.FOLDER_SET) THEN ! If no privileges + WRITE(ERROR_UNIT,1081) ! Tell user + GO TO 910 ! and abort + ELSE IF (F_EXPIRE_LIMIT.GT.0.AND..NOT.ALLOW ! Expiration limit + & .AND.USERNAME.NE.FOLDER_OWNER) THEN ! is present + WRITE(ERROR_UNIT,1083) + GO TO 910 + ELSE + SYSTEM = SYSTEM.OR.2 ! Set permanent bit + INEXDATE = '5-NOV-2000' + INEXTIME = '00:00:00.00' + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN ! Is /SHUTDOWN switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1082) ! Tell user + GO TO 910 ! and abort + ELSE + IER = CLI$GET_VALUE('SHUTDOWN',INLINE) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (REMOTE_SET) THEN ! Can't specify node name if + WRITE (6,1090) ! remote folder, as no code + GO TO 910 ! present to send the name. + END IF + CALL GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,INLINE) + IF (NODE_AREA.EQ.0) GO TO 910 ! Invalid node name + ELSE + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + END IF + SYSTEM = SYSTEM.OR.4 ! Set shutdown bit + INEXDATE = '5-NOV-2000' + WRITE (INEXTIME,'(I4)') NODE_NUMBER + WRITE (INEXTIME(7:),'(I4)') NODE_AREA + DO I=1,11 + IF (INEXTIME(I:I).EQ.' ') INEXTIME(I:I) = '0' + END DO + INEXTIME = INEXTIME(1:2)//':'//INEXTIME(3:4)//':'// + & INEXTIME(7:8)//'.'//INEXTIME(9:10) + END IF + END IF + + SELECT_NODES = .FALSE. + IF (CLI$PRESENT('NODES')) THEN + CALL GET_NODE_INFO + IF (NODE_ERROR) GO TO 940 + SELECT_NODES = .TRUE. + END IF + + IF (SYSTEM.LE.1) THEN ! Not permanent or shutdown + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + + IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + INDESCRIP = DESCRIP ! Use description with RE:, + LENDES = TRIM(INDESCRIP) ! filled in by main subroutine + ELSE IF (CLI$PRESENT('SUBJECT')) THEN ! /SUBJECT specified + CALL CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + ELSE + WRITE(6,1050) ! Request header for bulletin + CALL GET_LINE(INDESCRIP,LENDES) ! Get input line + IF (LENDES.LE.0) GO TO 910 + END IF + + LENDES = MIN(LEN(INDESCRIP)-6,LENDES) ! Make room for "Subj: " + +C +C If file specified in ADD command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + IF (LEN_P.EQ.0) THEN ! If no file param specified + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + LEN_P = 1 + ELSE + CLOSE (UNIT=3) + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + END IF + END IF + + ICOUNT = 0 ! Line count for bulletin + + IF (LEN_P.GT.0) THEN ! If file param in ADD command + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + ICOUNT = ICOUNT + 1 + MIN(ILEN,80) + IF (ILEN.EQ.0) ICOUNT = ICOUNT + 1! COPY_BULL writes line with + END DO ! 1 space for blank line + ELSE ! If no input file + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) ! Temp file to save message + WRITE (6,1000) ! Request input from terminal + ILEN = LINE_LENGTH + 1 ! Length of input line + ICOUNT = 0 ! Character count counter + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Input line too long + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput:'')') LINE_LENGTH + ELSE IF (ILEN.GE.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN ! Update counter + WRITE(3,2010) INPUT(:ILEN) ! Save line in scratch file + END IF + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + REWIND (UNIT=3) + + IF (SELECT_NODES.AND.NODE_NUM.GT.0) THEN + INLINE = 'ADD' + IF (CLI$PRESENT('SYSTEM')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SYSTEM' + IF (CLI$PRESENT('BROADCAST')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BROADCAST' + IF (CLI$PRESENT('PERMANENT')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/PERMANENT' + IF (CLI$PRESENT('SHUTDOWN')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SHUTDOWN' + IF (CLI$PRESENT('BELL')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BELL' + + LEN_INLINE = STR$POSITION(INLINE,' ') - 1 + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + INLINE = INLINE(:LEN_INLINE) + SEMI = INDEX(NODES(POINT_NODE),'::') ! Look for semicolons + ILEN = TRIM(NODES(POINT_NODE)) ! Length of node name + IF (SEMI.GT.0) THEN ! Are semicolon found? + IF (ILEN.GT.SEMI+1) THEN ! Is username found? + TEMP_USER = NODES(POINT_NODE)(SEMI+2:) ! Yes + ILEN = SEMI - 1 ! Remove semicolons + ELSE ! No username found... + TEMP_USER = DEFAULT_USER ! Set user to default + ILEN = SEMI - 1 ! Remove semicolons + SEMI = 0 ! Indicate no username + END IF + ELSE ! No semicolons present + TEMP_USER = DEFAULT_USER ! Set user to default + END IF + IER = 1 + DO WHILE ((INLINE.NE.'ADD'.OR.SEMI.GT.0.OR. + & CLI$PRESENT('USERNAME')).AND.IER.NE.0) + WRITE(6,'('' Enter password for node '',2A)') + & NODES(POINT_NODE),CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) GO TO 910 + OPEN (UNIT=10+NODE_NUM,NAME=NODES(POINT_NODE)(:ILEN)// + & '"'//TEMP_USER(:TRIM(TEMP_USER))//' '// + & PASSWORD(:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10+NODE_NUM) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + END IF + END DO + INLINE = INLINE(:STR$POSITION(INLINE,' ')-1) + & //'/USERNAME='//TEMP_USER + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + IF (SYSTEM.LE.1) ! If not permanent or shutdown specify date + & WRITE (POINT_NODE+9,'(A)',ERR=940) INEXDATE//' '//INEXTIME + WRITE (POINT_NODE+9,'(A)',ERR=940) INDESCRIP(:LENDES) + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + ILEN = MIN(ILEN,LINE_LENGTH) + IF (IER.EQ.0) THEN + WRITE (POINT_NODE+9,'(A)',ERR=940) INPUT(:ILEN) + END IF + END DO + WRITE (POINT_NODE+9,'(A)',ERR=940) CHAR(26) + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INPUT + IF (INPUT.EQ.'END') THEN + WRITE (6,'('' Message successfully sent to node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while sending message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INPUT(:80) + GO TO 940 + END IF + REWIND (UNIT=3) + END DO + END IF + + IF (SELECT_NODES.AND..NOT.LOCAL_NODE_FOUND) GO TO 95 + ! Exit if local node not specified. + + IF (.NOT.SELECT_FOLDERS) THEN + NODE_NUM = 1 ! No folders specified so just + NODES(1) = FOLDER ! add to select folder + END IF + + IER = SYS_TRNLNM('SYS$NODE',LOCAL_NODE) + LNODE = LEN(LOCAL_NODE) + LUSER = LEN(USERNAME) + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + BRDCST = .FALSE. + + DO I = 1,NODE_NUM + + IF (FOLDER.NE.NODES(I)) THEN + FOLDER_NUMBER = -1 + FOLDER1 = NODES(I) + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE + IER = 1 + END IF + + IF (IER) THEN + CALL OPEN_BULLDIR ! Prepare to add dir entry + + DESCRIP=INDESCRIP(:LENDES) ! Description header + EXDATE=INEXDATE ! Expiration date + EXTIME=INEXTIME + FROM = USERNAME ! Username + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + REWIND (UNIT=3) + OBLOCK = NBLOCK+1 + CALL STORE_BULL(LNODE+LUSER+6,'From: '// + & LOCAL_NODE(:LNODE)//USERNAME(:LUSER),OBLOCK) + IF (LENDES.GT.LEN(DESCRIP)) THEN + CALL STORE_BULL(LENDES+6, + & 'Subj: '//INDESCRIP(:LENDES),OBLOCK) + END IF + CALL COPY_BULL(3,1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) GO TO 930 ! Error in creating bulletin + LENGTH = OCOUNT - (NBLOCK+1) + 1 +C +C Broadcast the bulletin if requested. +C + IF (.NOT.BRDCST.AND.CLI$PRESENT('BROADCAST').AND. + & (.NOT.REMOTE_SET.OR.FOLDER_NUMBER.GT.0)) THEN + CALL GET_BROADCAST_MESSAGE(CLI$PRESENT('BELL')) + BRDCST = .TRUE. + IF (.NOT.CLI$PRESENT('LOCAL')) THEN + CALL BROADCAST_ALL_NODES(CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER')) + END IF + CALL BROADCAST( + & CLI$PRESENT('ALL'),CLI$PRESENT('CLUSTER')) + END IF + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CALL ADD_ENTRY ! Add the new directory entry + + IF (FOLDER_NUMBER.GE.0) THEN + CALL UPDATE_FOLDER ! Update info in folder file +C +C If user is adding message, update that user's last read time for +C folder, so user is not alerted of new message which is owned by user. +C + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + ELSE + WRITE (6,'('' ERROR: Unable to add message to '',A)') + & NODES(I) + END IF + END DO + +95 CLOSE (UNIT=3) ! Close the input file + IF (DECNET_PROC) WRITE(5,'(''END'')') ! DECNET operation worked + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + DO I=10,NODE_NUM+9 + CLOSE (UNIT=I) + END DO + + IF (FOLDER_NUMBER.NE.OLD_FOLDER_NUMBER) THEN + FOLDER_NUMBER = OLD_FOLDER_NUMBER + FOLDER1 = OLD_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + + IF (CLI$PRESENT('TEXT')) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + +910 WRITE(ERROR_UNIT,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(6,1020) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + GOTO 100 + +930 WRITE (ERROR_UNIT,1025) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + +940 WRITE (6,1015) NODES(POINT_NODE) + WRITE (6,1018) + CLOSE (UNIT=3) + GO TO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1010 FORMAT (' No message was added.') +1015 FORMAT (' ERROR: Unable to reach node ',A) +1018 FORMAT (' Try using /FOLDER instead of /NODE.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1025 FORMAT (' ERROR: Unable to add message to file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1070 FORMAT (' ERROR: SETPRV privileges are needed for system + & messages.') +1080 FORMAT (' ERROR: SETPRV privileges are needed to broadcast + & messages.') +1081 FORMAT (' ERROR: SETPRV privileges are needed to permanent + & messages.') +1082 FORMAT (' ERROR: SETPRV privileges are needed to shutdown + & messages.') +1083 FORMAT (' ERROR: Folder has expiration limit.') +1090 FORMAT (' ERROR: Nodename cannot be specified for shutdown + & if folder is remote.') +2010 FORMAT(A) +2020 FORMAT(1X,A) + + END + + + SUBROUTINE SUBTIME(BTIM,DAYS_BEFORE_TODAY,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER DAYS_BEFORE_TODAY*(*),TODAY_DATE*23 + + INTEGER BTIM(2),TODAY_BTIM(2) + + IER = SYS$BINTIM(DAYS_BEFORE_TODAY,BTIM) + IF (.NOT.IER) RETURN + + BTIM(1) = -BTIM(1) ! Convert to negative delta time + BTIM(2) = -BTIM(2)-1 + + IER = SYS$ASCTIM(TLEN,TODAY_DATE,,) + CALL SYS$BINTIM(TODAY_DATE(:TLEN),TODAY_BTIM) + + CALL LIB$SUBX(TODAY_BTIM,BTIM,BTIM) + + RETURN + END + + + + SUBROUTINE BROADCAST_ALL_NODES(ALL,CLUSTER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + COMMON /BROAD_MESSAGE/ BMESSAGE,BLENGTH + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*8 LOCALNODE + + IF (.NOT.TEST_BULLCP().OR.REMOTE_SET) RETURN + + CALL OPEN_BULLUSER_SHARED + + REMOTE_FOUND = .FALSE. + TEMP_USER = ':' + + DO WHILE (.NOT.REMOTE_FOUND) + DO WHILE (REC_LOCK(IER)) + READ (4,KEYGT=TEMP_USER,IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM,NEW_FLAG + END DO + IF (TEMP_USER(:1).NE.':') THEN + CALL CLOSE(4) + RETURN + END IF + REMOTE_FOUND = TEST2(NEW_FLAG,FOLDER_NUMBER) + END DO + + CALL CLOSE (4) + + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=NODENAME(:TRIM(NODENAME))//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IER = 0 + I = 1 + DO WHILE (IER.EQ.0.AND.I.LT.BLENGTH) + WRITE (17,'(4A)',IOSTAT=IER) + & 15,-1,I,BMESSAGE(I:MIN(BLENGTH,I+127)) + I = I + 128 + END DO + IF (IER.EQ.0) WRITE (17,'(7A)',IOSTAT=IER) + & 15,BLENGTH,I,ALL,CLUSTER,FOLDER_NUMBER,FOLDER + END IF + + CLOSE (UNIT=17) + + RETURN + END + + + + INTEGER FUNCTION ERROR_TRAP + + ERROR_TRAP = 1 + + RETURN + END + + + + SUBROUTINE REPLY + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLDIR.INC' + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + WRITE (6,'('' Adding REPLY message with the subject:'')') + CALL STR$UPCASE(BULL_PARAMETER,DESCRIP) + IF (BULL_PARAMETER(:3).NE.'RE:') THEN + DESCRIP = 'RE: '//DESCRIP + ELSE + DESCRIP = 'RE:'//DESCRIP(4:) + END IF + WRITE (6,'(1X,A)') DESCRIP + CALL ADD + + RETURN + END + + + + + SUBROUTINE CRELNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PSLDEF)' + + INCLUDE '($LNMDEF)' + + CHARACTER*(*) INPUT,OUTPUT + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT)) + CALL END_ITMLST(CRELNM_ITMLST) + + IER = SYS$CRELNM(,'LNM$PROCESS',INPUT,PSL$C_USER, + & %VAL(CRELNM_ITMLST)) + + RETURN + END + + + + SUBROUTINE GETPRIV +C +C SUBROUTINE GETPRIV +C +C FUNCTION: +C To get process privileges. +C OUTPUTS: +C PROCPRIV - Returned privileges +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /REALPROC/ REALPROCPRIV(2) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(8,JPI$_PROCPRIV,%LOC(PROCPRIV)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + REALPROCPRIV(1) = PROCPRIV(1) + REALPROCPRIV(2) = PROCPRIV(2) + + RETURN + END + + + + + LOGICAL FUNCTION SETPRV_PRIV + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + DATA NEEDPRIV/0,0/ + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (NEEDPRIV(1).EQ.0.AND.NEEDPRIV(2).EQ.0) THEN + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + CALL CLOSE_BULLUSER + NEEDPRIV(1) = USERPRIV(1) + NEEDPRIV(2) = USERPRIV(2) + END IF + + IF ((PROCPRIV(1).AND.NEEDPRIV(1)).GT.0.OR. + & (PROCPRIV(2).AND.NEEDPRIV(2)).GT.0) THEN + SETPRV_PRIV = .TRUE. + ELSE + SETPRV_PRIV = .FALSE. + END IF + + RETURN + END + + + + LOGICAL FUNCTION OPER_PRIV + IMPLICIT INTEGER (A-Z) + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + INCLUDE '($PRVDEF)' + OPER_PRIV = BTEST(PROCPRIV(1),PRV$V_OPER) + RETURN + END + + + + SUBROUTINE GETUSER(USERNAME) +C +C SUBROUTINE GETUSER +C +C FUNCTION: +C To get username of present process. +C OUTPUTS: +C USERNAME - Username owner of present process. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + CHARACTER*(*) USERNAME ! Limit is 12 characters + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + CALL CHECK_BULLETIN_PRIV(USERNAME) + + RETURN + END + + + SUBROUTINE SPAWN_PROCESS + + IMPLICIT INTEGER (A - Z) + + CHARACTER*255 COMMAND + + CALL DISABLE_PRIVS + IF (CLI$PRESENT('COMMAND')) THEN + CALL CLI$GET_VALUE('COMMAND',COMMAND,CLEN) + CALL LIB$SPAWN('$'//COMMAND(:CLEN)) + ELSE + CALL LIB$SPAWN() + END IF + CALL ENABLE_PRIVS + + RETURN + END diff --git a/decus/lt89b1/bulletin/bulletin0.for b/decus/lt89b1/bulletin/bulletin0.for new file mode 100644 index 0000000..506fad3 --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin0.for @@ -0,0 +1,1453 @@ +C +C BULLETIN0.FOR, Version 10/6/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE GET_BROADCAST_MESSAGE(RING_BELL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($BRKDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + +C +C The largest message that can be broadcasted is dependent on system +C and user quotas. The following limit is 12 lines of ( 80 characters + +C CR/LF ) + 2 bells. This should be more than enough room, as broadcasts +C shouldn't be too large anyway. +C + + PARAMETER CR=CHAR(13),LF=CHAR(10),BELL=CHAR(7) + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BROAD + + COMMON /BROAD_MESSAGE/ BROAD,BLENGTH + + IF (RING_BELL) THEN ! Include BELL in message? + BROAD(:36) = ! Say who the bulletin is from + & BELL//BELL//CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 37 ! Start adding next line here + ELSE + BROAD(:34) = ! Say who the bulletin is from + & CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 35 ! Start adding next line here + END IF + + IF (REMOTE_SET) REWIND (UNIT=3) + + END = 0 + ILEN = LINE_LENGTH + 1 + I = I + 1 + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (REMOTE_SET) THEN + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0) RETURN + ELSE + CALL GET_BULL_LINE(NBLOCK+1,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0) I = I + 1 + IF (ILEN.GT.0.AND.(I.GT.2.OR.(INPUT(:6).NE.'From: '.AND. + & INPUT(:6).NE.'Subj: '))) THEN + END = BLENGTH + ILEN - 1 + 2 ! Check how long string will be + IF (END.GT.BRDCST_LIMIT) RETURN ! String too long? + BROAD(BLENGTH:END) = CR//LF//INPUT(:ILEN)! Else add new input + BLENGTH = END + 1 ! Reset pointer + END IF + END DO + + RETURN + + ENTRY BROADCAST(ALL,CLUSTER) + + IF (ALL) THEN ! Should we broadcast to ALL? + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,,,,,) + END IF + ELSE ! Else just broadcast to users. + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,,,,,) + END IF + END IF + + RETURN + END + + + SUBROUTINE GET_FOLDER_INFO(IER) +C +C SUBROUTINE GET_FOLDER_INFO +C +C FUNCTION: Obtains & verifies folder names from command line. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + CHARACTER NODE_TEMP*256 + + NODE_NUM = 0 ! Initialize number of nodes + DO WHILE (CLI$GET_VALUE('SELECT_FOLDER',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(:COMMA-1) + NODE_TEMP = NODE_TEMP(COMMA+1:) + ELSE + NODES(NODE_NUM) = NODE_TEMP + NODE_TEMP = ' ' + END IF + NLEN = TRIM(NODES(NODE_NUM)) + IF (NODES(NODE_NUM)(NLEN-1:NLEN).EQ.'::') THEN + NODES(NODE_NUM) = NODES(NODE_NUM)(:NLEN)//'GENERAL' + END IF + FOLDER_NUMBER = -1 + FOLDER1 = NODES(NODE_NUM) + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' Unable to access folder '',A)') + & NODES(NODE_NUM) + RETURN + ELSE IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No write access for folder '',A)') + & NODES(NODE_NUM) + IER = 0 + RETURN + END IF + END DO + END DO + + IER = 1 + + RETURN + END + + + + + + + SUBROUTINE DELETE +C +C SUBROUTINE DELETE +C +C FUNCTION: Deletes a bulletin entry from the bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER ANSWER*1,REMOTE_USER*12,SUBJECT*53 + + INTEGER NOW(2) + + IMMEDIATE = 0 + IF (CLI$PRESENT('IMMEDIATE')) IMMEDIATE = 1 + + IF (CLI$PRESENT('NODES')) THEN ! Delete messages on DECNET node? + CALL DELETE_NODE ! Yes... + RETURN + ELSE IF (DECNET_PROC) THEN ! Is this from remote node? + IER = CLI$GET_VALUE('USERNAME',REMOTE_USER) + IER = CLI$GET_VALUE('SUBJECT',SUBJECT,SLEN) + CALL STR$UPCASE(SUBJECT,SUBJECT) + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + DEL_BULL = 0 + IER = 1 + DO WHILE (DEL_BULL+1.EQ.IER) + DEL_BULL = DEL_BULL + 1 + CALL READDIR(DEL_BULL,IER) + CALL STR$UPCASE(DESCRIP,DESCRIP) + IF (DEL_BULL+1.EQ.IER.AND.REMOTE_USER.EQ.FROM + & .AND.INDEX(DESCRIP,SUBJECT(:SLEN)).GT.0) THEN + CALL REMOVE_ENTRY(DEL_BULL,DEL_BULL,DEL_BULL,IMMEDIATE) + CALL CLOSE_BULLDIR + WRITE (5,'(''END'')') ! Tell DECNET that delete went ok. + RETURN + END IF + END DO + CALL CLOSE_BULLDIR ! Specified message not found, + WRITE(ERROR_UNIT,1030) ! so error out. + RETURN + END IF + +C +C Get the bulletin number to be deleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT ! Delete the file we are reading + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1020) + RETURN + ELSE IF (EBULL.GT.F_NBULL.AND..NOT.REMOTE_SET.AND. + & SBULL.NE.EBULL) THEN + WRITE (6,'('' Last message specified > number in folder.'')') + WRITE (6,'('' Do you want to delete to end of folder? '',$)') + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') THEN + WRITE (6,'('' Deletion aborted.'')') + RETURN + ELSE + EBULL = F_NBULL + END IF + END IF + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + IF (REMOTE_SET) THEN + IF (SBULL.NE.EBULL) THEN + WRITE (6,1025) + RETURN + END IF + IF (SBULL.NE.BULL_POINT) CALL READDIR(SBULL,IER) + WRITE(REMOTE_UNIT,'(4A)',IOSTAT=IER) + & 4,SBULL,IMMEDIATE,DESCRIP + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,INPUT,F1_NEWEST_BTIM,) + NEWEST_EXDATE = INPUT(1:11) + NEWEST_EXTIME = INPUT(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + RETURN + END IF + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + DO BULL_DELETE = SBULL,EBULL + CALL READDIR(BULL_DELETE,IER) ! Get info for bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges? + & (.NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER + & .AND.FOLDER_SET)) THEN + WRITE(6,1040) ! No, then error out. + CALL CLOSE_BULLDIR + RETURN + ELSE IF (SBULL.EQ.EBULL) THEN + CALL CLOSE_BULLDIR + WRITE (6,1050) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') RETURN + CALL OPEN_BULLDIR + CALL READDIR(BULL_DELETE,IER) + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + END IF + +C +C Delete the bulletin directory entry. +C + CALL REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + END DO + + CALL CLOSE_BULLDIR + RETURN + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1025 FORMAT(' ERROR: Cannot delete multiple messages in remote folder.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not deleted. Not owned by you.') +1050 FORMAT(' Message is not owned by you.', + & ' Are you sure you want to delete it? ',$) + + END + + + + SUBROUTINE REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + INTEGER NOW(2) + + IF (IMMEDIATE.EQ.1) THEN ! Delete it immediately + + CALL DELETE_ENTRY(BULL_DELETE) ! Delete the directory entry + + IF ((SYSTEM.AND.4).EQ.4) THEN ! Was entry shutdown bulletin? + SHUTDOWN = SHUTDOWN - 1 ! Decrement shutdown count + END IF + ELSE ! Delete it eventually +C +C Change year of expiration date of message to 100 years less, +C to indicate that message is to be deleted. Then, set expiration date +C in header of folder to 15 minutes from now. Thus, the folder will be +C checked in 15 minutes (or more), and will delete the messages then. +C +C NOTE: If some comic set their expiration date to > 1999, then +C the deleted date will be set to 1899 since can't specify date <1859. +C + + IF (SYSTEM.LE.1) THEN ! General or System message + EXDATE = EXDATE(1:7)//'18'//EXDATE(10:) + IF (EXDATE(10:10).LT.'6') EXDATE(10:11) = '99' + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(1:6)//'19'//EXDATE(9:) + ELSE + EXDATE = EXDATE(1:7)//'19'//EXDATE(10:) + END IF + END IF + + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + + IER = SYS$BINTIM('0 0:15',EX_BTIM) ! Get time 15 minutes from now + IER = SYS$GETTIM(NOW) + IER = LIB$SUBX(NOW,EX_BTIM,EX_BTIM) + IER = SYS$ASCTIM(,INPUT,EX_BTIM,) + + END IF + + IF (IMMEDIATE.NE.1.AND.BULL_DELETE.EQ.EBULL) THEN + CALL READDIR(0,IER) ! Get header + + NEWEST_EXDATE = INPUT(1:11) ! and store new expiration date + NEWEST_EXTIME = INPUT(13:) + + CALL WRITEDIR(0,IER) + ELSE IF (BULL_DELETE.EQ.EBULL) THEN + CALL CLEANUP_DIRFILE(SBULL) ! Reorder directory file + + CALL UPDATE_ALWAYS ! Somewhat a kludgey way of updating latest + ! bulletin and expired dates. + + IF (SBULL.LE.BULL_POINT) THEN + IF (BULL_POINT.GT.EBULL) THEN + BULL_POINT = BULL_POINT - (EBULL - SBULL + 1) + ELSE + BULL_POINT = SBULL + END IF + END IF ! Readjust where which bulletin to read next + ! if deletion causes messages to be moved. + END IF + + RETURN + END + + + + + + SUBROUTINE GET_2_VALS(INPUT,ILEN,SVAL,EVAL,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT + + DELIM = MAX(INDEX(INPUT,':'),INDEX(INPUT,'-')) + + IF (DELIM.EQ.0) THEN + DECODE(ILEN,'(I)',INPUT,IOSTAT=IER) SVAL + EVAL = SVAL + ELSE + DECODE(DELIM-1,'(I)',INPUT,IOSTAT=IER) SVAL + IF (IER.EQ.0) THEN + ILEN = ILEN - DELIM + DECODE(ILEN,'(I)',INPUT(DELIM+1:),IOSTAT=IER) EVAL + END IF + IF (EVAL.LT.SVAL) IER = 2 + END IF + + RETURN + END + + + + SUBROUTINE DIRECTORY(DIR_COUNT) +C +C SUBROUTINE DIRECTORY +C +C FUNCTION: Display directory of messages. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + DATA SCRATCH_D1/0/ + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED,CLI$_PRESENT + + CHARACTER START_PARAMETER*16,DATETIME*23 + + INTEGER TODAY(2) + + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + IF (INCMD(:3).EQ.'DIR'.AND..NOT.READ_TAG) THEN + IF (.NOT.CLI$PRESENT('SELECT_FOLDER').AND. + & CLI$PRESENT('MARKED')) THEN + IF (FOLDER_NUMBER.GE.0) THEN + READ_TAG = .TRUE. + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + ELSE + WRITE (6,'('' ERROR: Cannot use /MARKED with'', + & '' remote folder.'')') + RETURN + END IF + END IF + END IF + +C +C Directory listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C directory file, and to avoid the possibility of the user holding the screen, +C and thus causing the directory file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + CALL INIT_QUEUE(SCRATCH_D1,BULLDIR_ENTRY) + SCRATCH_D = SCRATCH_D1 + + CALL OPEN_BULLDIR_SHARED ! Get directory file + + CALL READDIR(0,IER) ! Does directory header exist? + IF (IER.EQ.1.AND.NBULL.GT.0) THEN ! And are there messages? + IF (DIR_COUNT.EQ.0) THEN + IF (CLI$PRESENT('START')) THEN ! Start number specified? + IER = CLI$GET_VALUE('START',START_PARAMETER,ILEN) + DECODE(ILEN,'(I)',START_PARAMETER) DIR_COUNT + IF (DIR_COUNT.GT.NBULL) THEN + DIR_COUNT = NBULL + ELSE IF (DIR_COUNT.LT.1) THEN + WRITE (6,'('' ERROR: Invalid starting message.'')') + CALL CLOSE_BULLDIR + DIR_COUNT = 0 + RETURN + END IF + ELSE IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + IF (CLI$PRESENT('SINCE')) THEN ! Was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present in'', + & '' folder '',A,''.'')') FOLDER(:TRIM(FOLDER)) + CALL CLOSE_BULLDIR + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + END IF + + CALL READDIR_KEYGE(IER) + + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + CALL CLOSE_BULLDIR + RETURN + ELSE + DIR_COUNT = IER + END IF + ELSE + DIR_COUNT = BULL_POINT + IF (DIR_COUNT.EQ.0) DIR_COUNT = 1 + END IF + + IF (READ_TAG) THEN + IF (.NOT.(CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW') + & .OR.CLI$PRESENT('START'))) THEN + DIR_COUNT = 1 + END IF + CALL READDIR(DIR_COUNT,IER1) + IF (IER1.EQ.DIR_COUNT+1) IER1 = 0 + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + END IF + + IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + ELSE IF (NBULL-DIR_COUNT+1.LE.PAGE_LENGTH-5) THEN + EBULL = NBULL + SBULL = NBULL - (PAGE_LENGTH-5) + 1 + IF (SBULL.LT.1) SBULL = 1 + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + END IF + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + END IF + IF (.NOT.PAGING) THEN + EBULL = NBULL + END IF + IF (.NOT.REMOTE_SET.AND..NOT.READ_TAG) THEN + DO I=SBULL,EBULL ! Copy messages from file + CALL READDIR(I,IER) ! Into the queue + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + END DO + ELSE IF (READ_TAG) THEN + I = SBULL + DO WHILE (I.LE.EBULL.AND.IER1.EQ.0) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,DIR_COUNT) + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + I = I + 1 + END DO + EBULL = I - 1 + IF (IER1.NE.0) EBULL = EBULL - 1 + ELSE + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,SBULL,EBULL + IF (IER.EQ.0) THEN + I = SBULL + DO WHILE (IER.EQ.0.AND.I.LE.EBULL) + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + I = I + 1 + END DO + END IF + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + RETURN + END IF + END IF + ELSE + NBULL = 0 + END IF + + CALL CLOSE_BULLDIR ! We don't need file anymore + + IF (NBULL.EQ.0) THEN + WRITE (6,'('' There are no messages present.'')') + RETURN + END IF + +C +C Directory entries are now in queue. Output queue entries to screen. +C + + FLEN = TRIM(FOLDER) + WRITE(6,'(X,A)') FOLDER(:FLEN) + WRITE(6,1000) ! Write header + N = 3 + + IF (BULL_TAG.AND..NOT.READ_TAG) THEN + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + + DO I=SBULL,EBULL + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + CALL CONVERT_ENTRY_FROMBIN + IF (MSG_NUM.GT.999) N = 4 + IF (MSG_NUM.GT.9999) N = 5 + IF (READ_TAG.OR.(BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG)) THEN + WRITE (6,'('' *'',$)') + ELSE + WRITE (6,'('' '',$)') + END IF + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM,'(DELETED)' + ELSE + WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM, + & DATE(1:7)//DATE(10:11) + END IF + IF (BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG) THEN + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + END DO + + DIR_COUNT = MSG_NUM + 1 ! Update directory counter + + IF (DIR_COUNT.GT.NBULL.OR.(READ_TAG.AND.IER1.NE.0)) THEN + ! Outputted all entries? + DIR_COUNT = 0 ! Yes. Set counter to 0. + ELSE + WRITE(6,1010) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(' #',1X,'Description',43X,'From',9X,'Date',/) +1010 FORMAT(1X,/,' Press RETURN for more...',/) + +2010 FORMAT('+',I,1X,A<55-N>,1X,A12,1X,A9) + + END + + + SUBROUTINE GET_MSGKEY(BTIM,MSG_KEY) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*8 MSG_KEY,INPUT + + CALL LIB$MOVC3(8,BTIM(1),%REF(INPUT)) + + DO I=1,8 + MSG_KEY(I:I) = INPUT(9-I:9-I) + END DO + + RETURN + END + + + + SUBROUTINE FILE +C +C SUBROUTINE FILE +C +C FUNCTION: Copies a bulletin to a file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN ! If no file name was specified + WRITE(6,1020) ! Write error + RETURN ! And return + END IF + + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + + IF (CLI$PRESENT('NEW')) THEN + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH, + & STATUS='UNKNOWN',CARRIAGECONTROL='LIST',ACCESS='APPEND') + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + DO FBULL = SBULL,EBULL + CALL READDIR(FBULL,IER) ! Get info for specified bulletin + + IF (IER.NE.FBULL+1) THEN ! Was bulletin found? + WRITE(6,1030) FBULL + IF (FBULL.GT.SBULL) GO TO 100 + CLOSE (UNIT=3,STATUS='DELETE') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + RETURN + END IF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + END DO + +100 CLOSE (UNIT=3) ! Bulletin copy completed + + WRITE(6,1040) BULL_PARAMETER(1:LEN_P) + ! Show name of file created. + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + + RETURN + +900 WRITE(6,1000) + CALL ENABLE_PRIVS ! Reset BYPASS privileges + RETURN + +1000 FORMAT(' ERROR: Error in opening file.') +1010 FORMAT(' ERROR: You have not read any bulletin.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1020 FORMAT(' ERROR: No file name was specified.') +1030 FORMAT(' ERROR: Following bulletin was not found: ',I) +1040 FORMAT(' Message(s) written to ',A) +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,/,'Date: ',A) + + END + + + + + SUBROUTINE LOGIN +C +C SUBROUTINE LOGIN +C +C FUNCTION: Alerts user of new messages upon logging in. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /READIT/ READIT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /POINT/ BULL_POINT + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY*23,INREAD*1 + + LOGICAL*1 CTRL_G/7/ + + DATA GEN_DIR1/0/ ! General directory link list header + DATA SYS_DIR1/0/ ! System directory link list header + DATA SYS_NUM1/0/ ! System message number link list header + DATA SYS_BUL1/0/ ! System bulletin link list header + DATA ALL_DIR1/0/ ! Full directory link list header (for remote) + + DATA PAGE/0/ + + DATA FIRST_WRITE/.TRUE./ + LOGICAL FIRST_WRITE + + DIMENSION NOLOGIN_BTIM(2),LOGIN_BTIM_SAVE(2),TODAY_BTIM(2) + DIMENSION NEW_BTIM(2),PASSCHANGE(2),BULLCP_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + CALL SYS_BINTIM('5-NOV-1956 11:05:56',NEW_BTIM) + +C +C Find user entry in BULLUSER.DAT to update information and +C to get the last date that messages were read. +C + + CALL OPEN_BULLUSER_SHARED + + CALL MODIFY_SYSTEM_LIST(1) + + CALL READ_USER_FILE_HEADER(IER) ! Get the header + + IF (IER.EQ.0) THEN ! Header is present. + UNLOCK 4 + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + ! Find if there is an entry + IF (NEW_FLAG(1).LT.143.OR.NEW_FLAG(1).GT.143) THEN + NEW_FLAG(2)=0 ! If old version clear GENERIC value + NEW_FLAG(1)=143 ! Set new version number + END IF + IF (IER1.EQ.0) THEN ! There is a user entry + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + ! DISMAIL or SET LOGIN set + IF (CLI$PRESENT('ALL')) THEN + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + ELSE + RETURN ! Don't notify + END IF + END IF + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_ENTRY + IF (SYSTEM_FLAG(1).NE.0.AND.SYSTEM_FLAG(1).NE.1) READIT = 1 + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0.OR.BRIEF_FLAG(I).NE.0.OR. + & (I.GT.1.AND.SYSTEM_FLAG(I).NE.0)) READIT = 1 + END DO + ELSE + CALL CLEANUP_LOGIN ! Good time to delete dead users + READ_BTIM(1) = NEW_BTIM(1) ! Make new entry + READ_BTIM(2) = NEW_BTIM(2) + DO I = 1,FLONG + SET_FLAG(I) = SET_FLAG_DEF(I) + BRIEF_FLAG(I) = BRIEF_FLAG_DEF(I) + NOTIFY_FLAG(I) = NOTIFY_FLAG_DEF(I) + END DO + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) + IF (DISMAIL.EQ.1) THEN + LOGIN_BTIM(1) = NOLOGIN_BTIM(1) + LOGIN_BTIM(2) = NOLOGIN_BTIM(2) + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + ELSE + LOGIN_BTIM_SAVE(1) = NEW_BTIM(1) + LOGIN_BTIM_SAVE(2) = NEW_BTIM(2) + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0) READIT = 1 + END DO + IF (COMPARE_BTIM(PASSCHANGE,NEWEST_BTIM).LT.0) IER1 = 0 + ! Old password change indicates user is new to BULLETIN + ! but not to system, so don't limit message viewing. + END IF + CALL WRITE_USER_FILE(IER) + IF (IER.NE.0) THEN ! Error in writing to user file + WRITE (6,1070) ! Tell user of the error + CALL CLOSE_BULLUSER ! Close the user file + CALL EXIT ! Go away... + END IF + IF (DISMAIL.EQ.1) RETURN ! Go away if DISMAIL set + DIFF = -1 ! Force us to look at messages + CALL OPEN_BULLINF_SHARED + DO I=1,FOLDER_MAX + LAST_READ_BTIM(1,I) = READ_BTIM(1) + LAST_READ_BTIM(2,I) = READ_BTIM(2) + END DO + WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(I,J),I=1,2),J=1,FOLDER_MAX) + CALL CLOSE_BULLINF + END IF + LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) + LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) + CALL READ_USER_FILE_HEADER(IER2) ! Reset read back to header + END IF + + IF (IER.EQ.0.AND.MINUTE_DIFF(TODAY_BTIM,BBOARD_BTIM) + & .GT.BBOARD_UPDATE) THEN ! Update BBOARD mail? + BBOARD_BTIM(1) = TODAY_BTIM(1) + BBOARD_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_HEADER ! Rewrite header + CALL CLOSE_BULLUSER + IF (.NOT.TEST_BULLCP()) CALL CREATE_BBOARD_PROCESS + ELSE + CALL CLOSE_BULLUSER + IF (IER.NE.0) CALL EXIT ! If no header, no messages + END IF + + IF (IER1.EQ.0) THEN ! Skip date comparison if new entry +C +C Compare and see if messages have been added since the last time +C that the user has logged in or used the BULLETIN facility. +C + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,READ_BTIM) + IF (DIFF1.LT.0) THEN ! If read messages since last login, + LOGIN_BTIM(1) = READ_BTIM(1) ! then use the read date to compare + LOGIN_BTIM(2) = READ_BTIM(2) ! with the latest bulletin date + END IF ! to see if should alert user. + + IF (SYSTEM_SWITCH) THEN + DIFF1 = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,NEWEST_BTIM) + ELSE + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,NEWEST_BTIM) + END IF + END IF + + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) ! These are destroyed in UPDATE_READ + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + + IF (NEW_FLAG(2).NE.0) THEN + CALL LIB$MOVC3(4,NEW_FLAG(2),%REF(BULL_PARAMETER)) + CALL SUBTIME(LOGIN_BTIM,BULL_PARAMETER(1:4),IER) + ELSE IF (DIFF1.GT.0) THEN + BULL_POINT = -1 + RETURN + END IF + +C +C If there are new messages, look for them in BULLDIR.DAT +C Save all new entries in the GEN_DIR file BULLCHECK.SCR so +C that we can close BULLDIR.DAT as soon as possible. +C + + ENTRY LOGIN_FOLDER + + IF (NEW_FLAG(2).EQ.0.OR.FOLDER_SET) THEN + LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) + LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) + END IF + + IF (REMOTE_SET) THEN ! If system remote folder, use remote + DIFF1 = COMPARE_BTIM(LOGIN_BTIM, ! info, not local login time + & LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF1.LT.0) THEN + LOGIN_BTIM(1) = LAST_READ_BTIM(1,FOLDER_NUMBER+1) + LOGIN_BTIM(2) = LAST_READ_BTIM(2,FOLDER_NUMBER+1) + ELSE + DIFF = MINUTE_DIFF(LOGIN_BTIM,F_NEWEST_BTIM) + IF (DIFF.GE.0.AND.DIFF.LE.15) THEN ! BULLCP updates every 15 min + IER = SYS$BINTIM('0 00:15',BULLCP_BTIM) + BULLCP_BTIM(1) = -BULLCP_BTIM(1) ! Convert to -delta time + BULLCP_BTIM(2) = -BULLCP_BTIM(2)-1 + CALL LIB$SUBX(LOGIN_BTIM,BULLCP_BTIM,LOGIN_BTIM) + END IF + END IF + END IF + + ENTRY SHOW_SYSTEM + + JUST_SYSTEM = (.NOT.LOGIN_SWITCH.AND.SYSTEM_SWITCH).OR. + & (FOLDER_NUMBER.GT.0.AND.BTEST(FOLDER_FLAG,2) + & .AND..NOT.TEST2(SET_FLAG,FOLDER_NUMBER) + & .AND..NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) + + NGEN = 0 ! Number of general messages + NSYS = 0 ! Number of system messages + BULL_POINT = -1 + + IF (IER1.NE.0.AND.FOLDER_NUMBER.GT.0) RETURN + ! Don't overwhelm new user with lots of non-general msgs + + IF (BTEST(FOLDER_FLAG,2).AND.SYSTEM_SWITCH) THEN + ! Can folder have SYSTEM messages and /SYSTEM specified? + LOGIN_BTIM(1) = SYSTEM_LOGIN_BTIM(1) ! Use specified login time + LOGIN_BTIM(2) = SYSTEM_LOGIN_BTIM(2) ! for system messages. + END IF + + CALL OPEN_BULLDIR_SHARED ! Get bulletin directory + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(0,IER) ! Get header info + ELSE + NBULL = F_NBULL + END IF + + CALL INIT_QUEUE(GEN_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_NUM1,%DESCR(ICOUNT)) + GEN_DIR = GEN_DIR1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + START = 1 + REVERSE = 0 + IF (REVERSE_SWITCH.AND.(.NOT.TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & .NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER))) THEN + REVERSE = 1 + IF (IER1.EQ.0) THEN + CALL GET_NEWEST_MSG(LOGIN_BTIM,START) + IF (START.EQ.-1) START = NBULL + 1 + END IF + END IF + + IF (REMOTE_SET) THEN + CALL INIT_QUEUE(ALL_DIR1,BULLDIR_ENTRY) + IF (REVERSE) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,START,NBULL + ELSE + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,NBULL,START + END IF + IF (IER.EQ.0) THEN + ALL_DIR = ALL_DIR1 + I = START + DO WHILE (IER.EQ.0.AND.I.LE.NBULL) + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY + CALL WRITE_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + I = I + 1 + END DO + END IF + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + RETURN + END IF + ALL_DIR = ALL_DIR1 + END IF + + DO ICOUNT1 = NBULL,START,-1 + IF (REVERSE) THEN + ICOUNT = NBULL + START - ICOUNT1 + ELSE + ICOUNT = ICOUNT1 + END IF + IF (REMOTE_SET) THEN + CALL READ_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + IER = ICOUNT + 1 + ELSE + CALL READDIR(ICOUNT,IER) + END IF + IF (IER1.EQ.0.AND.IER.EQ.ICOUNT+1) THEN ! Is this a totally new user? + ! No. Is bulletin system or from same user? + IF (.NOT.REVERSE) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM,MSG_BTIM) ! No, so compare date + IF (DIFF.GT.0) GO TO 100 + END IF + IF (.NOT.BTEST(FOLDER_FLAG,2)) SYSTEM = SYSTEM.AND.(.NOT.1) + ! Show system msg in non-system folder as general msg + IF (USERNAME.NE.FROM.OR.SYSTEM) THEN + IF (SYSTEM) THEN ! Is it system bulletin? + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (.NOT.JUST_SYSTEM) THEN + IF (SYSTEM_SWITCH) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,MSG_BTIM) + ELSE + DIFF = -1 + END IF + IF (DIFF.LT.0) THEN + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + SYSTEM = ICOUNT + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END IF + ELSE IF (IER.EQ.ICOUNT+1) THEN + ! Totally new user, save only permanent system msgs + IF (SYSTEM.EQ.3) THEN + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (NGEN.EQ.0) THEN ! And save only the first non-system msg + SYSTEM = ICOUNT ! Save bulletin number for display + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END DO +100 CALL CLOSE_BULLDIR +C +C Review new directory entries. If there are system messages, +C copy the system bulletin into GEN_DIR file BULLSYS.SCR for outputting +C to the terminal. If there are simple messages, just output the +C header information. +C + IF (NGEN.EQ.0.AND.NSYS.EQ.0) RETURN + + IF (NSYS.GT.0) THEN ! Are there any system messages? + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + LENF = TRIM(FOLDER) + S1 = (PAGE_WIDTH-(LENF+16))/2 + S2 = PAGE_WIDTH - S1 - (LENF + 16) + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE (6,1026) FOLDER(:LENF) ! Yep... + PAGE = PAGE + 1 + CTRL_G = 0 ! Don't ring bell for non-system bulls + CALL OPEN_BULLFIL_SHARED + CALL INIT_QUEUE(SYS_BUL1,INPUT) + SYS_BUL = SYS_BUL1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + NSYS_LINE = 0 + DO J=1,NSYS + CALL READ_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + IF (REMOTE_SET) THEN + CALL READ_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,ICOUNT + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER) + END IF + IF (IER.GT.0) THEN + CALL CLOSE_BULLFIL + RETURN + END IF + END IF + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin to SYS_BUL link list + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + IF (ILEN.LT.0) THEN + CALL CLOSE_BULLFIL + RETURN + END IF + IF (J.LT.NSYS.AND.SEPARATE.NE.' ') THEN + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + DO I=1,PAGE_WIDTH + INPUT(I:I) = SEPARATE + END DO + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 2 + END IF + END DO + CALL CLOSE_BULLFIL + SYS_BUL = SYS_BUL1 + ILEN = 0 + I = 1 + DO WHILE (I.LE.NSYS_LINE.OR.ILEN.GT.0) ! Write out system messages + IF (ILEN.EQ.0) THEN + CALL READ_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + ILEN = TRIM(INPUT) + I = I + 1 + END IF + IF (SYS_BUL.NE.0) THEN + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN + ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD,! Get terminal input + & 'HIT any key for next page....') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) '+'//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) '+'//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + ELSE + PAGE = PAGE + 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) ' '//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) ' '//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + END IF + END IF + END DO + IF (NGEN.EQ.0) THEN + WRITE(6,'(A)') ! Write delimiting blank line + END IF + PAGE = PAGE + 1 + END IF + + ENTRY REDISPLAY_DIRECTORY + + GEN_DIR = GEN_DIR1 + IF (NGEN.GT.0) THEN ! Are there new non-system messages? + LENF = TRIM(FOLDER) + S1 = (PAGE_WIDTH-13-LENF)/2 + S2 = PAGE_WIDTH-S1-13-LENF + IF (PAGE+5+NGEN.GT.PAGE_LENGTH.AND.PAGE.GT.0) THEN + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, ! Get terminal input + & 'HIT any key for next page....') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1028) 'New '//FOLDER(1:LENF)//' messages' + PAGE = 1 + ELSE + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1027) 'New '//FOLDER(1:LENF)//' messages' + PAGE = PAGE + 1 + END IF + WRITE(6,1020) + WRITE(6,1025) + PAGE = PAGE + 2 + I = 0 + DO WHILE (I.LT.NGEN) + I = I + 1 + CALL READ_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + CALL CONVERT_ENTRY_FROMBIN + IF (SYSTEM.GT.9999) THEN ! # Digits in message number + N = 5 + ELSE IF (SYSTEM.GT.999) THEN + N = 4 + ELSE + N = 3 + END IF + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, + & 'HIT Q(Quit listing) or any other key for next page....') + CALL STR$UPCASE(INREAD,INREAD) + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (INREAD.EQ.'Q') THEN + I = NGEN ! Quit directory listing + WRITE(6,'(''+Quitting directory listing.'')') + ELSE + WRITE(6,1040) '+'//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM + END IF + ! Bulletin number is stored in SYSTEM + ELSE + PAGE = PAGE + 1 + WRITE(6,1040) ' '//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM + END IF + END DO + IF ((.NOT.FOLDER_SET.AND.BTEST(SET_FLAG(1),0).AND.DIFF1.LE.0) + & .OR.(FOLDER_SET.AND.TEST2(SET_FLAG,FOLDER_NUMBER))) THEN + PAGE = 0 ! Don't reset page counter if READNEW not set, + END IF ! as no prompt to read is generated. + END IF +C +C Instruct users how to read displayed messages if READNEW not selected. +C + IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE(6,1030) + ELSE IF (NGEN.EQ.0) THEN + ILEN = 57 + INDEX(COMMAND_PROMPT,'>') - 1 + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-57)// + & '/SYSTEM command can be used to reread these messages.' + ELSE + FLEN = TRIM(FOLDER) + IF (FOLDER_NUMBER.EQ.0) FLEN = -1 + ILEN = 49 + INDEX(COMMAND_PROMPT,'>') - 1 + FLEN + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-48)// + & ' command can be used to read these messages.' + ELSE + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-49-FLEN) + & //' '//FOLDER(:FLEN)// + & ' command can be used to read these messages.' + END IF + END IF + + RETURN + +1020 FORMAT(' Description',43X,'From',9X,'Date',3X,'Number') +1025 FORMAT(' -----------',43X,'----',9X,'----',3X,'------') +1026 FORMAT(' ',('*'),A,' System Messages',('*')) +1027 FORMAT(/,' ',('*'),A,('*')) +1028 FORMAT('+',('*'),A,('*')) +1030 FORMAT(' ',('*')) +1035 FORMAT(' ',('*'),A,('*')) +1040 FORMAT(A<57-N>,1X,A12,1X,A6,<6-N>X,I) +1060 FORMAT(A) +1070 FORMAT(' ERROR: Cannot add new entry to user file.') +1080 FORMAT(' ',/) + + END + + + + SUBROUTINE GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,NODE_NAME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + CHARACTER*(*) NODE_NAME + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) + CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) + CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist + + IER = SYS$GETSYIW(,,NODE_NAME(:TRIM(NODE_NAME)), + & %VAL(GETSYI_ITMLST),,,) ! Get Info command. + + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Specified node name not found.'')') + NODE_AREA = 0 + END IF + + RETURN + END + diff --git a/decus/lt89b1/bulletin/bulletin1.for b/decus/lt89b1/bulletin/bulletin1.for new file mode 100644 index 0000000..fc51748 --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin1.for @@ -0,0 +1,1565 @@ +C +C BULLETIN1.FOR, Version 9/26/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE MAIL(STATUS) +C +C SUBROUTINE MAIL +C +C FUNCTION: Sends message which you have read to user via DEC mail. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*64 MAIL_SUBJECT + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + MAIL_SUBJECT = DESCRIP + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',MAIL_SUBJECT,LEN_D) + IF (LEN_D.GT.LEN(MAIL_SUBJECT)-2) THEN + WRITE(6,'('' ERROR: Subject limit is 64 characters.'')') + RETURN + END IF + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Error in opening scratch file.'')') + RETURN + END IF + + IF (CLI$PRESENT('HEADER')) THEN ! Printout header? + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + WRITE (3,'(A)') INPUT(:TRIM(INPUT)) + END IF + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Message copy completed + + CALL CLOSE_BULLFIL + + LEN_D = TRIM(MAIL_SUBJECT) + IF (LEN_D.EQ.0) THEN + MAIL_SUBJECT = 'BULLETIN message.' + LEN_D = TRIM(MAIL_SUBJECT) + END IF + + I = 1 + DO WHILE (I.LE.LEN_D) + IF (MAIL_SUBJECT(I:I).EQ.'"') THEN + IF (LEN_D.EQ.64) THEN + MAIL_SUBJECT(I:I) = '`' + ELSE + MAIL_SUBJECT = MAIL_SUBJECT(:I)//'"'//MAIL_SUBJECT(I+1:) + I = I + 1 + LEN_D = LEN_D + 1 + END IF + END IF + I = I + 1 + END DO + + LEN_P = 0 + DO WHILE (CLI$GET_VALUE('RECIPIENTS',BULL_PARAMETER(LEN_P+1:),I) + & .NE.%LOC(CLI$_ABSENT)) ! Get all the usernames + LEN_P = LEN_P + I + 1 + BULL_PARAMETER(LEN_P:LEN_P) = ',' + END DO + LEN_P = LEN_P - 1 + + I = 1 ! Must change all " to "" in MAIL recipients + DO WHILE (I.LE.LEN_P) + IF (BULL_PARAMETER(I:I).EQ.'"') THEN + BULL_PARAMETER = BULL_PARAMETER(:I)//'"'// + & BULL_PARAMETER(I+1:) + I = I + 1 + LEN_P = LEN_P + 1 + END IF + I = I + 1 + END DO + + CALL DISABLE_PRIVS + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR '//BULL_PARAMETER(:LEN_P) + & //'/SUBJECT="'//MAIL_SUBJECT(:LEN_D)//'"',,,,,,STATUS) + CALL ENABLE_PRIVS + + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR') + + RETURN + +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A) + + END + + + + SUBROUTINE MODIFY_FOLDER +C +C SUBROUTINE MODIFY_FOLDER +C +C FUNCTION: Modifies a folder's information. +C + IMPLICIT INTEGER (A - Z) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER PASSWORD*31,DEFAULT_USER*12 + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + RETURN + ELSE IF (FOLDER_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: No privileges to modify folder.'')') + RETURN + END IF + + IF (CLI$PRESENT('NAME')) THEN + IF (REMOTE_SET) THEN + WRITE (6,'('' ERROR: Cannot change name of'', + & '' remote folder.'')') + RETURN + ELSE + CALL CLI$GET_VALUE('NAME',FOLDER1,LEN_P) + IF (LEN_P.GT.25) THEN + WRITE (6,'('' ERROR: Folder name cannot be larger + & than 25 characters.'')') + RETURN + END IF + END IF + ELSE + FOLDER1 = FOLDER + END IF + + IF (CLI$PRESENT('DESCRIPTION')) THEN + WRITE (6,'('' Enter one line description of folder.'')') + LEN_P = 81 + DO WHILE (LEN_P.GT.80) + CALL GET_LINE(FOLDER1_DESCRIP,LEN_P) ! Get input line + IF (LEN_P.LE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + RETURN + ELSE IF (LEN_P.GT.80) THEN ! If too many characters + WRITE (6,'('' ERROR: Description must be < 80 characters.'')') + ELSE + FOLDER1_DESCRIP = FOLDER1_DESCRIP(:LEN_P) ! End fill with spaces + END IF + END DO + ELSE + FOLDER1_DESCRIP = FOLDER_DESCRIP + END IF + + IF (CLI$PRESENT('OWNER')) THEN + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner name is not valid username.'')') + RETURN + ELSE IF (LEN_P.GT.LEN(FOLDER1_OWNER)) THEN + WRITE (6,'('' ERROR: Folder owner name too long.'')') + RETURN + ELSE IF (.NOT.SETPRV_PRIV()) THEN + WRITE(6,'('' Enter password of new owner: '',A)') CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) THEN + WRITE (6,'('' ERROR: No password entered.'')') + RETURN + END IF + WRITE (6,'('' Attempting to verify password name...'')') + OPEN (UNIT=10,NAME='SYS$NODE"'// + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + & //' '//PASSWORD(:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + RETURN + ELSE + WRITE (6,'('' Password was verified.'')') + END IF + ELSE + FOLDER1_OWNER = FOLDER1_OWNER(:LEN_P) + END IF + ELSE + FOLDER1_OWNER = FOLDER_OWNER + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + + IF (CLI$PRESENT('NAME')) THEN + READ (7,IOSTAT=IER,KEY=FOLDER1,KEYID=0) + ! See if folder exists + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder name already exists.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + END IF + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (IER.EQ.0.AND.CLI$PRESENT('NAME')) THEN + LEN_F = TRIM(FOLDER_DIRECTORY) + IER = LIB$RENAME_FILE(FOLDER_DIRECTORY(:LEN_F)// + & FOLDER(:TRIM(FOLDER))//'.*',FOLDER_DIRECTORY(:LEN_F)// + & FOLDER1(:TRIM(FOLDER1))//'.*') + IF (IER) THEN + IER = 0 + FOLDER_FILE = FOLDER_DIRECTORY(:LEN_F)//FOLDER1 + END IF + END IF + + IF (IER.EQ.0) THEN + IF (CLI$PRESENT('OWNER')) THEN + CALL CHKACL + & (FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + CALL DEL_ACL(FOLDER_OWNER,'R+W+C',IER) + END IF + END IF + FOLDER = FOLDER1 + FOLDER_OWNER = FOLDER1_OWNER + FOLDER_DESCRIP = FOLDER1_DESCRIP + DELETE (7) + CALL WRITE_FOLDER_FILE(IER) + IF (IER.EQ.0) WRITE (6,'('' Folder successfully modified.'')') + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + SUBROUTINE MOVE(DELETE_ORIGINAL) +C +C SUBROUTINE MOVE +C +C FUNCTION: Moves message from one folder to another. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + EXTERNAL CLI$_ABSENT + + EXTERNAL BULLETIN_SUBCOMMANDS + + LOGICAL DELETE_ORIGINAL + + CHARACTER SAVE_FOLDER*25 + + IF (CLI$PRESENT('ORIGINAL').AND..NOT.SETPRV_PRIV()) THEN + WRITE (6, + & '('' ERROR: You have no privileges to keep original owner.'')') + END IF + + ALL = CLI$PRESENT('ALL') + + MERGE = CLI$PRESENT('MERGE') + + SAVE_BULL_POINT = BULL_POINT + + IER1 = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER1.EQ.%LOC(CLI$_ABSENT).AND..NOT.ALL) THEN + IF (BULL_POINT.EQ.0) THEN ! If no message has been read + WRITE(6,'('' ERROR: You are not reading any message.'')') + RETURN ! and return + END IF + + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) ! Get message directory entry + IF (IER.NE.BULL_POINT+1) THEN ! Was message found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + NUM_COPY = 1 + ELSE + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) ! Get message directory entry + IF (NBULL.EQ.0) THEN ! Were messages found? + WRITE(6,'('' ERROR: No messages were found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (IER1.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER1) + IF (SBULL.LE.0.OR.IER1.NE.0) THEN + WRITE (6,'(A)') + & ' ERROR: Specified message number has incorrect format.' + CALL CLOSE_BULLDIR + RETURN + ELSE + NUM_COPY = EBULL - SBULL + 1 + BULL_POINT = SBULL + END IF + ALL = .TRUE. + ELSE IF (CLI$PRESENT('ALL')) THEN + NUM_COPY = NBULL + BULL_POINT = 1 + END IF + END IF + + FROM_REMOTE = REMOTE_SET + + IF (REMOTE_SET) THEN + OPEN (UNIT=12,FILE='REMOTE.BULLDIR', + & STATUS='SCRATCH',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.0) THEN + OPEN (UNIT=11,FILE='REMOTE.BULLFIL', + & STATUS='SCRATCH',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END IF + IF (IER.EQ.0) THEN + CALL OPEN_BULLFIL + I = BULL_POINT - 1 + CALL READDIR(I,IER) + IF (IER.EQ.I+1) THEN + IF (I.EQ.0) THEN + WRITE (12,IOSTAT=IER1) BULLDIR_HEADER + ELSE + WRITE (12,IOSTAT=IER1) BULLDIR_ENTRY + END IF + END IF + NBLOCK = 1 + DO WHILE (I.LT.BULL_POINT+NUM_COPY-1.AND.IER.EQ.I+1) + I = I + 1 + CALL READDIR(I,IER) + IF (IER.EQ.I+1) THEN + BLOCK = NBLOCK + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (12,IOSTAT=IER1) BULLDIR_ENTRY + IF (IER1.EQ.0) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER1) 5,I + IF (IER1.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER1) + END IF + END IF + IF (IER1.EQ.0) THEN + SCRATCH_R = SCRATCH_R1 + DO J=1,LENGTH + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT(:128)) + WRITE (11'NBLOCK,IOSTAT=IER1) INPUT(:128) + NBLOCK = NBLOCK + 1 + END DO + END IF + IF (IER1.NE.0) I = IER + END IF + END DO + NUM_COPY = I - BULL_POINT + 1 + END IF + CALL CLOSE_BULLFIL + IF (IER1.NE.0) THEN + WRITE(6,'('' ERROR: Copy aborted. Remote folder problem.'')') + CLOSE (UNIT=11) + CLOSE (UNIT=12) + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + + CALL CLOSE_BULLDIR + + SAVE_FOLDER = FOLDER + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + CALL CLI$GET_VALUE('FOLDER',FOLDER1) + + FOLDER_NUMBER = -1 ! Use FOLDER as key rather than FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Cannot access specified folder.'')') + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER = SAVE_FOLDER + BULL_POINT = SAVE_BULL_POINT + CLOSE (UNIT=11) + CLOSE (UNIT=12) + RETURN + END IF + + IF (READ_ONLY.OR.(MERGE.AND.REMOTE_SET)) THEN + IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No access to write into folder.'')') + ELSE + WRITE (6,'('' ERROR: /MERGE invalid into remote folder.'')') + END IF + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + BULL_POINT = SAVE_BULL_POINT + CLOSE (UNIT=11) + CLOSE (UNIT=12) + RETURN + END IF + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + CALL OPEN_BULLDIR ! Prepare to add dir entry + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //SAVE_FOLDER + + IF (.NOT.FROM_REMOTE) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=12,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER.EQ.0) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=11,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END DO + END IF + ELSE + IER= 0 + END IF + + IF (MERGE) CALL INITIALIZE_MERGE(IER) + + START_BULL_POINT = BULL_POINT + + IF (IER.EQ.0) READ (12,KEYID=0,KEY=BULL_POINT-1,IOSTAT=IER) + + DO WHILE (NUM_COPY.GT.0.AND.IER.EQ.0) + READ (12,IOSTAT=IER) BULLDIR_ENTRY + NUM_COPY = NUM_COPY - 1 + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + + IF (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV()) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,0) ! Remove system bit + END IF + + IF (BTEST(SYSTEM,2).AND. ! Shutdown message? + & (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV())) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,2) ! Remove shutdown bit + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + EXTIME = '00:00:00.00' + ELSE IF (BTEST(SYSTEM,1).AND.FOLDER_NUMBER.EQ.0.AND. + & .NOT.SETPRV_PRIV().AND..NOT.ALL) THEN ! Permanent? + WRITE (6,'('' ERROR: No privileges to add'', + & '' permanent message.'')') + WRITE (6,'('' Expiration will be '',I,'' days.'')') + & FOLDER_BBEXPIRE + SYSTEM = IBCLR(SYSTEM,1) + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + EXTIME = '00:00:00.00' + END IF + + IF (.NOT.CLI$PRESENT('ORIGINAL')) THEN ! If not /ORIGINAL + FROM = USERNAME ! Specify owner + END IF + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + IF (IER.NE.0) CALL ERROR_AND_EXIT + END IF + + IF (MERGE) CALL ADD_MERGE_TO(IER) + + IF (IER.EQ.0) THEN + NBLOCK = NBLOCK + 1 + + DO I=BLOCK,BLOCK+LENGTH-1 + READ (11'I,IOSTAT=IER) INPUT(:128) + IF (IER.EQ.0) THEN + CALL WRITE_BULL_FILE(NBLOCK,INPUT(:128)) + END IF + NBLOCK = NBLOCK + 1 + END DO + END IF + + IF (IER.EQ.0) THEN + IF (MERGE) THEN + CALL ADD_MERGE_FROM(IER) + ELSE + CALL ADD_ENTRY ! Add the new directory entry + END IF + BULL_POINT = BULL_POINT + 1 + END IF + END DO + + IF (MERGE) CALL ADD_MERGE_REST(IER) + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CLOSE (UNIT=11) + + CLOSE (UNIT=12) + + IF (FOLDER_NUMBER.GE.0.AND.IER.EQ.0) THEN + CALL UPDATE_FOLDER ! Update folder info +C +C If user is adding message, update that user's last read time for +C folder, so user is not alerted of new message which is owned by user. +C + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + + IF (IER.EQ.0) THEN + WRITE (6,'('' Successful copy to folder '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + IF (MERGE) THEN + CALL LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END IF + ELSE IF (MERGE) THEN + WRITE (6,'('' ERROR: Copy aborted. No files copied.'')') + ELSE + WRITE (6,'('' ERROR: Copy aborted. '',I,'' files copied.'')') + & BULL_POINT - START_BULL_POINT + END IF + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + + BULL_POINT = SAVE_BULL_POINT + + IF (DELETE_ORIGINAL.AND.IER.EQ.0) THEN + IF (FROM_REMOTE.AND.ALL) THEN + WRITE (6,'('' WARNING: Original messages not deleted.'')') + WRITE (6,'('' Multiple deletions not possible for '', + & ''remote folders.'')') + ELSE + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + CALL DELETE + END IF + END IF + + RETURN + + END + + + + + SUBROUTINE PRINT +C +C SUBROUTINE PRINT +C +C FUNCTION: Print header to queue. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SJCDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + CHARACTER*32 QUEUE + + INTEGER*2 FILE_ID(14) + INTEGER*2 IOSB(4) + EQUIVALENCE (IOSB(1),JBC_ERROR) + + CHARACTER*31 FORM_NAME + + PARAMETER FF = CHAR(12) + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.LIS',ERR=900,IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + CALL ENABLE_PRIVS + + CALL OPEN_BULLDIR_SHARED + + CALL OPEN_BULLFIL_SHARED + + HEAD = CLI$PRESENT('HEADER') + + DO I=SBULL,EBULL + CALL READDIR(I,IER) ! Get info for specified message + + IF (IER.NE.I+1) THEN ! Was message found? + IF (I.EQ.SBULL) THEN ! No, were any messages found? + WRITE(6,1030) ! If not, then error out + CLOSE (UNIT=3,STATUS='DELETE') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + RETURN + END IF + ELSE ! Yes, message found. + IF (I.GT.SBULL) WRITE(3,'(A)') FF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + END IF + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(18,SJC$_FILE_SPECIFICATION, + & %LOC('SYS$LOGIN:BULL.LIS')) + + IER = CLI$GET_VALUE('QUEUE',QUEUE,ILEN) ! Get queue name + IF (ILEN.EQ.0) THEN + QUEUE = 'SYS$PRINT' + ILEN = 9 + END IF + + CALL ADD_2_ITMLST(ILEN,SJC$_QUEUE,%LOC(QUEUE)) + CALL ADD_2_ITMLST(0,SJC$_DELETE_FILE,0) + + IF (CLI$PRESENT('NOTIFY')) THEN + CALL ADD_2_ITMLST(0,SJC$_NOTIFY,0) + END IF + + IF (CLI$PRESENT('FORM')) THEN + IER = CLI$GET_VALUE('FORM',FORM_NAME,FORM_NAME_LEN) + CALL ADD_2_ITMLST(FORM_NAME_LEN,SJC$_FORM_NAME,%LOC(FORM_NAME)) + END IF + + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + + CALL END_ITMLST(SJC_ITMLST) + + IER=SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SJC_ITMLST),IOSB,,) + IF (IER.AND.(.NOT.JBC_ERROR)) THEN + CALL SYS_GETMSG(JBC_ERROR) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + ELSE IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + RETURN + +900 CALL ERRSNS(IDUMMY,IER) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + WRITE(6,1000) + CALL SYS_GETMSG(IER) + RETURN + +1000 FORMAT(' ERROR: Unable to open temporary file + & SYS$LOGIN:BULL.LIS for printing.') +1010 FORMAT(' ERROR: You have not read any message.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Specified message was not found.') +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A,/,'Date: ',A) + + END + + + + + SUBROUTINE READ(READ_COUNT,BULL_READ) +C +C SUBROUTINE READ +C +C FUNCTION: Reads a specified bulletin. +C +C PARAMETER: +C READ_COUNT - Variable to store the record in the message file +C that READ will read from. Must be set to 0 to indicate +C that it is the first read of the message. If -1, +C READ will search for the last message in the message file +C and read that one. If -2, just display header information. +C BULL_READ - Message number to be read. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /TAGS/ BULL_TAG,READ_TAG + + DATA SCRATCH_B1/0/ + + CHARACTER TODAY*11,DATETIME*23,BUFFER*(LINE_LENGTH) + CHARACTER SAVE_MSG_KEY*8 + + LOGICAL SINCE,PAGE + + CALL LIB$ERASE_PAGE(1,1) ! Clear screen + END = 0 ! Nothing outputted on screen + + IF (READ_COUNT.GT.0) GO TO 100 ! Skip init steps if this is + ! not first page of bulletin + + SINCE = .FALSE. + PAGE = .TRUE. + + IF (.NOT.PAGING) PAGE = .FALSE. + IF (INCMD(:4).EQ.'READ') THEN ! If READ command... + IF (CLI$PRESENT('MARKED')) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No marked messages found.'')') + RETURN + ELSE + READ_TAG = .TRUE. + END IF + END IF + + IF (.NOT.CLI$PRESENT('PAGE')) PAGE = .FALSE. + IF (CLI$PRESENT('SINCE')) THEN ! was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present.'')') + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + END IF + IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + CALL OPEN_BULLDIR_SHARED + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + RETURN + ELSE + BULL_READ = IER + IER = IER + 1 + END IF + SINCE = .TRUE. + END IF + END IF + + IF (READ_TAG) THEN + NEXT = .FALSE. + IF (INCMD(:4).EQ.'NEXT'.OR.INCMD.EQ.' ') THEN + NEXT = .TRUE. + ELSE IF (INCMD(:4).EQ.'READ') THEN + IF (.NOT.CLI$PRESENT('BULLETIN_NUMBER')) NEXT = .TRUE. + END IF + IF (INCMD(:4).EQ.'BACK') THEN + SAVE_MSG_KEY = MSG_KEY + MSG_KEY = BULLDIR_HEADER + I = 0 + IER = 0 + DO WHILE (IER.EQ.0.AND.MSG_KEY.NE.SAVE_MSG_KEY) + I = I + 1 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END DO + IF (IER.EQ.0) THEN + MSG_KEY = BULLDIR_HEADER + DO J=1,I-1 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END DO + IER = BULL_READ + 1 + ELSE + IER = 0 + END IF + ELSE IF (NEXT) THEN + IF (SINCE) THEN + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + ELSE + IF (BULL_POINT.GT.0) THEN + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) + CALL CLOSE_BULLDIR + ELSE + MSG_KEY = BULLDIR_HEADER + END IF + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END IF + IF (IER.EQ.0) THEN + IER = BULL_READ + 1 + ELSE + IER = 0 + END IF + END IF + END IF + + IF (.NOT.SINCE.AND. + & (.NOT.READ_TAG.OR.(.NOT.NEXT.AND.INCMD(:4).NE.'BACK'))) THEN + IF (BULL_READ.GT.0) THEN ! Valid bulletin number? + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_READ,IER) ! Get bulletin directory entry + IF (READ_COUNT.EQ.-1.AND.IER.NE.BULL_READ+1) THEN + READ_COUNT = 0 + CALL READDIR(0,IER) + IF (NBULL.GT.0) THEN + BULL_READ = NBULL + CALL READDIR(BULL_READ,IER) + ELSE + IER = 0 + END IF + END IF + CALL CLOSE_BULLDIR + ELSE + IER = 0 + END IF + END IF + + IF (IER.NE.BULL_READ+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + RETURN + END IF + + DIFF = COMPARE_BTIM(MSG_BTIM,LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF.GT.0) THEN + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = MSG_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = MSG_BTIM(2) + END IF + + BULL_POINT = BULL_READ ! Update bulletin counter + + IF (INCMD(:4).EQ.'READ'.OR.INCMD(:4).EQ.'CURR') THEN + IF (CLI$PRESENT('EDIT')) THEN + CALL READ_EDIT + RETURN + END IF + END IF + + FLEN = TRIM(FOLDER) + IF (BULL_POINT.GT.F_NBULL) F_NBULL = BULL_POINT + WRITE (INPUT,'(1X,I5,'' of '',I5)') BULL_POINT,F_NBULL + DO WHILE (INDEX(INPUT,' ').LT.TRIM(INPUT)) + I = INDEX(INPUT,' ') + INPUT(I:) = INPUT(I+1:) + END DO + I = TRIM(INPUT) + INPUT = ' #'//INPUT(2:TRIM(INPUT)) + INPUT(PAGE_WIDTH-LEN(FOLDER):) = FOLDER(:FLEN) + IF (READIT.GT.0) THEN + WRITE(6,'(A)') '+'//INPUT(:TRIM(INPUT)) + ELSE + WRITE(6,'(1X,A)') INPUT(:TRIM(INPUT)) + END IF + + END = 1 ! Outputted 1 line to screen + + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + WRITE (6,'(1X,A)') INPUT(:TRIM(INPUT)) + + END = END + 1 + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + LINE_OFFSET = 0 + CHAR_OFFSET = 0 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INPUT = 'From: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + WRITE(6,'(1X,A)') INPUT(:I) + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = 1 + ELSE + WRITE(6,'('' From: '',A)') FROM + END = END + 1 + END IF + IF (INPUT(:6).NE.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + INPUT = 'Subj: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + WRITE(6,'(1X,A)') INPUT(:I) + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = LINE_OFFSET + 1 + ELSE + IF (LINE_OFFSET.EQ.1) THEN + CHAR_OFFSET = 1 - PAGE_WIDTH + LINE_OFFSET = 2 + END IF + WRITE(6,'('' Subj: '',A)') DESCRIP + END = END + 1 + END IF + IF (LINE_OFFSET.EQ.0) ILEN = LINE_LENGTH + 1 + CALL CLOSE_BULLFIL ! End of bulletin file read + + WRITE(6,'(1X)') + IF (READIT.GT.0) WRITE(6,'(1X)') + END = END + 1 +C +C Each page of the bulletin is buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C bulletin file, and to avoid the possibility of the user holding the screen, +C and thus causing the bulletin file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_B1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + IF (SCRATCH_B1.NE.0) THEN ! Is queue empty? + SCRATCH_B = SCRATCH_B1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_B,INPUT) + SCRATCH_B1 = SCRATCH_B ! Init header pointer + END IF + + READ_ALREADY = 0 ! Number of lines already read + ! from record. + IF (READ_COUNT.EQ.-2) THEN ! Just output header first read + READ_COUNT = BLOCK + RETURN + ELSE + READ_COUNT = BLOCK ! Init bulletin record counter + END IF + + GO TO 200 + +100 IF (READIT.EQ.0) THEN ! If not 1st page of READ + WRITE (BUFFER,'(1X,I5,'' of '',I5)') BULL_POINT,F_NBULL + DO WHILE (INDEX(BUFFER,' ').LT.TRIM(BUFFER)) + I = INDEX(BUFFER,' ') + BUFFER(I:) = BUFFER(I+1:) + END DO + BUFFER = ' #'//BUFFER(2:TRIM(BUFFER)) + BUFFER(PAGE_WIDTH-LEN(FOLDER):) = FOLDER(:FLEN) + WRITE(6,'(1X,A,/)') BUFFER(:TRIM(BUFFER)) ! Output header info + END = END + 2 ! Increase display counter + END IF + +200 SCRATCH_B = SCRATCH_B1 ! Init queue pointer to header + IF (READIT.GT.0) END = END - 2 ! /READ can output 2 more lines + DISPLAY = 0 + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + MORE_LINES = .TRUE. + DO WHILE (ILEN.GT.0.AND.MORE_LINES) + IF (CHAR_OFFSET.EQ.0) THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + LINE_OFFSET = LINE_OFFSET + 1 + END IF + IF (ILEN.LT.0) THEN ! Error, couldn't read record + ILEN = 0 ! Fake end of reading file + MORE_LINES = .FALSE. + ELSE IF (ILEN.GT.0) THEN + IF (CHAR_OFFSET.EQ.0) THEN + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (LEN_TEMP.GT.PAGE_WIDTH) THEN + CHAR_OFFSET = 1 + BUFFER = INPUT(:PAGE_WIDTH) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + ELSE + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,INPUT) + END IF + ELSE + CHAR_OFFSET = CHAR_OFFSET + PAGE_WIDTH + IF (LEN_TEMP.LE.CHAR_OFFSET+PAGE_WIDTH-1) THEN + BUFFER = INPUT(CHAR_OFFSET:LEN_TEMP) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + CHAR_OFFSET = 0 + ELSE + BUFFER = INPUT(CHAR_OFFSET:CHAR_OFFSET+PAGE_WIDTH-1) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + END IF + END IF + DISPLAY = DISPLAY + 1 + IF ((DISPLAY.EQ.PAGE_LENGTH-END-4).AND.PAGE) THEN + MORE_LINES = .FALSE. + END IF + END IF + END DO + + CALL CLOSE_BULLFIL ! End of bulletin file read + +C +C Bulletin page is now in temporary memory, so output to terminal. +C Note that if this is a /READ, the first line will have problems with +C the usual FORMAT statement. It will cause a blank line to be outputted +C at the top of the screen. This is because of the input QIO at the +C end of the previous page. The output gets confused and thinks it must +C end the previous line. To prevent that, the first line of a new page +C in a /READ must use a different FORMAT statement to surpress the CR/LF. +C + + SCRATCH_B = SCRATCH_B1 ! Reinit queue pointer to head + DO I=1,DISPLAY ! Output page to terminal + CALL READ_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) ! Get queue record + IF (I.EQ.1.AND.READIT.GT.0) THEN + WRITE(6,'(A)') '+'//BUFFER(:TRIM(BUFFER)) ! (See above comments) + ELSE + WRITE(6,'(1X,A)') BUFFER(:TRIM(BUFFER)) + END IF + END DO + + IF (ILEN.EQ.0) THEN ! End of message? + READ_COUNT = 0 ! init bulletin record counter + ELSE ! Possibly end of message since end of page could be last line + CALL TEST_MORE_RECORDS(BLOCK,LENGTH,IREC) + IF (IREC.EQ.0) THEN ! Last record? + CALL TEST_MORE_LINES(ILEN) ! More lines to read? + IF (ILEN.GT.0) THEN ! Yes, there are still more + IF (READIT.EQ.0) WRITE(6,1070) ! say there is more of bulletin + ELSE ! Yes, last line anyway + READ_COUNT = 0 ! init bulletin record counter + END IF + ELSE IF (READIT.EQ.0) THEN ! Not last record so + WRITE(6,1070) ! say there is more of bulletin + END IF + END IF + + RETURN + +1030 FORMAT(' ERROR: Specified message was not found.') +1070 FORMAT(1X,/,' Press RETURN for more...',/) + +2000 FORMAT(A) + + END + + + + + + SUBROUTINE READ_EDIT + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + WRITE(3,1050) INPUT(7:ILEN) + ELSE + WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + CALL CLOSE_BULLFIL + + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A,' Date: ',A) + + RETURN + END + + + SUBROUTINE READNEW(REDO) +C +C SUBROUTINE READNEW +C +C FUNCTION: Displays new non-system bulletins with prompts between bulletins. +C + + IMPLICIT INTEGER (A-Z) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /POINT/ BULL_POINT + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + CHARACTER INREAD*1,FILE_DEF*80,NUMREAD*5 + + DATA LEN_FILE_DEF /0/, INREAD/0/ + + LOGICAL SLOW,SLOW_TERMINAL + + FIRST_MESSAGE = BULL_POINT + + IF (ICHAR(INREAD).EQ.0) THEN ! If calling READNEW for first time + SLOW = SLOW_TERMINAL() ! Check baud rate of terminal + END IF ! to avoid gobs of output + + LEN_P = 0 ! Tells read subroutine there is + ! no bulletin parameter + +1 WRITE(6,1000) ! Ask if want to read new bulletins + + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0) THEN + INREAD = NUMREAD(:1) + IF (INREAD.EQ.'N'.OR.INREAD.EQ.'Q'.OR.INREAD.EQ.'E') THEN + IF (INREAD.EQ.'Q') THEN + WRITE (6,'(''+uit'',$)') + ELSE IF (INREAD.EQ.'E') THEN + WRITE (6,'(''+xit'',$)') + DO I=1,FLONG ! Just show SYSTEM folders + NEW_MSG(I) = NEW_MSG(I).AND.SYSTEM_FLAG(I) + END DO + DO I=1,FLONG ! Test for new messages in SYSTEM folders + IF (NEW_MSG(I).NE.0) RETURN + END DO + CALL EXIT + ELSE + WRITE (6,'(''+o'',$)') + END IF + RETURN ! If NO, exit + ! Include QUIT to be consistent with next question + ELSE + CALL LIB$ERASE_PAGE(1,1) + END IF + END IF + +3 IF (TEMP_READ.GT.0) THEN + IF (TEMP_READ.LT.FIRST_MESSAGE+1.OR.TEMP_READ.GT.NBULL) THEN + WRITE (6,'('' ERROR: Specified new message not found.'')') + GO TO 1 + ELSE + BULL_POINT = TEMP_READ - 1 + END IF + END IF + + READ_COUNT = 0 ! Initialize display pointer + +5 CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + FILE_POINT = BULL_POINT + IF (READ_COUNT.EQ.0) THEN ! Is full bulletin displayed? + CALL OPEN_BULLDIR_SHARED ! If so, see if more new bulls +10 CALL READDIR(BULL_POINT+1,IER_POINT) + IF ((IER_POINT.EQ.BULL_POINT+2).AND. ! If system bulletin (and system + & (SYSTEM.AND.BTEST(FOLDER_FLAG,2))) THEN ! folder) then skip it. + BULL_POINT = BULL_POINT + 1 + GO TO 10 + END IF + CALL CLOSE_BULLDIR + END IF + +12 IF (READ_COUNT.EQ.0) THEN ! Prompt user in between + WRITE(6,1020) ! full screens or end of bull. + ELSE + WRITE(6,1030) + END IF + + CALL GET_INPUT_NOECHO(INREAD) + CALL STR$UPCASE(INREAD,INREAD) ! Convert input to upper case + + IF (INREAD.EQ.'Q') THEN ! If Q , then QUIT + WRITE (6,'(''+Quit'',$)') + RETURN + ELSE IF (INREAD.EQ.'D') THEN ! If D , then redisplay directory + WRITE (6,'(''+Dir'',$)') + REDO = .TRUE. + RETURN + ELSE IF (INREAD.EQ.'F') THEN ! If F then copy bulletin to file + WRITE (6,'(''+ '')') ! Move cursor from end of prompt line + ! to beginning of next line. + IF (LEN_FILE_DEF.EQ.0) THEN + CALL LIB$SYS_TRNLOG('SYS$LOGIN',ILEN,FILE_DEF) + IER = LIB$FIND_FILE(FILE_DEF//'BULL.DIR', + & BULL_PARAMETER,CONTEXT) + IF (IER) THEN + FILE_DEF = BULL_PARAMETER(:ILEN-1)//'.BULL]' + LEN_FILE_DEF = ILEN + 5 + ELSE + FILE_DEF = 'SYS$LOGIN:' + LEN_FILE_DEF = 10 + END IF + END IF + + LEN_FOLDER = TRIM(FOLDER) + CALL GET_INPUT_PROMPT(BULL_PARAMETER,LEN_P, + & 'Name of file? (Default='//FILE_DEF(:LEN_FILE_DEF)// + & FOLDER(:LEN_FOLDER)//'.LIS) ') + + IF (LEN_P.EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)//FOLDER(:LEN_FOLDER) + & //'.LIS' + LEN_P = LEN_FILE_DEF + LEN_FOLDER + 4 + ELSE + IER = LIB$SYS_TRNLOG(BULL_PARAMETER(:LEN_P),ILEN,INPUT) + IF (IER.NE.1.AND.INDEX(BULL_PARAMETER(:LEN_P),':').EQ.0 + & .AND.INDEX(BULL_PARAMETER(:LEN_P),'[').EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)// + & BULL_PARAMETER(:LEN_P) + LEN_P = LEN_P + LEN_FILE_DEF + END IF + END IF + + BLOCK_SAVE = BLOCK + LENGTH_SAVE = LENGTH + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + CALL READDIR(FILE_POINT,IER) + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH,ERR=18,STATUS='UNKNOWN', + & CARRIAGECONTROL='LIST',ACCESS='APPEND') + WRITE(3,1050) DESCRIP ! Output bulletin header info + WRITE(3,1060) FROM,DATE//' '//TIME(:5) + ILEN = LINE_LENGTH + 1 + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE(3,'(A)') INPUT(:TRIM(INPUT)) + END DO + IF (ILEN.EQ.0) WRITE(6,1040) BULL_PARAMETER(:LEN_P) + ! Show name of file created. +18 IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + END IF + CLOSE (UNIT=3) ! Bulletin copy completed + IF (READ_COUNT.GT.0) THEN ! Reposition GET_BULL routine + ILEN = LINE_LENGTH + 1 ! in case read in progress + DO I=1,LINE_OFFSET ! and partial block was read. + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + END IF + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + LENGTH = LENGTH_SAVE + BLOCK = BLOCK_SAVE + CALL ENABLE_PRIVS ! Reset BYPASS privileges + GO TO 12 + ELSE IF (INREAD.EQ.'N'.AND.READ_COUNT.GT.0) THEN + ! If NEXT and last bulletins not finished + READ_COUNT = 0 ! Reset read bulletin counter + CALL OPEN_BULLDIR_SHARED ! Look for NEXT bulletin +20 CALL READDIR(BULL_POINT+1,IER) + IF (IER.NE.BULL_POINT+2) THEN ! If no NEXT bulletin + CALL CLOSE_BULLDIR ! Exit + WRITE(6,1010) + RETURN + ELSE IF (SYSTEM.AND.BTEST(FOLDER_FLAG,2)) THEN + BULL_POINT = BULL_POINT + 1 ! If SYSTEM bulletin, skip it + GO TO 20 ! Look for more bulletins + END IF + CALL CLOSE_BULLDIR + ELSE IF (INREAD.EQ.'R') THEN + WRITE (6,'(''+Read'')') + WRITE (6,'('' Enter message number: '',$)') + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0.OR.TEMP_READ.LE.0) THEN + WRITE (6,'('' ERROR: Invalid message number specified.'')') + GO TO 12 + ELSE + GO TO 3 + END IF + ELSE IF (IER_POINT.NE.BULL_POINT+2.AND.READ_COUNT.EQ.0) THEN + WRITE(6,1010) + RETURN + END IF + IF (READ_COUNT.EQ.0.AND.SLOW) READ_COUNT = -2 + GO TO 5 + +1000 FORMAT(' Read messages? Type N(No),E(Exit),message + & number, or any other key for yes: ',$) +1010 FORMAT(' No more messages.') +1020 FORMAT(1X,('-'),/,' Type Q(Quit), + & F(File it), D(Dir), R(Read msg #) or other for next message: ',$) +1030 FORMAT(1X,('-'),/,' Type Q(Quit), F(File), N(Next), + & D(Dir), R(Read msg #) or other for MORE: ',$) +1040 FORMAT(' Message written to ',A) +1050 FORMAT(/,'Description: ',A53) +1060 FORMAT('From: ',A12,' Date: ',A20,/) + + END + + + + + SUBROUTINE SET_DEFAULT_EXPIRE +C +C SUBROUTINE SET_DEFAULT_EXPIRE +C +C FUNCTION: Sets default expiration date. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER EXPIRE*3 + + IF (SETPRV_PRIV().OR.USERNAME.EQ.FOLDER_OWNER) THEN + IER = CLI$GET_VALUE('DEFAULT_EXPIRE',EXPIRE,EX_LEN) + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + ELSE IF (TEMP.LT.-1) THEN + WRITE (6,'('' ERROR: Expiration must be > -1.'')') + ELSE + FOLDER_BBEXPIRE = TEMP + WRITE (6,'('' Default expiration modified.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to set expiration.'')') + END IF + + RETURN + END diff --git a/decus/lt89b1/bulletin/bulletin2.for b/decus/lt89b1/bulletin/bulletin2.for new file mode 100644 index 0000000..5a10bc7 --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin2.for @@ -0,0 +1,1499 @@ +C +C BULLETIN2.FOR, Version 9/1/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE SET_BBOARD(BBOARD) +C +C SUBROUTINE SET_BBOARD +C +C FUNCTION: Set username for BBOARD for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($UAIDEF)' + + EXTERNAL CLI$_ABSENT + + CHARACTER EXPIRE*3,INPUT_BBOARD*12,TODAY*23,RESPONSE*1 + + IF (TRIM(BBOARD_DIRECTORY).EQ.0) THEN + WRITE(6,'('' ERROR: System programmer has disabled BBOARD.'')') + RETURN + END IF + + IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + WRITE (6,'( + & '' ERROR: Cannot set BBOARD for remote folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + + IF (BBOARD) THEN + IER = CLI$GET_VALUE('BB_USERNAME',INPUT_BBOARD,INPUT_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_UAF + & (INPUT_BBOARD,USERB,GROUPB,ACCOUNTB,FLAGS,IER1) + CALL CLOSE_BULLFOLDER + IF (IER1.AND..NOT.BTEST(FLAGS,UAI$V_DISACNT)) THEN ! DISUSER? + WRITE (6,'('' ERROR: '',A, + & '' account needs DISUSER flag set.'')') + & INPUT_BBOARD(:INPUT_LEN) + RETURN + ELSE IF (IER1.AND.BTEST(USERB,31)) THEN + WRITE (6,'('' ERROR: User number of UIC cannot '', + & ''be greater than 7777777777.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_TEMP(IER) + DO WHILE ((FOLDER1_BBOARD.NE.INPUT_BBOARD.OR. + & FOLDER1_NUMBER.EQ.FOLDER_NUMBER).AND.IER.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER) + END DO + IF (FOLDER1_BBOARD.EQ.INPUT_BBOARD.AND. + & FOLDER1_NUMBER.NE.FOLDER_NUMBER) THEN + WRITE (6,'( + & '' ERROR: Account used by other folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + IF (.NOT.IER1) THEN + CALL CLOSE_BULLFOLDER + WRITE (6,'('' WARNING: '',A,'' account not in SYSUAF'', + & '' file.'')') INPUT_BBOARD(:INPUT_LEN) + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Is the name a mail forwarding entry? '// + & '(Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + USERB = 1 ! Fake userb/groupb, as old method of + GROUPB = 1 ! indicating /SPECIAL used [0,0] + END IF + GROUPB1 = GROUPB + USERB1 = USERB + ACCOUNTB1 = ACCOUNTB + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + GROUPB = GROUPB1 + USERB = USERB1 + ACCOUNTB = ACCOUNTB1 + FOLDER_BBOARD = INPUT_BBOARD + CALL OPEN_BULLUSER + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM(TODAY,BBOARD_BTIM) + REWRITE (4) USER_HEADER + CALL CLOSE_BULLUSER + IF (CLI$PRESENT('SPECIAL')) THEN ! SPECIAL specified? + USERB = IBSET(USERB,31) ! Set bit to show /SPECIAL + IF (CLI$PRESENT('VMSMAIL')) THEN + GROUPB = IBSET(GROUPB,31) ! Set bit to show /VMSMAIL + END IF + END IF + ELSE IF (CLI$PRESENT('SPECIAL')) THEN + USERB = IBSET(0,31) ! Set top bit to show /SPECIAL + GROUPB = 0 + DO I=1,LEN(FOLDER_BBOARD) + FOLDER_BBOARD(I:I) = ' ' + END DO + ELSE IF (FOLDER_BBOARD.EQ.'NONE') THEN + WRITE (6,'('' ERROR: No BBOARD specified for folder.'')') + END IF + + IER = CLI$GET_VALUE('EXPIRATION',EXPIRE,EX_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (TEMP.LE.0) THEN + WRITE (6,'('' ERROR: Expiration must be > 0.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + FOLDER_BBEXPIRE = TEMP + END IF + ELSE IF (.NOT.CLI$PRESENT('EXPIRATION')) THEN + FOLDER_BBEXPIRE = -1 + END IF + ELSE + FOLDER_BBOARD = 'NONE' + END IF + + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + WRITE (6,'('' BBOARD has been modified for folder.'')') + ELSE + WRITE (6,'('' You are not authorized to modify BBOARD.'')') + END IF + + RETURN + END + + + + + + + SUBROUTINE SET_SYSTEM(SYSTEM_SET) +C +C SUBROUTINE SET_SYSTEM +C +C FUNCTION: Set SYSTEM specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + ELSE IF (SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (SYSTEM_SET) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been set.'')') + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been removed.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL MODIFY_SYSTEM_LIST(0) + CALL CLOSE_BULLFOLDER + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + ELSE + WRITE (6,'('' You are not authorized to modify SYSTEM.'')') + END IF + + RETURN + END + + + + SUBROUTINE MODIFY_SYSTEM_LIST(FILE_OPENED) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + INTEGER SHUTDOWN_BTIM(FLONG),VERSION(FLONG) + + CHARACTER UPDATE*11,UPTIME*8 + + INTEGER UP_BTIM(2) + + IF (.NOT.FILE_OPENED) CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0.OR.VERSION(1).NE.168) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + SHUTDOWN_BTIM(1) = 0 + SHUTDOWN_BTIM(2) = 0 + NODE_NUMBER = 0 + NODE_AREA = 0 + IF (IER.EQ.0) THEN + DO WHILE (TEMP_USER(:7).EQ.'*SYSTEM'.AND.IER.EQ.0) + DELETE (UNIT=4) + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) TEMP_USER + END DO + END DO + IER = 2 + ELSE + VERSION(1) = 168 + END IF + END IF + + IF (VERSION(1).NE.168) THEN + CALL CLOSE_BULLFOLDER + CALL OPEN_BULLFOLDER + NODE_AREA = 0 + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + END DO + IER1 = 0 + DO WHILE (IER1.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER1) + IF (BTEST(FOLDER1_FLAG,2).AND.IER1.EQ.0) THEN + CALL SET2(SYSTEM_FLAG,FOLDER1_NUMBER) + END IF + END DO + VERSION(1) = 168 + END IF + + IF (BTEST(FOLDER_FLAG,2)) THEN + CALL SET2(SYSTEM_FLAG,FOLDER_NUMBER) + ELSE + CALL CLR2(SYSTEM_FLAG,FOLDER_NUMBER) + END IF + + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14,BTEST(FOLDER_FLAG,2), + & NODENAME + IF (IER1.NE.0) THEN + CALL DISCONNECT_REMOTE + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + RETURN + END IF + END IF + + CALL GET_UPTIME(UPDATE,UPTIME) + + CALL SYS_BINTIM(UPDATE//' '//UPTIME,UP_BTIM) + + IF (NODE_AREA.EQ.0) THEN + IF (SHUTDOWN_BTIM(1).EQ.0) THEN + DIFF = -1 + ELSE + DIFF = COMPARE_BTIM(SHUTDOWN_BTIM,UP_BTIM) + END IF + IF (DIFF.EQ.-1) THEN + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + SHUTDOWN_BTIM(1) = UP_BTIM(1) + SHUTDOWN_BTIM(2) = UP_BTIM(2) + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + END IF + ELSE ! Test to make sure NODE_AREA is zero + SEEN_FLAG = 0 ! if all of SHUTDOWN_FLAG is zero + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 + END IF + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + + RETURN + END + + + + SUBROUTINE GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) + CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) + CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist + + IER = SYS$GETSYIW(,,,%VAL(GETSYI_ITMLST),,,) ! Get Info command. +C +C NODE_AREA is set to 0 after shutdown messages are deleted. +C If node is not part of cluster, NODE_AREA will be 0, +C so set it to 1 as a dummy value to cause messages to be deleted. +C + IF (NODE_AREA.EQ.0) NODE_AREA = 1 + + RETURN + END + + + + + SUBROUTINE SET_NODE(NODE_SET) +C +C SUBROUTINE SET_NODE +C +C FUNCTION: Set or reset remote node specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,FOLDER_SAVE*25 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) ! Get folder name + FOLDER_SAVE = FOLDER + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + IF (IER.EQ.0) THEN + IF (FOLDER_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: No privs to modify folder.'')') + IER = 1 + END IF + ELSE + WRITE (6,'('' ERROR: Specified folder not found.'')') + END IF + IF (IER.NE.0) THEN + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + RETURN + END IF + CALL CLOSE_BULLFOLDER + END IF + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' Cannot set remote node for GENERAL folder.'')') + ELSE IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + IF (.NOT.NODE_SET) THEN + IF (INDEX(FOLDER_BBOARD,'*').GT.0) THEN + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + CALL OPEN_BULLDIR ! Remove directory file which + CALL CLOSE_BULLDIR_DELETE ! contains remote folder name + REMOTE_SET = REMOTE_SET_SAVE + END IF + FOLDER1_BBOARD = 'NONE' + WRITE (6,'('' Remote node setting has been removed.'')') + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .FALSE. + ELSE + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Are you sure you want to make folder '// + & FOLDER(:TRIM(FOLDER))// + & ' remote? (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + IER = CLI$GET_VALUE('NODENAME',FOLDER1_BBOARD,FLEN) + FOLDER1_BBOARD = '::'//FOLDER1_BBOARD(:FLEN) + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'( + & '' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE + WRITE (6,'('' Folder has been converted to remote.'')') + END IF + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + IF (FOLDER.NE.FOLDER1) THEN ! Different remote folder name? + CALL OPEN_BULLDIR ! If so, put name in header + BULLDIR_HEADER(13:) = FOLDER1 ! of directory file. + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:FLEN+2)//'*' + END IF + REMOTE_SET = REMOTE_SET_SAVE + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .TRUE. + END IF + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (.NOT.NODE_SET.AND.FOLDER_BBOARD(:2).EQ.'::' + & .AND.BTEST(FOLDER_FLAG,2)) THEN + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER_BBOARD(3:TRIM(FOLDER_BBOARD)) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Disregister remote SYSTEM folder + WRITE(17,'(2A)',IOSTAT=IER) 14,0 + CLOSE (UNIT=17) + END IF + END IF + FOLDER_BBOARD = FOLDER1_BBOARD + IF (NODE_SET) THEN + F_NBULL = F1_NBULL + F_NEWEST_BTIM(1) = F1_NEWEST_BTIM(1) + F_NEWEST_BTIM(2) = F1_NEWEST_BTIM(2) + F_NEWEST_NOSYS_BTIM(1) = F1_NEWEST_NOSYS_BTIM(1) + F_NEWEST_NOSYS_BTIM(2) = F1_NEWEST_NOSYS_BTIM(2) + FOLDER_FLAG = 0 + F_EXPIRE_LIMIT = F1_EXPIRE_LIMIT + ELSE + F_NBULL = 0 + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to modify NODE.'')') + END IF + + IF (CLI$PRESENT('FOLDER')) THEN + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + END IF + + RETURN + END + + + + + SUBROUTINE RESPOND(STATUS) +C +C SUBROUTINE RESPOND +C +C FUNCTION: Sends a mail message in reply to a posted message. +C +C NOTE: Modify the last SPAWN statement to specify the command +C you use to send mail to sites other than via MAIL. +C If you always use a different command, modify both +C spawn commands. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER FROM_TEST*5,INFROM*(LINE_LENGTH) + + EXTERNAL CLI$_NEGATED + + IF (INCMD(:4).NE.'POST') THEN + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + BULL_PARAMETER = 'RE: '//DESCRIP + END IF + + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',BULL_PARAMETER,LEN_P) + IF (LEN_P.GT.LEN(BULL_PARAMETER)-2) THEN + WRITE(6,'('' ERROR: Subject limit is 64 characters.'')') + RETURN + END IF + ELSE IF (INCMD(:4).EQ.'POST') THEN + WRITE(6,'('' Enter subject of message:'')') + CALL GET_LINE(BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.0) THEN + WRITE(6,'('' ERROR: No subject specified.'')') + RETURN + END IF + END IF + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + EDIT = .TRUE. + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + ELSE + EDIT = .FALSE. + END IF + + IF (EDIT.AND.CLI$PRESENT('TEXT')) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + RETURN + END IF + END IF + + LENFRO = 0 + IF (CLI$GET_VALUE('CC',INPUT,ILEN)) THEN + INFROM = INPUT(:ILEN)//',' + LENFRO = ILEN + 1 + END IF + + IF ((EDIT.AND.CLI$PRESENT('TEXT')).OR. + & INCMD(:4).NE.'POST') THEN + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INFROM = INFROM(:LENFRO)//INPUT(7:) + LENFRO = LENFRO + ILEN - 6 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + INFROM = INFROM(:LENFRO)//FROM + LENFRO = TRIM(FROM) + LENFRO + END IF + + IF (CLI$PRESENT('LIST')) THEN + INFROM = INFROM(:LENFRO)//',' + LENFRO = LENFRO + 1 + END IF + + IF (INCMD(:4).EQ.'POST') LENFRO = 0 + + IF (EDIT.AND.CLI$PRESENT('TEXT')) THEN + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + + CALL CLOSE_BULLFIL + END IF + + IF (CLI$PRESENT('LIST')) THEN + LIST = INDEX(FOLDER_DESCRIP,'<') + IF (LIST.GT.0) THEN + INFROM = INFROM(:LENFRO)// + & FOLDER_DESCRIP(LIST+1:TRIM(FOLDER_DESCRIP)-1) + LENFRO = LENFRO + TRIM(FOLDER_DESCRIP) - 1 - LIST + ELSE + WRITE (6,'('' ERROR: No list address'', + & '' found in folder description.'')') + GO TO 900 + END IF + END IF + + I = 1 ! Must change all " to "" in FROM field + DO WHILE (I.LE.LENFRO) + IF (INFROM(I:I).EQ.'"') THEN + INFROM = INFROM(:I)//'"'//INFROM(I+1:) + I = I + 1 + LENFRO = LENFRO + 1 + END IF + I = I + 1 + END DO + + LEN_P = TRIM(BULL_PARAMETER) + I = 1 ! Must change all " to "" in SUBJECT field + DO WHILE (I.LE.LEN_P) + IF (BULL_PARAMETER(I:I).EQ.'"') THEN + IF (LEN_P.EQ.64) THEN + BULL_PARAMETER(I:I) = '`' + ELSE + BULL_PARAMETER = BULL_PARAMETER(:I)//'"' + & //BULL_PARAMETER(I+1:) + I = I + 1 + LEN_P = LEN_P + 1 + END IF + END IF + I = I + 1 + END DO + CALL DISABLE_PRIVS + IF (EDIT) THEN + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + IF (CLI$PRESENT('TEXT')) THEN + CONTEXT = 0 + CALL LIB$FIND_FILE('SYS$LOGIN:BULL.SCR',INPUT,CONTEXT) + VERSION = INDEX(INPUT,';') + 1 + IF (INPUT(VERSION:VERSION).EQ.'1') THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + END IF + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR "'//INFROM(:LENFRO) + & //'"/SUBJECT="'//BULL_PARAMETER//'"',,,,,,STATUS) + ELSE + CALL LIB$SPAWN('$MAIL SYS$INPUT "'//INFROM(:LENFRO)// + & '"/SUBJECT="'//BULL_PARAMETER//'"',,,,,,STATUS) + END IF + CALL ENABLE_PRIVS + +900 IF (EDIT) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + + END + + + INTEGER FUNCTION CONFIRM_USER(USERNAME) +C +C FUNCTION CONFIRM_USER +C +C FUNCTION: Confirms that username is valid user. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + CALL OPEN_SYSUAF_SHARED + + READ (8,KEY=USERNAME,IOSTAT=CONFIRM_USER) + + CALL CLOSE_SYSUAF + + RETURN + END + + + + + + SUBROUTINE REPLACE +C +C SUBROUTINE REPLACE +C +C FUNCTION: Replaces existing bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER INEXDATE*11,INEXTIME*11 + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH) + CHARACTER*1 ANSWER + + CHARACTER DATE_SAVE*11,TIME_SAVE*11 + + INTEGER TIMADR(2) + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + LOGICAL*1 DOALL + +C +C Get the bulletin number to be replaced. +C + IF (.NOT.CLI$PRESENT('NUMBER')) THEN ! No number has been specified + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE (6,1005) ! Tell user of the error + RETURN ! and return + END IF + NUMBER_PARAM = BULL_POINT ! Replace the bulletin we are reading + ELSE + CALL CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + DECODE(LEN_P,'(I)',BULL_PARAMETER) NUMBER_PARAM + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to system.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SYSTEM cannot be set with selected folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to shutdown.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SHUTDOWN cannot be set with selected folder.'')') + RETURN + ELSE IF (CLI$GET_VALUE('SHUTDOWN',BULL_PARAMETER).NE. + & %LOC(CLI$_ABSENT).AND.REMOTE_SET) THEN + WRITE (6,'('' ERROR: Shutdown node name not'', + & '' permitted for remote folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('PERMANENT').AND. + & .NOT.FOLDER_SET.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to permanent.'')') + RETURN + END IF +C +C Check to see if specified bulletin is present, and if the user +C is permitted to replace the bulletin. +C + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(NUMBER_PARAM,IER) ! Get info for specified bulletin + + CALL CLOSE_BULLDIR + + IF (IER.NE.NUMBER_PARAM+1) THEN ! Was bulletin found? + WRITE (6,1015) ! If not, tell the person + RETURN ! and error out + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.SETPRV_PRIV().AND. + & USERNAME.NE.FOLDER_OWNER.AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1090) ! If not, then error out. + RETURN + ELSE + WRITE (6,1100) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER ! Get his answer + CALL STR$UPCASE(ANSWER,ANSWER) ! Convert input to uppercase + IF (ANSWER.NE.'Y') RETURN ! If not Yes, then exit + END IF + END IF + +C +C If no switches were given, replace the full bulletin +C + + DOALL = .FALSE. + + IF ((.NOT.CLI$PRESENT('EXPIRATION')).AND. + & (.NOT.CLI$PRESENT('GENERAL')).AND. + & (.NOT.CLI$PRESENT('SYSTEM')).AND. + & (.NOT.CLI$PRESENT('HEADER')).AND. + & (.NOT.CLI$PRESENT('SUBJECT')).AND. + & (.NOT.CLI$PRESENT('TEXT')).AND. + & (.NOT.CLI$PRESENT('SHUTDOWN')).AND. + & (.NOT.CLI$PRESENT('PERMANENT'))) THEN + DOALL = .TRUE. + END IF + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + +8 LENDES = 0 + IF (CLI$PRESENT('HEADER').OR.DOALL) THEN + WRITE(6,1050) ! Request header for bulletin + READ(5,'(Q,A)',END=910,ERR=910) LENDES,INDESCRIP + IF (LENDES.EQ.0) GO TO 910 ! If no header, don't add bull + ELSE IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + END IF + + IF (LENDES.GT.0) THEN + INDESCRIP = 'Subj: '//INDESCRIP + LENDES = MIN(LENDES+6,LEN(INDESCRIP)) + END IF + + REC1 = 0 + + LENFROM = 0 + + IF (LENDES.GT.0.OR.CLI$PRESENT('TEXT').OR.DOALL) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='SCRATCH',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + REC1 = 1 + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INFROM = INPUT(:ILEN) + LENFROM = ILEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (LENDES.EQ.0.AND..NOT.DOALL) THEN + INDESCRIP = INPUT(:ILEN) + LENDES = ILEN + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + CALL CLOSE_BULLFIL + + IF (CLI$PRESENT('TEXT').OR.DOALL) CLOSE(UNIT=3) + END IF + + IF (CLI$PRESENT('TEXT').OR.DOALL) THEN +C +C If file specified in REPLACE command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + ICOUNT = 0 ! Line count for bulletin + LAST_NOBLANK = 0 ! Last line with data + REC1 = 1 + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT).OR. ! If file param in ADD command + & ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! or /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)))) THEN + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + IF (LEN_P.EQ.0) THEN ! If no file param specified + IF (.NOT.CLI$PRESENT('NEW')) THEN + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='NEW', + & RECL=LINE_LENGTH, + & ERR=920,FORM='FORMATTED',CARRIAGECONTROL='LIST') + CALL OPEN_BULLFIL_SHARED ! Prepare to copy message + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy message into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + CALL CLOSE_BULLFIL + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + ELSE + IF (.NOT.SETPRV_PRIV()) CALL DISABLE_PRIVS + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + END IF + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;-1') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + ELSE IF (LEN_P.GT.0) THEN + IF (.NOT.SETPRV_PRIV()) CALL DISABLE_PRIVS + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD', + & READONLY,SHARED,ERR=920,FORM='FORMATTED') ! Try opening the file + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT ! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + CALL STR$TRIM(INPUT,INPUT,ILEN) + IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN + 1 ! Increment record count + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0) THEN + IF (ICOUNT.GT.0) THEN + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + ELSE ! 1 space for a blank line. + REC1 = REC1 + 1 + END IF + END IF + END DO + ELSE ! If no input file + OPEN (UNIT=3,STATUS='NEW',FILE='SYS$LOGIN:BULL.SCR',ERR=920, + & DISPOSE='DELETE',FORM='FORMATTED',RECL=LINE_LENGTH, + & CARRIAGECONTROL='LIST') ! Scratch file to save bulletin + WRITE (6,1000) ! Request bulletin input from terminal + ILEN = LINE_LENGTH ! Length of input line + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Line too long. + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput::'')') LINE_LENGTH + ELSE IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + 1 + ILEN ! Increment character count + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.0) THEN + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + END IF ! 1 space for a blank line. + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 ICOUNT = LAST_NOBLANK + IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + END IF + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + DATE_SAVE = DATE + TIME_SAVE = TIME + INPUT = DESCRIP + + CALL OPEN_BULLDIR ! Prepare to add dir entry + + CALL READDIR(NUMBER_PARAM,IER) ! Get info for message + + IF (IER.NE.NUMBER_PARAM+1.OR.DATE.NE.DATE_SAVE.OR. + & TIME.NE.TIME_SAVE.OR.INPUT.NE.DESCRIP) THEN + ! If message disappeared, try to find it. + IF (IER.NE.NUMBER_PARAM+1) DATE = ' ' + NUMBER_PARAM = 0 + IER = 1 + DO WHILE (IER.EQ.NUMBER_PARAM+1.AND. + & (DATE.NE.DATE_SAVE.OR.TIME.NE.TIME_SAVE.OR.DESCRIP.NE.INPUT)) + NUMBER_PARAM = NUMBER_PARAM + 1 + CALL READDIR(NUMBER_PARAM,IER) + END DO + + IF (IER.NE.NUMBER_PARAM+1) THEN ! Couldn't find message + CALL CLOSE_BULLDIR + CLOSE (UNIT=3,STATUS='SAVE') + WRITE(6,'('' ERROR: Message has been deleted'', + & '' by another user.'')') + IF (DOALL.OR.CLI$PRESENT('TEXT')) THEN + WRITE (6,'('' New text has been saved in'', + & '' SYS$LOGIN:BULL.SCR.'')') + END IF + GO TO 100 + END IF + END IF + + CALL READDIR(0,IER) ! Get directory header + + IF (REC1.GT.0) THEN ! If text has been replaced + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + BLOCK = NBLOCK + 1 + BLOCK_SAVE = BLOCK + NEMPTY = NEMPTY + LENGTH + NBLOCK = NBLOCK + ICOUNT + + IF (.NOT.REMOTE_SET) CALL WRITEDIR(0,IER) + + OBLOCK = BLOCK + IF (LENFROM.GT.0) THEN + CALL STORE_BULL(LENFROM,INFROM(:LENFROM),OBLOCK) + END IF + IF (LENDES.GT.0) THEN + CALL STORE_BULL(LENDES,INDESCRIP(:LENDES),OBLOCK) + END IF + REWIND (UNIT=3) + CALL COPY_BULL(3,REC1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) THEN ! Error in creating bulletin + WRITE (6,'(A)') ' ERROR: Unable to replace message.' + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + END IF + + LENGTH_SAVE = OCOUNT - BLOCK + 1 + + CALL CLOSE_BULLFIL + + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(NUMBER_PARAM,IER) ! Get directory entry + LENGTH = LENGTH_SAVE ! Update size + BLOCK = BLOCK_SAVE + CALL WRITEDIR(NUMBER_PARAM,IER) ! Write new directory entry + END IF + ELSE + CALL READDIR(NUMBER_PARAM,IER) + END IF + + IF (.NOT.REMOTE_SET) THEN + + IF (LENDES.GT.0.OR.DOALL) THEN + DESCRIP=INDESCRIP(7:59) ! Update description header + END IF + CALL UPDATE_DIR_HEADER(CLI$PRESENT('EXPIRATION').OR.DOALL, + & CLI$PRESENT('PERMANENT'),CLI$PRESENT('SHUTDOWN'), + & INEXDATE,INEXTIME) + IF (CLI$PRESENT('SYSTEM')) THEN + SYSTEM = IBSET(SYSTEM,0) + ELSE IF (CLI$PRESENT('GENERAL')) THEN + SYSTEM = IBCLR(SYSTEM,0) + END IF + CALL WRITEDIR(NUMBER_PARAM,IER) + ELSE + MSGTYPE = 0 + IF (CLI$PRESENT('SYSTEM').OR. + & (BTEST(SYSTEM,0).AND..NOT.CLI$PRESENT('GENERAL'))) THEN + MSGTYPE = IBSET(MSGTYPE,0) + END IF + IF (CLI$PRESENT('PERMANENT')) THEN + MSGTYPE = IBSET(MSGTYPE,1) + ELSE IF (CLI$PRESENT('SHUTDOWN')) THEN + MSGTYPE = IBSET(MSGTYPE,2) + ELSE IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + MSGTYPE = IBSET(MSGTYPE,3) + END IF + IF (LENDES.EQ.0.AND..NOT.DOALL) INDESCRIP(7:) = DESCRIP + IF (CLI$PRESENT('EXPIRATION')) THEN + EXDATE = INEXDATE + EXTIME = INEXTIME + END IF + WRITE (REMOTE_UNIT,'(7A)',IOSTAT=IER) + & 10,DESCRIP,NUMBER_PARAM,INDESCRIP(7:59),MSGTYPE,EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + + CALL CLOSE_BULLDIR ! Totally finished with replace + + CLOSE (UNIT=3) + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + RETURN + +910 WRITE(6,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(6,1020) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + GOTO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1005 FORMAT (' ERROR: You are not reading any message.') +1010 FORMAT (' No message was replaced.') +1015 FORMAT (' ERROR: Specified message was not found.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1090 FORMAT(' ERROR: Specified message is not owned by you.') +1100 FORMAT(' Message is not owned by you.', + & ' Are you sure you want to replace it? ',$) +2020 FORMAT(1X,A) + + END + + + + SUBROUTINE UPDATE_DIR_HEADER(EXPIRE,PERM,SHUT,INEXDATE,INEXTIME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER TODAY*23,INEXDATE*11,INEXTIME*11 + + IF (EXPIRE) THEN + SYSTEM = IBCLR(SYSTEM,1) + SYSTEM = IBCLR(SYSTEM,2) + EXDATE=INEXDATE ! Update expiration date + EXTIME=INEXTIME + DIFF = COMPARE_DATE(EXDATE,NEWEST_EXDATE) ! Compare expiration + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,NEWEST_EXTIME) + IF (DIFF.LT.0) THEN ! If it's oldest expiration bull + NEWEST_EXDATE = EXDATE ! Update the header in + NEWEST_EXTIME = EXTIME ! the directory file + CALL WRITEDIR(0,IER) + END IF + ELSE IF (PERM.AND.(.NOT.BTEST(SYSTEM,1))) THEN + IF (BTEST(SYSTEM,2)) THEN + SYSTEM = IBCLR(SYSTEM,2) + SHUTDOWN = SHUTDOWN - 1 + CALL WRITEDIR(0,IER) + END IF + SYSTEM = IBSET(SYSTEM,1) + EXDATE = '5-NOV-2000' + EXTIME = '00:00:00.00' + ELSE IF (SHUT.AND.(.NOT.BTEST(SYSTEM,2))) THEN + SYSTEM = IBSET(SYSTEM,2) + SYSTEM = IBCLR(SYSTEM,1) + EXDATE = '5-NOV-2000' + NODE_AREA = 0 + IF (INCMD(:4).EQ.'REPL') THEN + IF (CLI$GET_VALUE('SHUTDOWN',NODE_NAME) + & .NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,NODE_NAME) + IF (NODE_AREA.EQ.0) THEN + WRITE (6,'('' ERROR: Shutdown node name ignored.'', + & '' Invalid node name specified.'')') + END IF + END IF + END IF + IF (NODE_AREA.EQ.0) 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) + SHUTDOWN = SHUTDOWN + 1 + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + SHUTDOWN_DATE = TODAY(:11) + SHUTDOWN_TIME = TODAY(13:) + CALL WRITEDIR(0,IER) + END IF + + RETURN + END + + + + + SUBROUTINE SEARCH(READ_COUNT) +C +C SUBROUTINE SEARCH +C +C FUNCTION: Search for bulletin with specified string +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*132 SEARCH_STRING,SAVE_STRING + DATA SEARCH_STRING /' '/, SEARCH_LEN /1/ + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CALL DISABLE_CTRL + + IF (CLI$PRESENT('START')) THEN ! Starting message specified + CALL CLI$GET_VALUE('START',BULL_PARAMETER,LEN_P) + DECODE(LEN_P,'(I)',BULL_PARAMETER) BULL_POINT + BULL_POINT = BULL_POINT - 1 + END IF + + SAVE_STRING = SEARCH_STRING + SAVE_LEN = SEARCH_LEN + + IER1 = CLI$GET_VALUE('SEARCH_STRING',SEARCH_STRING,SEARCH_LEN) + + IF (.NOT.IER1) THEN ! If no search string entered + SEARCH_STRING = SAVE_STRING ! use saved search string + SEARCH_LEN = SAVE_LEN + IF (SAVE_LEN.EQ.0) THEN + WRITE (6,'('' No search string present.'')') + RETURN + END IF + IF (STEP_BULL.EQ.-1) BULL_POINT = BULL_POINT - 2 + END IF + + CALL STR$UPCASE(SEARCH_STRING,SEARCH_STRING) ! Make upper case + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(0,IER) + + IF (IER1) THEN ! If string entered + IF (.NOT.CLI$PRESENT('START')) THEN ! If starting message not + BULL_POINT = 0 ! specified, use first + IF (CLI$PRESENT('REVERSE')) BULL_POINT = NBULL - 1 ! or last + END IF + SUBJECT = CLI$PRESENT('SUBJECT') + IF (CLI$PRESENT('REVERSE')) THEN + END_BULL = 1 + STEP_BULL = -1 + ELSE + END_BULL = NBULL + STEP_BULL = 1 + END IF + END IF + + IF ((BULL_POINT+1.GT.NBULL.AND.STEP_BULL.EQ.1).OR. + & (BULL_POINT+1.EQ.0)) THEN + WRITE (6,'('' ERROR: No more messages.'')') + CALL CLOSE_BULLDIR + CALL ENABLE_CTRL + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + CALL DECLARE_CTRLC_AST + + DO BULL_SEARCH = BULL_POINT+1, END_BULL, STEP_BULL + CALL READDIR(BULL_SEARCH,IER) ! Get bulletin directory entry + IF (IER.EQ.BULL_SEARCH+1) THEN + CALL STR$UPCASE(DESCRIP,DESCRIP) ! Make upper case + IF (INDEX(DESCRIP,SEARCH_STRING(:SEARCH_LEN)).GT.0) THEN + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + BULL_POINT = BULL_SEARCH - 1 + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + RETURN + END IF + END IF + IF (IER.EQ.BULL_SEARCH+1.AND..NOT.SUBJECT) THEN + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,BULL_SEARCH + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + GO TO 900 + ELSE + CALL GET_REMOTE_MESSAGE(IER) + IF (IER.GT.0) GO TO 900 + END IF + END IF + ILEN = LINE_LENGTH + 1 + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + CALL STR$UPCASE(INPUT,INPUT) ! Make upper case + IF (INDEX(INPUT,SEARCH_STRING(:SEARCH_LEN)).GT.0) THEN + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + BULL_POINT = BULL_SEARCH - 1 + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + RETURN + ELSE IF (FLAG.EQ.1) THEN + WRITE (6,'('' Search aborted.'')') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CALL ENABLE_CTRL + RETURN + END IF + END DO + END IF + END DO + +900 CALL CANCEL_CTRLC_AST + + CALL CLOSE_BULLFIL ! End of bulletin file read + CALL CLOSE_BULLDIR + + CALL ENABLE_CTRL + + WRITE (6,'('' No messages found with given search string.'')') + + RETURN + END + + + + + SUBROUTINE UNDELETE +C +C SUBROUTINE UNDELETE +C +C FUNCTION: Undeletes deleted message. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + +C +C Get the bulletin number to be undeleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + DECODE(LEN_P,5,BULL_PARAMETER,ERR=920) BULL_DELETE ! Yes +5 FORMAT(I) + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + GO TO 910 ! No, then error. + ELSE + BULL_DELETE = BULL_POINT ! Delete the file we are reading + END IF + + IF (BULL_DELETE.LE.0) GO TO 920 + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + CALL OPEN_BULLDIR + + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER + & .AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1040) ! Then error out. + GO TO 100 + ELSE + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + END IF + END IF + + IF (SYSTEM.LE.1) THEN ! General or System message + EXDATE = EXDATE(:7)//'19'//EXDATE(10:) + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(:6)//'20'//EXDATE(9:) + ELSE + EXDATE = EXDATE(:7)//'20'//EXDATE(10:) + END IF + END IF + + IF (.NOT.REMOTE_SET) THEN + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + WRITE (6,'('' Message was undeleted.'')') + ELSE + WRITE (REMOTE_UNIT,'(5A)',IOSTAT=IER) + & 11,BULL_DELETE,DESCRIP,EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + ELSE + WRITE (6,'('' Message was undeleted.'')') + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + +100 CALL CLOSE_BULLDIR + +900 RETURN + +910 WRITE(6,1010) + GO TO 900 + +920 WRITE(6,1020) + GO TO 900 + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not undeleted. Not owned by you.') + + END diff --git a/decus/lt89b1/bulletin/bulletin3.for b/decus/lt89b1/bulletin/bulletin3.for new file mode 100644 index 0000000..b593297 --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin3.for @@ -0,0 +1,1589 @@ +C +C BULLETIN3.FOR, Version 10/23/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE UPDATE +C +C SUBROUTINE UPDATE +C +C FUNCTION: Searches for bulletins that have expired and deletes them. +C +C NOTE: Assumes directory file is already opened. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER*107 DIRLINE + + CHARACTER*11 TEMP_DATE,TEMP_EXDATE,TEMP_NOSYSDATE + CHARACTER*11 TEMP_TIME,TEMP_EXTIME,TEMP_NOSYSTIME + + IF (REMOTE_SET.AND. + & NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + + IF (TEST_BULLCP().OR.REMOTE_SET) RETURN + ! BULLCP cleans up expired bulletins + + ENTRY UPDATE_ALWAYS ! Entry to skip BULLCP test + + TEMP_EXDATE = '5-NOV-2000' ! If a bulletin gets deleted, and there are + TEMP_EXTIME = '00:00:00.00' ! are no more bulletins, this is the value + ! assigned to the latest expiration date + + TEMP_DATE = '5-NOV-1956' ! Storage for computing newest + TEMP_TIME = '00:00:00.00' ! bulletin date if deletion occurs + + TEMP_NOSYSDATE = '5-NOV-1956' ! Storage for computing newest + TEMP_NOSYSTIME = '00:00:00.00' ! non-system bulletin date + + BULL_ENTRY = 1 ! Init bulletin pointer + UPDATE_DONE = 0 ! Flag showing bull has been deleted + + NEW_SHUTDOWN = 0 + OLD_SHUTDOWN = SHUTDOWN + + DO WHILE (1) + CALL READDIR(BULL_ENTRY,IER) ! Get next directory entry + IF (IER.EQ.BULL_ENTRY) GO TO 100 ! ERROR: Not found + IF (SYSTEM.LE.3.OR.(OLD_SHUTDOWN.EQ.0! If not shutdown, or time + & .AND.(SYSTEM.AND.4).EQ.4)) THEN ! to delete shutdowns? + IF ((SYSTEM.AND.4).EQ.4) THEN ! Shutdown bulletin? + IF (NODE_AREA.GT.0) THEN + EXTIME(3:4) = EXTIME(4:5) + READ (EXTIME(1:4),'(I4)') NODE_NUMBER_MSG + EXTIME(9:10) = EXTIME(10:11) + READ (EXTIME(7:10),'(I4)') NODE_AREA_MSG + IF (NODE_NUMBER_MSG.EQ.NODE_NUMBER.AND. + & NODE_AREA_MSG.EQ.NODE_AREA) THEN + DIFF = 0 + ELSE + DIFF = 1 + END IF + ELSE + DIFF = 1 + END IF + IF (DIFF.EQ.1) NEW_SHUTDOWN = NEW_SHUTDOWN + 1 + ELSE + DIFF = COMPARE_DATE(EXDATE,' ') ! Has expiration date passed? + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,' ') + END IF + IF (DIFF.LE.0) THEN ! If so then delete bulletin + CALL DELETE_ENTRY(BULL_ENTRY) ! Delete bulletin entry + IF (UPDATE_DONE.EQ.0) THEN ! If this is first deleted file + UPDATE_DONE = BULL_ENTRY ! store it to use for reordering + END IF ! directory file. + ELSE IF (SYSTEM.LE.3) THEN ! Expiration date hasn't passed + ! If a bulletin is deleted, we'll have to update the latest + ! expiration date. The following does that. + DIFF = COMPARE_DATE(EXDATE,TEMP_EXDATE) + IF (DIFF.LT.0.OR.(DIFF.EQ.0.AND. + & COMPARE_TIME(EXTIME,TEMP_EXTIME).LT.0)) THEN + TEMP_EXDATE = EXDATE ! If this is the latest exp + TEMP_EXTIME = EXTIME ! date seen so far, save it. + END IF + TEMP_DATE = DATE ! Keep date after search + TEMP_TIME = TIME ! we have the last message date + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + ELSE + TEMP_DATE = DATE + TEMP_TIME = TIME + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + BULL_ENTRY = BULL_ENTRY + 1 + END DO + +100 IF (UPDATE_DONE.GT.0) THEN ! Reorder directory file + CALL CLEANUP_DIRFILE(UPDATE_DONE) ! due to deleted entries + END IF + + DATE = NEWEST_DATE + TIME = NEWEST_TIME + CALL READDIR(0,IER) + SHUTDOWN = NEW_SHUTDOWN + NEWEST_EXDATE = TEMP_EXDATE + DIFF = COMPARE_DATE(NEWEST_EXDATE,' ') + IF (DIFF.GT.20*356) NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = TEMP_EXTIME + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL WRITEDIR(0,IER) + SYSTEM = 0 ! Updating last non-system date/time + NEWEST_DATE = TEMP_NOSYSDATE + NEWEST_TIME = TEMP_NOSYSTIME + CALL UPDATE_FOLDER + SYSTEM = 1 ! Now update latest date/time + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL UPDATE_FOLDER + + IF (NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN ! Shutdowns deleted? + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) ! Save that info + END IF + +C +C If newest message date has been changed, must change it in BULLUSER.DAT +C and also see if it affects notification of new messages to users +C + IF (TEMP_DATE.NE.DATE.OR.TEMP_TIME.NE.TIME) THEN + CALL UPDATE_LOGIN(.FALSE.) + END IF + + RETURN + + END + + + + SUBROUTINE UPDATE_READ +C +C SUBROUTINE UPDATE_READ +C +C FUNCTION: +C Store the latest date that user has used the BULLETIN facility. +C If new bulletins have been added, alert user of the fact. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($PRVDEF)' + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2),READ_BTIM_SAVE(2) + + LOGICAL MODIFY_SYSTEM /.TRUE./ + +C +C Update user's latest read time in his entry in BULLUSER.DAT. +C + + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.NE.0) THEN ! If header not present, exit + CALL CLOSE_BULLUSER + RETURN + ELSE IF (USERPRIV(1).EQ.-1.AND.USERPRIV(2).EQ.-1) THEN + ! If header present, but no + DO I=1,FLONG ! SET_FLAG and NOTIFY_FLAG + SET_FLAG_DEF(I) = 0 ! information, write default + NOTIFY_FLAG_DEF(I) = 0 ! flags. + BRIEF_FLAG_DEF(I) = 0 + END DO + SET_FLAG_DEF(1) = 1 + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + + CALL SYS$ASCTIM(,TODAY,,) ! Get today's time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + UNLOCK 4 + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + + IF (IER1.EQ.0) THEN ! If entry found, update it + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + ELSE ! If no entry create a new entry + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + CALL WRITE_USER_FILE_NEW(IER) + END IF + + IF (MODIFY_SYSTEM) THEN + CALL MODIFY_SYSTEM_LIST(1) + MODIFY_SYSTEM = .FALSE. + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + RETURN ! to go home... + + END + + + + + SUBROUTINE FIND_NEWEST_BULL +C +C SUBROUTINE FIND_NEWEST_BULL +C +C If new bulletins have been added, alert user of the fact and +C set the next bulletin to be read to the first new bulletin. +C +C OUTPUTS: +C BULL_POINT - If -1, no new bulletins to read, else there are. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INTEGER DIR_BTIM(2) + +C +C Now see if bulletins have been added since the user's previous +C read time. If they have, then search for the first new bulletin. +C Ignore new bulletins that are owned by the user or system notices +C that have not been added since the user has logged in. +C + BULL_POINT = -1 ! Init bulletin pointer + + CALL OPEN_BULLDIR_SHARED ! Yep, so get directory file + CALL READDIR(0,IER) ! Get # bulletins from header + IF (IER.EQ.1) THEN + CALL GET_NEWEST_MSG(LAST_READ_BTIM(1,FOLDER_NUMBER+1),START) + IF (START.LE.0) THEN + BULL_POINT = START + CALL CLOSE_BULLDIR + RETURN + END IF + DO WHILE (START.LE.NBULL.AND.(FROM.EQ.USERNAME.OR.SYSTEM)) + IF (FROM.NE.USERNAME) THEN ! Ignore bull if owner is user + IF (SYSTEM) THEN ! If system bulletin + CALL SYS_BINTIM(DATE//' '//TIME,DIR_BTIM) + DIFF = COMPARE_BTIM(LOGIN_BTIM,DIR_BTIM) + IF (DIFF.GT.0) THEN + START = START + 1 + CALL READDIR(START,IER) + ELSE ! SYSTEM bulletin was not seen + SYSTEM = 0 ! so force exit to read it. + END IF + END IF + ELSE + START = START + 1 + CALL READDIR(START,IER) + IF (IER.NE.START+1) START = NBULL + 1 + END IF + END DO + IF (START.LE.NBULL) BULL_POINT = START - 1 + END IF + + CALL CLOSE_BULLDIR + + RETURN + END + + + + SUBROUTINE GET_EXPIRED(EXPDAT,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 EXPDAT + CHARACTER*23 TODAY + + DIMENSION EXTIME(2),NOW(2) + + EXTERNAL CLI$_ABSENT + + IER = SYS$ASCTIM(,TODAY,,) ! Get today's date + + IERC = CLI$GET_VALUE('EXPIRATION',EXPDAT,ILEN) + + PROMPT = .TRUE. + +5 IF (PROMPT) THEN + IF (IERC.NE.%LOC(CLI$_ABSENT)) THEN ! Was value specified? + PROMPT = .FALSE. + ELSE + DEFAULT_EXPIRE = FOLDER_BBEXPIRE + IF ((DEFAULT_EXPIRE.GT.F_EXPIRE_LIMIT.OR.DEFAULT_EXPIRE + & .EQ.0).AND.F_EXPIRE_LIMIT.GT.0.AND. + & .NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER) THEN + DEFAULT_EXPIRE = F_EXPIRE_LIMIT + END IF + IF (BTEST(FOLDER_FLAG,3)) THEN ! NOPROMPT was set + IF (DEFAULT_EXPIRE.LE.0) THEN ! If no expiration date + SYSTEM = SYSTEM.OR.2 ! make permanent + EXPDAT = '5-NOV-2000 00:00:00.00' + ELSE ! Else set expiration + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + ELSE + IF (DEFAULT_EXPIRE.EQ.0) THEN ! Get expiration date + WRITE(6,1030) TODAY(:INDEX(TODAY,'.')-4) + ELSE IF (DEFAULT_EXPIRE.EQ.-1) THEN + WRITE(6,1031) TODAY(:INDEX(TODAY,'.')-4) + ELSE + WRITE(6,1032) TODAY(:INDEX(TODAY,'.')-4), + & DEFAULT_EXPIRE + END IF + WRITE (6,1035) + CALL GET_LINE(EXPDAT,ILEN) ! Get EXPDAT line + IF (ILEN.EQ.0.AND.DEFAULT_EXPIRE.NE.0) THEN + IF (DEFAULT_EXPIRE.EQ.-1) THEN + EXPDAT = '5-NOV-2000 00:00:00.00' + SYSTEM = IBSET(SYSTEM,1) ! Indicate permanent message + ELSE + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + END IF + END IF + END IF + ELSE + RETURN + END IF + + IF (ILEN.LE.0) THEN + IER = 0 + RETURN + END IF + + EXPDAT = EXPDAT(:ILEN) ! Change trailing zeros 2 spaces + + IF (INDEX(EXPDAT,'-').EQ.0.AND.INDEX(EXPDAT,':').GT.0.AND. + & INDEX(EXPDAT(:ILEN),' ').EQ.0) THEN ! Only time specified? + EXPDAT = TODAY(:INDEX(TODAY(2:),' ')+1)//EXPDAT ! Add date + ELSE IF (INDEX(EXPDAT(6:),'-').EQ.0.AND. ! Date specified + & INDEX(EXPDAT,'-').GT.0) THEN ! but no year? + SPACE = INDEX(EXPDAT,' ') - 1 ! Add year + IF (SPACE.EQ.-1) SPACE = TRIM(EXPDAT) + YEAR = INDEX(TODAY(6:),'-') + EXPDAT = EXPDAT(:SPACE)//TODAY(5+YEAR:9+YEAR)//EXPDAT(SPACE+1:) + END IF + + CALL STR$UPCASE(EXPDAT,EXPDAT) ! Convert to upper case + IER = SYS_BINTIM(EXPDAT,EXTIME) + IF (IER.NE.1) THEN ! If not able to do so + WRITE(6,1040) ! tell user is wrong + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + IF (TIMLEN.EQ.16) THEN + CALL SYS$GETTIM(NOW) + CALL LIB$SUBX(NOW,EXTIME,EXTIME) + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + END IF + + IF (EXPDAT(2:2).EQ.'-') EXPDAT = '0'//EXPDAT + IER = COMPARE_DATE(EXPDAT(:11),TODAY(:11)) ! Compare date with today's + IF (IER.GT.F_EXPIRE_LIMIT.AND.F_EXPIRE_LIMIT.GT.0.AND. + & .NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER) THEN + WRITE(6,1050) F_EXPIRE_LIMIT ! Expiration date > limit + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IF (IER.EQ.0) IER = COMPARE_TIME(EXPDAT(13:),TODAY(13:)) + IF (IER.LE.0) THEN ! If expiration date not future + WRITE(6,1045) ! tell user + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + + IF (PROMPT) THEN + IF (BTEST(SYSTEM,1)) THEN ! Permanent message + WRITE (6,'('' Message will be permanent.'')') + ELSE + WRITE (6,'('' Expiration date will be '',A,''.'')') + & EXPDAT(:TRIM(EXPDAT)) + END IF + END IF + + IER = 1 + + RETURN + +1030 FORMAT(' It is ',A,'. Specify when message expires.') +1031 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is permanent.') +1032 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is ',I3,' days.') +1035 Format(' Enter absolute time: [dd-mmm-yyyy] hh:mm:ss ', + & 'or delta time: dddd hh:mm:ss') +1040 FORMAT(' ERROR: Invalid date format specified.') +1045 FORMAT(' ERROR: Specified time has already passed.') +1050 FORMAT(' ERROR: Specified expiration period too large.' + & ' Limit is ',I3,' days.') + + END + + + SUBROUTINE MAILEDIT(INFILE,OUTFILE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SSDEF)' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL BULLETIN_SUBCOMMANDS + + CHARACTER*(*) INFILE,OUTFILE + + CHARACTER*80 MAIL_EDIT,OUT + + IER = SYS_TRNLNM('MAIL$EDIT',MAIL_EDIT) + + OUT = OUTFILE + IF (TRIM(OUT).EQ.0) THEN + OUT = INFILE + END IF + + IF (INDEX(MAIL_EDIT,'CALLABLE_').EQ.0.AND. + & IER.EQ.SS$_NORMAL) THEN + CALL DISABLE_PRIVS + IF (OUT.EQ.INFILE) THEN + CALL LIB$SPAWN('$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' "" '//OUT(:TRIM(OUT))) + ELSE + CALL LIB$SPAWN('$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' '//INFILE//' '//OUT(:TRIM(OUT))) + END IF + CALL ENABLE_PRIVS + ELSE IF (INDEX(MAIL_EDIT,'EDT').GT.0.OR. + & IER.NE.SS$_NORMAL) THEN + CALL EDT$EDIT(INFILE,OUT) + ELSE IF (INDEX(MAIL_EDIT,'TPU').GT.0) THEN + CONTEXT = 0 + IER = LIB$FIND_FILE(INFILE,MAIL_EDIT,CONTEXT) + IF (.NOT.IER) THEN + CALL TPU$EDIT(' ',OUT) + ELSE + CALL TPU$EDIT(INFILE,OUT) + END IF + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + ! TPU does CLI$ stuff which wipes our parsed command line + END IF + + RETURN + END + + + + + + SUBROUTINE CREATE_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE '($JPIDEF)' + + INCLUDE '($SSDEF)' + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /REALPROC/ REALPROCPRIV(2) + + DIMENSION IMAGEPRIV(2) + + CHARACTER IMAGENAME*132,ANSWER*1,PRCNAM*15 + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: You do not have the privileges '', + & ''to execute the command.'')') + CALL EXIT + END IF + + JUST_STOP = CLI$PRESENT('STOP') + + IF (JUST_STOP.AND..NOT.BTEST(REALPROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: You need SETPRV to execute /STOP.'')') + CALL EXIT + ELSE IF (.NOT.JUST_STOP.AND. + & .NOT.BTEST(REALPROCPRIV(1),PRV$V_SYSNAM)) THEN + CALL SYS$SETPRV(,,,IMAGEPRIV) + IF (.NOT.BTEST(IMAGEPRIV(1),PRV$V_SYSNAM)) THEN + WRITE (6,'('' ERROR: This new version of BULLETIN'', + & '' needs to be installed with SYSNAM.'')') + CALL EXIT + END IF + END IF + + IF (TEST_BULLCP()) THEN + IF (.NOT.JUST_STOP) THEN + WRITE (6,'('' BULLCP process running. + & Do you wish to kill it and restart a new one? '',$)') + READ (5,'(A)') ANSWER + IF (ANSWER.NE.'Y'.AND.ANSWER.NE.'y') CALL EXIT + END IF + + WILDCARD = -1 + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(PRCNAM),JPI$_PRCNAM,%LOC(PRCNAM)) + CALL ADD_2_ITMLST(4,JPI$_PID,%LOC(PID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + IER = 1 + DO WHILE (IER.AND.PRCNAM(:6).NE.'BULLCP') + ! Get next interactive process + IER = SYS$GETJPIW(,WILDCARD,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + IF (IER.AND.PID.NE.0) IER = SYS$DELPRC(PID,) + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + CALL EXIT + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP process has been terminated.'')') + CALL EXIT + END IF + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP is not presently running.'')') + CALL EXIT + END IF + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(FOLDER_DIRECTORY) + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$SET NOON' + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$LOOP:' + WRITE(11,'(A)') '$PURGE '//FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$OUTPUT ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$ERROR ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.ERR' + WRITE(11,'(A)') '$B/BULLCP' + WRITE(11,'(A)') '$WAIT 00:01:00' + WRITE(11,'(A)') '$GOTO LOOP' ! File open timed out + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = 0 + DO WHILE (IER.EQ.0.OR.(IER.EQ.SS$_DUPLNAM.AND.PID.GT.0)) + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT', + & FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM','NL:' + & ,,,,'BULLCP',%VAL(4),,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + END DO + + IF (IER) THEN + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM;-1', + & STATUS='OLD',IOSTAT=IER1) + IF (IER1.EQ.0) CLOSE(UNIT=11,STATUS='DELETE',IOSTAT=IER1) + END IF + + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + ELSE + IF (CONFIRM_USER('DECNET').NE.0) THEN + WRITE (6,'('' WARNING: Account with username DECNET'', + & '' does not exist.'')') + WRITE (6,'('' BULLCP will be owned by present account.'')') + END IF + WRITE (6,'('' Successfully created BULLCP detached process.'')') + END IF + CALL EXIT + + END + + + + + + + SUBROUTINE FIND_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + DATA BULLCP /0/ + + CHARACTER*1 DUMMY + + IER = SYS_TRNLNM('BULL_BULLCP',DUMMY) + IF (IER) BULLCP = 1 + + RETURN + END + + + + + LOGICAL FUNCTION TEST_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + TEST_BULLCP = BULLCP + + RETURN + END + + + + + SUBROUTINE RUN_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + + CHARACTER*23 OLD_TIME,NEW_TIME + + IF (TEST_BULLCP()) CALL EXIT ! BULLCP already running, so exit. + + CALL LIB$DATE_TIME(OLD_TIME) + + BULLCP = 2 ! Enable process to do BULLCP functions + + IER = SYS$CREMBX(%VAL(1),CHAN,,,,,'BULL_BULLCP') + IF (.NOT.IER) THEN ! Can't create mailbox, so exit. + CALL SYS_GETMSG(IER) + CALL EXIT + END IF + + IER = SYS$DELMBX(%VAL(CHAN)) ! If process dies, mailbox is deleted. + + CALL REGISTER_BULLCP + + CALL SET_REMOTE_SYSTEM + + CALL START_DECNET + + DO WHILE (1) ! Loop once every 15 minutes + CALL SYS$SETAST(%VAL(0)) + CALL LIB$DATE_TIME(NEW_TIME) + CALL GET_PROXY_ACCOUNTS ! Proxy info for incoming connections + CALL SYS$SETAST(%VAL(1)) + CALL BBOARD ! Look for BBOARD messages. + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).NE.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + IF (IER) THEN + CALL DELETE_EXPIRED ! Delete expired messages + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Do empty block + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! cleanup at 3 a.m. + IF (NEMPTY.GT.200) THEN + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + END IF + END IF + END IF + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Cleanup deleted users from + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! data files at 3 a.m. + CALL SYS$SETAST(%VAL(0)) + CALL TOTAL_CLEANUP_LOGIN + CALL SYS$SETAST(%VAL(1)) + END IF + + OLD_TIME = NEW_TIME + CALL WAIT('15') ! Wait for 15 minutes +C +C Look at remote folders and update local info to reflect new messages. +C Do here after waiting in case problem with connecting to remote folder +C which requires killing process. +C + FOLDER_Q = FOLDER_Q1 + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + CALL SYS$SETAST(%VAL(0)) + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + CALL REGISTER_BULLCP + CALL SYS$SETAST(%VAL(1)) + END DO + + RETURN + END + + + + + SUBROUTINE SET_REMOTE_SYSTEM + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER NODENAME*8 + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + CALL OPEN_BULLFOLDER_SHARED + + IER = 0 + DO WHILE (IER.EQ.0) + CALL READ_FOLDER_FILE(IER) + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER_FLAG,2) + & .AND.IER.EQ.0) THEN + CALL SELECT_FOLDER(.FALSE.,IER1) + IF (IER1) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14, + & BTEST(FOLDER_FLAG,2),NODENAME + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER + + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + + RETURN + END + + + + + SUBROUTINE REGISTER_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + NODE_AREA = 0 + END IF + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE UPDATE_SHUTDOWN(FOLDER_NUMBER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + CALL CLR2(SHUTDOWN_FLAG,FOLDER_NUMBER) + + SEEN_FLAG = 0 + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 ! All done with that node + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE WAIT(PARAM) +C +C SUBROUTINE WAIT +C +C FUNCTION: Waits for specified time period in minutes. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,PARAM*2 + DATA TIMBUF/'0 00:00:00.00'/ + + DATA WAIT_EF /0/ + + IF (WAIT_EF.EQ.0) CALL LIB$GET_EF(WAIT_EF) + + TIMBUF(6:7) = PARAM + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SETIMR(%VAL(WAIT_EF),TIMADR,,%VAL(2)) ! Set timer. + IER=SYS$WAITFR(%VAL(WAIT_EF)) ! Wait for EFN to be set. + + RETURN + END + + + + SUBROUTINE WAIT_SEC(PARAM) +C +C SUBROUTINE WAIT_SEC +C +C FUNCTION: Waits for specified time period in seconds. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,PARAM*2 + DATA TIMBUF/'0 00:00:00.00'/ + DATA WAIT_EF /0/ + + IF (WAIT_EF.EQ.0) CALL LIB$GET_EF(WAIT_EF) + + TIMBUF(9:10) = PARAM + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SETIMR(%VAL(WAIT_EF),TIMADR,,%VAL(3)) ! Set timer. + IER=SYS$WAITFR(%VAL(WAIT_EF)) ! Wait for EFN to be set. + + RETURN + END + + + + + SUBROUTINE DELETE_EXPIRED + +C +C SUBROUTINE DELETE_EXPIRED +C +C FUNCTION: +C +C Delete any expired bulletins (normal or shutdown ones). +C (NOTE: If bulletin files don't exist, they get created now by +C OPEN_FILE_SHARED. Also, if new format has been defined for files, +C they get converted now. The directory file has had it's record size +C lengthened in the past to include more info, and the bulletin file +C was lengthened from 80 to 81 characters to include byte which indicated +C start of bulletin message. However, that scheme was removed and +C was replaced with a 128 byte record compressed format). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER UPTIME_DATE*11,UPTIME_TIME*11 + + CALL OPEN_BULLDIR_SHARED ! Open directory file + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + CALL CLOSE_BULLFIL + CALL READDIR(0,IER) ! Get directory header + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired bulls? + IF (IER.GT.20*356) IER = -1 ! Check if latest expiration date valid. + IF (IER.EQ.0) IER = COMPARE_TIME(NEWEST_EXTIME,' ') + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)).AND. + & TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown messages exist and need to be checked? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER1.LE.0) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Reopen without sharing + CALL UPDATE ! Need to update + END IF + ELSE ! If header not there, then first time running BULLETIN + CALL OPEN_BULLUSER ! Create user file to be able to set + CALL CLOSE_BULLUSER ! defaults, privileges, etc. + END IF + CALL CLOSE_BULLDIR + + RETURN + END + + + + + SUBROUTINE BBOARD +C +C SUBROUTINE BBOARD +C +C FUNCTION: Converts mail to BBOARD into non-system bulletins. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + CHARACTER*11 INEXDATE + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH),INTO*76 + CHARACTER ACCOUNT_SAVE*8,USERNAME_SAVE*12 + + DIMENSION NEW_MAIL(FOLDER_MAX) + + DATA SPAWN_EF/0/ + + CALL SYS$SETAST(%VAL(0)) + + IF (SPAWN_EF.EQ.0) CALL LIB$GET_EF(SPAWN_EF) + + CALL DISABLE_CTRL + + CALL INIT_QUEUE(FOLDER_Q1,FOLDER_COM) + + FOLDER_Q = FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE(IER) + IF (IER.EQ.0) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + CALL SYS$SETAST(%VAL(1)) + + CALL SYS$SETAST(%VAL(0)) + CALL CHECK_MAIL(NEW_MAIL) + CALL SYS$SETAST(%VAL(1)) + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + + NBBOARD_FOLDERS = 0 + + POINT_FOLDER = 0 + +1 POINT_FOLDER = POINT_FOLDER + 1 + IF (POINT_FOLDER.GT.NUM_FOLDERS) GO TO 900 + + CALL SYS$SETAST(%VAL(0)) + + FOLDER_Q_SAVE = FOLDER_Q + + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (FOLDER_BBOARD.EQ.'NONE'.OR. + & FOLDER_BBOARD(:2).EQ.'::') GO TO 1 + + NBBOARD_FOLDERS = NBBOARD_FOLDERS + 1 + + IF (.NOT.NEW_MAIL(POINT_FOLDER)) GO TO 1 +C +C The process is set to the BBOARD uic and username in order to create +C a spawned process that is able to read the BBOARD mail (a real kludge). +C + + CALL GETUSER(USERNAME_SAVE) ! Get present username + CALL GETACC(ACCOUNT_SAVE) ! Get present account + CALL GETUIC(GROUP_SAVE,USER_SAVE) ! Get present uic + + IF (TRIM(FOLDER_BBOARD).GT.0) THEN ! BBOARD name present? + IER = SETUSER(FOLDER_BBOARD,USERNAME_SAVE)! Set to BBOARD username + IF (IER.EQ.2) GO TO 910 ! Can't set username. New VMS version? + CALL SETACC(ACCOUNTB) ! Set to BBOARD account + CALL SETUIC(IBCLR(GROUPB,31),IBCLR(USERB,31)) ! Set to BBOARD uic + END IF + + LEN_B = TRIM(BBOARD_DIRECTORY) + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.TXT;*') + ! Delete old TXT files left due to errors + + IF (.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)) THEN + ! If normal BBOARD user + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + IF (((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'READ_BOARD.COM', + & STATUS='NEW',ERR=910,CARRIAGECONTROL='LIST') + WRITE(11,'(A)') '$ SET PROTECT=(W:RWED)/DEFAULT' + WRITE(11,'(A)') '$ SET PROC/PRIV=SYSPRV' + WRITE(11,'(A)') + & '$ DEFINE/USER EXTRACT_FILE '//BBOARD_DIRECTORY(:LEN_B)// + & '''F$GETJPI("","USERNAME")''' + WRITE(11,'(A)') '$ MAIL' + WRITE(11,'(A)') 'READ' + WRITE(11,'(A)') 'EXTRACT/ALL/APPEND EXTRACT_FILE' + WRITE(11,'(A)') 'DELETE/ALL' + WRITE(11,'(A)') 'SELECT/NEW' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + ELSE + CONTEXT = 0 + IER = LIB$FIND_FILE(BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.COM',INPUT,CONTEXT) + IF (IER) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.COM','NL:', + & 'NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + IF (.NOT.IER.OR.((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & 'BOARD_SPECIAL.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + END IF + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),FOLDER_Q,FOLDER_COM) + + NBULL = F_NBULL + + CALL SETACC(ACCOUNT_SAVE) ! Reset to original account + CALL SETUSER(USERNAME_SAVE) ! Reset to original username + CALL SETUIC(GROUP_SAVE,USER_SAVE) ! Reset to original uic + + OPEN (UNIT=3,FILE=BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.TXT',STATUS='OLD',ERR=100) + READ (3,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read first line + CALL SYS$SETAST(%VAL(1)) + +5 CALL SYS$SETAST(%VAL(0)) + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),IDUMMY,FOLDER_COM) + + DO WHILE (LEN_INPUT.GT.0) + IF (INPUT(:5).EQ.'From:') THEN + INFROM = INPUT(7:) ! Store username + ELSE IF (INPUT(:5).EQ.'Subj:') THEN + INDESCRIP = INPUT(7:) ! Store subject + ELSE IF (INPUT(:3).EQ.'To:') THEN + INTO = INPUT(5:) ! Store address + END IF + READ (3,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read next line from mail + END DO + + INTO = INTO(:TRIM(INTO)) + CALL STR$TRIM(INTO,INTO) + CALL STR$UPCASE(INTO,INTO) + FLEN = TRIM(FOLDER_BBOARD) + IF (INDEX(INTO,FOLDER_BBOARD(:FLEN)).EQ.0.AND. + & INTO.NE.FOLDER_BBOARD.AND.INDEX(INTO,'@').EQ.0) THEN + POINT_FOLDER1 = 0 + FOLDER_Q2 = FOLDER_Q1 + FOLDER1_BBOARD = FOLDER_BBOARD + FOUND = .FALSE. + DO WHILE (.NOT.FOUND.AND.POINT_FOLDER1.LT.NUM_FOLDERS) + FOLDER_Q2_SAVE = FOLDER_Q2 + CALL READ_QUEUE(%VAL(FOLDER_Q2),FOLDER_Q2,FOLDER1_COM) + FLEN = TRIM(FOLDER1_BBOARD) + POINT_FOLDER1 = POINT_FOLDER1 + 1 + IF (POINT_FOLDER1.LE.NUM_FOLDERS.AND. + & FOLDER1_BBOARD(:2).NE.'::'.AND. + & FOLDER1_BBOARD.NE.'NONE') THEN + IF (INTO.EQ.FOLDER1_BBOARD) THEN + FOUND = .TRUE. + ELSE + FIND_TO = INDEX(INTO,FOLDER1_BBOARD(:FLEN)) + IF (FIND_TO.GT.0) THEN + END_TO = FLEN+FIND_TO + IF (TRIM(INTO).LT.END_TO.OR. + & INTO(END_TO:END_TO).LT.'A'.OR. + & INTO(END_TO:END_TO).GT.'Z') THEN + IF (FIND_TO.EQ.1) THEN + FOUND = .TRUE. + ELSE IF (INTO(FIND_TO-1:FIND_TO-1).LT.'A'.OR. + & INTO(FIND_TO-1:FIND_TO-1).GT.'Z') THEN + FOUND = .TRUE. + END IF + END IF + END IF + END IF + END IF + END DO + IF (FOUND) THEN + FOLDER_COM = FOLDER1_COM + FOLDER_Q_SAVE = FOLDER_Q2_SAVE + END IF + END IF + + READ (3,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT ! Read first line + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12).AND.IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (INPUT(:5).EQ.'From:') GO TO 5 + END DO ! If line is just form feed, the message is empty + IF (IER.NE.0) GO TO 100 ! If end of file, exit + + EFROM = 2 + I = TRIM(INFROM) + DO WHILE (EFROM.GT.0.AND.I.GT.0) ! Strip off the date + IF (INFROM(I:I).EQ.' ') EFROM = EFROM - 1 ! From the "From:" line + I = I - 1 + END DO + IF (I.GT.0) INFROM = INFROM(:I) + + CALL INIT_MESSAGE_ADD_BBOARD(INFROM,INDESCRIP,IER) + + ISTART = 0 + NBLANK = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Move text to bulletin file + IF (LEN_INPUT.EQ.0) THEN + IF (ISTART.EQ.1) THEN + NBLANK = NBLANK + 1 + END IF + ELSE + ISTART = 1 + DO I=1,NBLANK + CALL WRITE_MESSAGE_LINE(' ') + END DO + NBLANK = 0 + CALL WRITE_MESSAGE_LINE(INPUT) + END IF + READ (3,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12)) THEN + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12) + & .AND.IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + END DO + IF (IER.EQ.0.AND.INPUT(:5).EQ.'From:') THEN + IER = 1 + ELSE + NBLANK = NBLANK + 1 + END IF + END IF + END DO + + CALL FINISH_MESSAGE_ADD ! Totally finished with add + + CALL SYS$SETAST(%VAL(1)) + + GO TO 5 ! See if there is more mail + +100 CLOSE (UNIT=3,STATUS='DELETE') ! Close the input file + CALL SYS$SETAST(%VAL(1)) + GO TO 1 + +900 CALL SYS$SETAST(%VAL(0)) + + FOLDER_NUMBER = 0 + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNUM(0,IER) + CALL CLOSE_BULLFOLDER + CALL ENABLE_CTRL + FOLDER_SET = .FALSE. + + IF (NBBOARD_FOLDERS.EQ.0) THEN + CALL OPEN_BULLUSER + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',BBOARD_BTIM) + REWRITE (4) USER_HEADER ! Rewrite header + CALL CLOSE_BULLUSER + END IF + + CALL SYS$SETAST(%VAL(1)) + + RETURN + +910 WRITE (6,1010) + GO TO 100 + +930 CLOSE (UNIT=3) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + WRITE (6,1030) + GO TO 100 + +1010 FORMAT(' ERROR:Install program with CMKRNL privileges or relink.') +1030 FORMAT(' ERROR:Alert system programmer. Data file problems.') + + END + + + + + SUBROUTINE CREATE_BBOARD_PROCESS + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + CHARACTER*132 IMAGENAME + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(BBOARD_DIRECTORY) + + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='OLD',IOSTAT=IER) + IF (IER.EQ.0) CLOSE(UNIT=11,STATUS='DELETE') + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$ON ERROR THEN GOTO EXIT' + WRITE(11,'(A)') '$ON SEVERE THEN GOTO EXIT' + WRITE(11,'(A)') '$ON WARNING THEN GOTO EXIT' + WRITE(11,'(A)') '$B/'//'''F$PROCESS()''' + WRITE(11,'(A)') '$EXIT:' + WRITE(11,'(A)') '$LOGOUT' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT', + & BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM','NL:',, + & PROCPRIV,,'BBOARD',%VAL(4),,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + + RETURN + END + + + + SUBROUTINE GETUIC(GRP,MEM) +C +C SUBROUTINE GETUIC(UIC) +C +C FUNCTION: +C To get UIC of process submitting the job. +C OUTPUT: +C GRP - Group number of UIC +C MEM - Member number of UIC +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,JPI$_GRP,%LOC(GRP)) + CALL ADD_2_ITMLST(4,JPI$_MEM,%LOC(MEM)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + SUBROUTINE GET_UPTIME(UPTIME_DATE,UPTIME_TIME) +C +C SUBROUTINE GET_UPTIME +C +C FUNCTION: Gets time of last reboot. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + INTEGER UPTIME(2) + CHARACTER*(*) UPTIME_TIME,UPTIME_DATE + CHARACTER ASCSINCE*23 + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(8,SYI$_BOOTTIME,%LOC(UPTIME)) + CALL END_ITMLST(GETSYI_ITMLST) + + IER = SYS$GETSYI(,,,%VAL(GETSYI_ITMLST),,,) + + CALL SYS$ASCTIM(,ASCSINCE,UPTIME,) + + UPTIME_DATE = ASCSINCE(:11) + UPTIME_TIME = ASCSINCE(13:) + + RETURN + END + + + + INTEGER FUNCTION GET_L_VAL(I) + INTEGER I + GET_L_VAL = I + RETURN + END + + + + SUBROUTINE CHECK_MAIL(NEW_MAIL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + DIMENSION NEW_MAIL(1) + + CHARACTER INPUT*37,FILENAME*132 + + INTEGER*2 COUNT + + FOLDER_Q = FOLDER_Q1 ! so reinit queue pointer + + OPEN (UNIT=10,FILE='VMSMAIL_PROFILE', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL_PROFILE.DATA', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + OFFSET = 36 + + IF (IER.NE.0) THEN + OPEN (UNIT=10,FILE='VMSMAIL', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL.DAT', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + OFFSET = 34 + END IF + + DO I=1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (((.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)).OR. + & BTEST(GROUPB,31)).AND.FOLDER_BBOARD(:2).NE.'::') THEN + ! If normal BBOARD or /VMSMAIL + READ(10,'(A)',KEY=FOLDER_BBOARD,IOSTAT=IER1) INPUT + CALL LIB$MOVC3(2,%REF(INPUT(OFFSET:)),COUNT) + IF (IER1.EQ.0.AND.(COUNT.GT.0.OR.IER.NE.0)) THEN + NEW_MAIL(I) = .TRUE. + ELSE + NEW_MAIL(I) = .FALSE. + END IF + ELSE + NEW_MAIL(I) = .TRUE. + END IF + END DO + + CLOSE (10) + + RETURN + END + + + + SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C FUNCTION: +C To get image name of process. +C OUTPUT: +C IMAGNAME - Image name of process +C ILEN - Length of imagename +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CHARACTER*(*) IMAGNAME + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST_WITH_RET(LEN(IMAGNAME),JPI$_IMAGNAME, + & %LOC(IMAGNAME),%LOC(ILEN)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + + SUBROUTINE GET_NEWEST_MSG(IN_BTIM,START) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + DIMENSION IN_BTIM(2) + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 12,IN_BTIM(1),IN_BTIM(2) + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(A)',IOSTAT=IER) START + END IF + ELSE + CALL GET_MSGKEY(IN_BTIM,MSG_KEY) + CALL READDIR_KEYGE(START) + IF (START.EQ.0) THEN + START = -1 + END IF + END IF + + RETURN + END diff --git a/decus/lt89b1/bulletin/bulletin4.for b/decus/lt89b1/bulletin/bulletin4.for new file mode 100644 index 0000000..d86064c --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin4.for @@ -0,0 +1,1703 @@ +C +C BULLETIN4.FOR, Version 8/2/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C +C +C SUBROUTINE ITMLST_SUBS +C +C FUNCTION: +C A set of routines to easily create item lists. It allows one +C to easily create item lists without the need for declaring arrays +C or itemlist size. Thus, the code can be easily changed to add or +C delete item list codes. +C +C Here is an example of how to use the routines (prints file to a queue): +C +C CALL INIT_ITMLST ! Initialize item list +C ! Now add items to list +C CALL ADD_2_ITMLST(LEN,SJC$_FILE_SPECIFICATION,%LOC(FILENAME)) +C CALL ADD_2_ITMLST(9,SJC$_QUEUE,%LOC(QUEUE)) +C CALL END_ITMLST(SNDJBC_ITMLST) ! Get address of itemlist +C IER = SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SNDJBC_ITMLST),IOSB,,) +C + SUBROUTINE ITMLST_SUBS + + IMPLICIT INTEGER (A-Z) + + DATA SAVE_ITMLST_ADDRESS/0/,NUM_ITEMS/0/,QUEUE_HEADER/0/ + + ENTRY INIT_ITMLST + + IF (QUEUE_HEADER.EQ.0) THEN ! First time INIT_ITMLST ever called? + CALL LIB$GET_VM(8,QUEUE_HEADER) ! Yes, create queue header pointer + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER)) ! Zero out header + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER+4)) ! Zero out header + ELSE IF (SAVE_ITMLST_ADDRESS.GT.0) THEN ! Clean out old item list + CALL LIB$FREE_VM((NUM_ITEMS+1)*12,SAVE_ITMLST_ADDRESS) + NUM_ITEMS = 0 ! Release old itemlist memory + SAVE_ITMLST_ADDRESS = 0 + ELSE ! ITMLST calls cannot be nested. + WRITE (6,'('' ERROR: INIT_ITMLST called before previous'',$)') + WRITE (6,'(''+ ITMLST terminated with END_ITMLST.'')') + CALL EXIT + END IF + + RETURN + + + ENTRY ADD_2_ITMLST(BUFLEN,CODE,BUFADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR,0) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY ADD_2_ITMLST_WITH_RET(BUFLEN,CODE,BUFADR,RETADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR, + & RETADR) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY END_ITMLST(ITMLST_ADDRESS) + + CALL LIB$GET_VM((NUM_ITEMS+1)*12,ITMLST_ADDRESS) + ! Get memory for itemlist + SAVE_ITMLST_ADDRESS = ITMLST_ADDRESS ! Save address to remove memory + + DO I=1,NUM_ITEMS ! Place entries into itemlist + CALL LIB$REMQHI(%VAL(QUEUE_HEADER),INPUT_ITMLST) + CALL LIB$MOVC3(12,%VAL(INPUT_ITMLST+8), + & %VAL(ITMLST_ADDRESS+(I-1)*12)) + CALL LIB$FREE_VM(20,INPUT_ITMLST) + END DO + + CALL LIB$MOVC3(4,0,%VAL(ITMLST_ADDRESS+NUM_ITEMS*12)) + ! Place terminating 0 at end of itemlist + + RETURN + END + + + + SUBROUTINE STORE_ITMLST_ENTRY(INPUT_ITMLST,BUFLEN,CODE,BUFADR, + & RETADR) + + IMPLICIT INTEGER (A-Z) + + STRUCTURE /ITMLST/ + UNION + MAP + INTEGER*2 BUFLEN,CODE + INTEGER BUFADR,RETADR + END MAP + END UNION + END STRUCTURE + + RECORD /ITMLST/ INPUT_ITMLST(1) + + INPUT_ITMLST(1).BUFLEN = BUFLEN + INPUT_ITMLST(1).CODE = CODE + INPUT_ITMLST(1).BUFADR = BUFADR + INPUT_ITMLST(1).RETADR = RETADR + + RETURN + END + + + SUBROUTINE CLEANUP_LOGIN +C +C SUBROUTINE CLEANUP_LOGIN +C +C FUNCTION: Removes entry in user file of user that no longer exist +C if it creates empty space for new user. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 LOGIN_USER + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL OPEN_SYSUAF_SHARED + + LOGIN_USER = USERNAME + READ (4,IOSTAT=IER1,KEYGT=USERNAME) USER_ENTRY ! Look forward one + TEMP_USER = USERNAME + USERNAME = LOGIN_USER + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=TEMP_USER,IOSTAT=IER) TEMP_USER ! See if user exists + END DO + + IF (IER.NE.0.AND.IER1.EQ.0.AND.TEMP_USER.NE.USER_HEADER_KEY) THEN + ! If no UAF entry and last login was + ! more than 6 months old, delete entry + IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN + DELETE(UNIT=4) ! Delete non-existant user + CALL OPEN_BULLINF + READ (9,KEY=TEMP_USER,IOSTAT=IER) + IF (IER.EQ.0) DELETE(UNIT=9) + CALL CLOSE_BULLINF + END IF + END IF + + CALL CLOSE_SYSUAF ! All done... + + RETURN + END + + + SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C FUNCTION: Removes all entries in user file of usesr that no longer exist +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL OPEN_SYSUAF_SHARED + CALL OPEN_BULLUSER + CALL OPEN_BULLINF + + TEMP_USER = USERNAME + + READ (4,IOSTAT=IER) USER_ENTRY ! Skip header + + DO WHILE (IER.EQ.0) ! Clean out BULLUSER.DAT + READ (4,IOSTAT=IER) USER_ENTRY + IF (IER.EQ.0.AND.USERNAME(:1).NE.'*'.AND. + & USERNAME(:1).NE.':') THEN ! See if user exists + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=USERNAME,IOSTAT=IER) + END DO + IF (IER.NE.0) THEN ! If no UAF entry and last login was + ! more than 6 months old, delete entry + IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN + DELETE (UNIT=4) + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=9) + END IF + IER = 0 + END IF + END IF + END DO + + CALL CLOSE_SYSUAF ! All done... + + READ (9,KEYGT=' ',IOSTAT=IER) USERNAME + + DO WHILE (IER.EQ.0) ! Clean out BULLINF.DAT + READ (4,KEYEQ=USERNAME,IOSTAT=IER) + IF (IER.NE.0) DELETE (UNIT=9) + READ (9,IOSTAT=IER) USERNAME + END DO + + CALL CLOSE_BULLINF + CALL CLOSE_BULLUSER + + USERNAME = TEMP_USER + + RETURN + END + + + SUBROUTINE COPY_BULL(INLUN,IBLOCK,OBLOCK,IER) +C +C SUBROUTINE COPY_BULL +C +C FUNCTION: To copy data to the bulletin file. +C +C INPUT: +C INLUN - Input logical unit number +C IBLOCK - Input block number in input file to start at +C OBLOCK - Output block number in output file to start at +C +C OUTPUT: +C IER - If error in writing to bulletin, IER will be <> 0. +C +C NOTES: Input file is accessed using sequential access. This is +C to allow files which have variable records to be read. The +C bulletin file is assumed to be opened on logical unit 1. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + IF (IER.NE.0) CALL ERROR_AND_EXIT + END IF + + DO I=1,IBLOCK-1 + READ(INLUN,'(A)') + END DO + + OCOUNT = OBLOCK + ICOUNT = IBLOCK + + NBLANK = 0 + LENGTH = 0 + DO WHILE (1) + ILEN = 0 + DO WHILE (ILEN.EQ.0) + READ(INLUN,'(Q,A)',END=100) ILEN,INPUT + ILEN = MIN(ILEN,TRIM(INPUT),LINE_LENGTH) + IF (ILEN.GT.1.AND.ICHAR(INPUT(ILEN:ILEN)).EQ.10) THEN + INPUT(ILEN-1:ILEN-1) = CHAR(32) ! Remove imbedded + INPUT(ILEN:ILEN) = CHAR(32) ! CR/LFs at end of file. + ILEN = ILEN - 2 + END IF + IF (ILEN.GT.0) THEN + IF (ICOUNT.EQ.IBLOCK) THEN + IF (INPUT(:6).EQ.'From: ') THEN + INPUT(:4) = 'FROM' + END IF + END IF + ICOUNT = ICOUNT + 1 + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.IBLOCK) THEN + NBLANK = NBLANK + 1 + END IF + END DO + IF (NBLANK.GT.0) THEN + DO I=1,NBLANK + CALL STORE_BULL(1,' ',OCOUNT) + END DO + LENGTH = LENGTH + NBLANK*2 + NBLANK = 0 + END IF + CALL STORE_BULL(ILEN,INPUT,OCOUNT) + LENGTH = LENGTH + ILEN + 1 + END DO + +100 LENGTH = (LENGTH+127)/128 + IF (LENGTH.EQ.0) THEN + IER = 1 + ELSE + IER = 0 + END IF + + CALL FLUSH_BULL(OCOUNT) + + RETURN + END + + + + SUBROUTINE STORE_BULL(ILEN,INPUT,OCOUNT) + + IMPLICIT INTEGER (A-Z) + + PARAMETER BRECLEN=128 + + CHARACTER INPUT*(*),OUTPUT*256 + + DATA POINT/0/ + + IF (ILEN+POINT+1.GT.BRECLEN) THEN + IF (POINT.EQ.BRECLEN) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)) + OUTPUT = CHAR(ILEN)//INPUT + POINT = ILEN + 1 + ELSE IF (POINT.EQ.BRECLEN-1) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN)) + OUTPUT = INPUT + POINT = ILEN + ELSE + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN) + & //INPUT(:BRECLEN-1-POINT)) + OUTPUT = INPUT(BRECLEN-POINT:) + POINT = ILEN - (BRECLEN-1-POINT) + END IF + OCOUNT = OCOUNT + 1 + DO WHILE (POINT.GE.BRECLEN) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + OCOUNT = OCOUNT + 1 + OUTPUT = OUTPUT(BRECLEN+1:) + POINT = POINT - BRECLEN + END DO + ELSE + OUTPUT(POINT+1:) = CHAR(ILEN)//INPUT(:ILEN) + POINT = POINT + ILEN + 1 + END IF + + RETURN + + ENTRY FLUSH_BULL(OCOUNT) + + IF (POINT.LT.BRECLEN) OUTPUT(POINT+1:POINT+1) = CHAR(0) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + POINT = 0 + + RETURN + + END + + + SUBROUTINE WRITE_BULL_FILE(OCOUNT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*(*) OUTPUT + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 6,OUTPUT + ELSE + WRITE (1'OCOUNT) OUTPUT + END IF + + RETURN + END + + + SUBROUTINE GET_BULL_LINE(SBLOCK,BLENGTH,BUFFER,ILEN) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + IBLOCK = SBLOCK ! Initialize pointers. + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 + ELSE ! Else set ILEN to zero + ILEN = 0 ! to request next line + END IF + + DO WHILE (ILEN.EQ.0) ! Read until line created + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 ! Need to read new record. + IF (IBLOCK.GE.SBLOCK+BLENGTH) RETURN ! No more records. + END DO + + RETURN + + ENTRY TEST_MORE_RECORDS(SBLOCK,BLENGTH,IREC) + + IREC = (SBLOCK+BLENGTH-1) - IBLOCK + + RETURN + END + + + SUBROUTINE GET_BULL(IBLOCK,BUFFER,ILEN) +C +C SUBROUTINE GET_BULL +C +C FUNCTION: Outputs line from folder file. +C +C INPUT: +C IBLOCK - Input block number in input file to read from. +C +C OUTPUT: +C BUFFER - Character string containing output line. +C ILEN - Length of character string. If 0, signifies that +C new record needs to be read, -1 signifies error. +C +C NOTE: Since message file is stored as a fixed length (128) record file, +C but message lines are variable, message lines may span one or +C more record. This routine takes a record and outputs as many +C lines as it can from the record. When no more lines can be +C outputted, it returns ILEN=0 requesting the calling program to +C increment the record counter. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + PARAMETER BRECLEN=128 + + CHARACTER BUFFER*(*),TEMP*(BRECLEN), LEFT*(LINE_LENGTH) + + DATA POINT /1/, LEFT_LEN /0/ + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + POINT = 1 ! Initialize pointers. + LEFT_LEN = 0 + END IF + + IF (POINT.EQ.1) THEN ! Need to read new line? + IF (REMOTE_SET) THEN ! Remote folder? + IF (IBLOCK.EQ.BLOCK) SCRATCH_R = SCRATCH_R1 ! Read lines + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,TEMP) ! from queue + ELSE ! Local folder + DO WHILE (REC_LOCK(IER)) ! Read from file + READ (1'IBLOCK,IOSTAT=IER) TEMP + END DO + END IF + ELSE IF (POINT.EQ.BRECLEN+1) THEN ! Read all of line + ILEN = 0 ! so indicate need to read + POINT = 1 ! new line to calling routine. + RETURN + END IF + + IF (IER.GT.0) THEN ! Error in reading file. + ILEN = -1 ! ILEN = -1 signifies error + POINT = 1 + LEFT_LEN = 0 + RETURN + END IF + + IF (LEFT_LEN.GT.0) THEN ! Part of line is left from + ILEN = ICHAR(LEFT(:1)) ! previous record read. + IF (LEFT_LEN.LE.BRECLEN) THEN ! Rest of it is in next record. + BUFFER = LEFT(2:ILEN-LEFT_LEN+1)//TEMP(:LEFT_LEN) ! Output line. + POINT = LEFT_LEN + 1 ! Update pointers. + LEFT_LEN = 0 + ELSE ! Rest of line is longer than + LEFT(ILEN-LEFT_LEN+2:) = TEMP ! a record, so store record + LEFT_LEN = LEFT_LEN - BRECLEN ! and request another read. + ILEN = 0 ! Request new record read. + END IF + ELSE ! Else nothing left over. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Get line length + IF (ILEN.GT.BRECLEN-POINT) THEN ! If it extends to next record + LEFT = TEMP(POINT:) ! Store it in leftover buffer + LEFT_LEN = ILEN - (BRECLEN-POINT) ! Store leftover length + ILEN = 0 ! Request new record read + POINT = 1 ! Update record pointer. + ELSE IF (ILEN.EQ.0) THEN ! Empty line signifies + POINT = 1 ! end of message. + ELSE ! Else message line fully read + BUFFER = TEMP(POINT+1:POINT+ILEN) ! So output it + POINT = POINT+ILEN+1 ! and update pointer. + END IF + END IF + + RETURN + + ENTRY TEST_MORE_LINES(ILEN) ! Test for more lines in record. + ! Returns length of next line. + IF (POINT.EQ.BRECLEN+1) THEN ! If pointer greater than + ILEN = 0 ! record, no more lines. + ELSE ! Else there is another line. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Output it's length. + END IF + + RETURN + + END + + + + SUBROUTINE GET_REMOTE_MESSAGE(IER) +C +C SUBROUTINE GET_REMOTE_MESSAGE +C +C FUNCTION: +C Gets remote message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($RMSDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + IF (SCRATCH_R1.NE.0) THEN ! Is queue empty? + SCRATCH_R = SCRATCH_R1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_R,INPUT) + SCRATCH_R1 = SCRATCH_R ! Init header pointer + END IF + + ILEN = 128 + IER = 0 + LENGTH = 0 + DO WHILE (ILEN.GT.0.AND.IER.EQ.0) + READ (REMOTE_UNIT,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0.AND.ILEN.GT.0) THEN + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.RMS$_RER) THEN ! Ignore this error + IER = 0 + ILEN = 0 + ELSE + CALL SYS_GETMSG(IER1) + LENGTH = 0 + IER1 = IER + CALL DISCONNECT_REMOTE + IER = IER1 ! IER is set to 0 by DISCONNECT_REMOTE + END IF + ELSE IF (ILEN.GT.0) THEN + CALL WRITE_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT) + LENGTH = LENGTH + 1 + END IF + END DO + + RETURN + END + + + + + SUBROUTINE DELETE_ENTRY(BULL_ENTRY) +C +C SUBROUTINE DELETE_ENTRY +C +C FUNCTION: +C To delete a directory entry. +C +C INPUTS: +C BULL_ENTRY - Bulletin entry number to delete +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (NBULL.GT.0) THEN + CALL READDIR(0,IER) + NBULL = -NBULL + CALL WRITEDIR(0,IER) + END IF + + IF (BTEST(FOLDER_FLAG,1)) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',IOSTAT=IER,STATUS='OLD', + & RECL=LINE_LENGTH,CARRIAGECONTROL='LIST',ACCESS='APPEND') + IF (IER.NE.0) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + WRITE (3,'(A)') CHAR(12) + END IF + + CALL OPEN_BULLFIL + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + WRITE(3,1050) INPUT(7:ILEN) + ELSE + WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + + CALL CLOSE_BULLFIL + END IF + +900 CALL READDIR(BULL_ENTRY,IER) + DELETE(UNIT=2) + + NEMPTY = NEMPTY + LENGTH + CALL WRITEDIR(0,IER) + +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,' Date: ',A11) + + RETURN + END + + + + + SUBROUTINE GET_EXDATE(EXDATE,NDAYS) +C +C SUBROUTINE GET_EXDATE +C +C FUNCTION: Computes expiration date giving number of days to expire. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*11 EXDATE + + CHARACTER*3 MONTHS(12) + DIMENSION LENGTH(12) + DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP', + & 'OCT','NOV','DEC'/ + DATA LENGTH/31,27,31,30,31,30,31,31,30,31,30,31/ + + CALL SYS$ASCTIM(,EXDATE,,) ! Get the present date + + DECODE(2,'(I2)',EXDATE(:2)) DAY ! Get day + DECODE(4,'(I4)',EXDATE(8:11)) YEAR ! Get year + + MONTH = 1 + DO WHILE (MONTHS(MONTH).NE.EXDATE(4:6)) ! Get month + MONTH = MONTH + 1 + END DO + + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + + NUM_DAYS = NDAYS ! Put number of days into buffer variable + + DO WHILE (NUM_DAYS.GT.0) + IF (NUM_DAYS+DAY.GT.LENGTH(MONTH)) THEN + ! If expiration date exceeds end of month + NUM_DAYS = NUM_DAYS - (LENGTH(MONTH) - DAY + 1) + ! Decrement # of days by days left in month + DAY = 1 ! Reset day to first of month + MONTH = MONTH + 1 ! Increment month pointer + IF (MONTH.EQ.13) THEN ! Moved into next year? + MONTH = 1 ! Reset month pointer + YEAR = YEAR + 1 ! Increment year pointer + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + END IF + ELSE ! If expiration date is within the month + DAY = DAY + NUM_DAYS ! Find expiration day + NUM_DAYS = 0 ! Force loop exit + END IF + END DO + + ENCODE(2,'(I2)',EXDATE(:2)) DAY ! Put day into new date + ENCODE(4,'(I4)',EXDATE(8:11)) YEAR ! Put year into new date + EXDATE(4:6) = MONTHS(MONTH) ! Put month into new date + + RETURN + END + + + + SUBROUTINE GET_LINE(INPUT,LEN_INPUT) +C +C SUBROUTINE GET_LINE +C +C FUNCTION: +C Gets line of input from terminal. +C +C OUTPUTS: +C LEN_INPUT - Length of input line. If = -1, CTRLC entered. +C if = -2, CTRLZ entered. +C +C NOTES: +C Also, on first call, set LEN_INPUT to 1+LENGTH OF INPUT CHARCTER +C for initializing the CTRLC AST. +C + + IMPLICIT INTEGER (A-Z) + + LOGICAL*1 DESCRIP(8),DTYPE,CLASS + INTEGER*2 LENGTH + CHARACTER*(*) INPUT + EQUIVALENCE (DESCRIP(1),LENGTH),(DESCRIP(3),DTYPE) + EQUIVALENCE (DESCRIP(4),CLASS),(DESCRIP(5),POINTER) + + EXTERNAL SMG$_EOF + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + CHARACTER PROMPT*(*),NULLPROMPT*1 + LOGICAL*1 USE_PROMPT + + USE_PROMPT = .FALSE. + + GO TO 5 + + ENTRY GET_INPUT_PROMPT(INPUT,LEN_INPUT,PROMPT) + + USE_PROMPT = .TRUE. + +5 LIMIT = LEN(INPUT) ! Get input line size limit + INPUT = ' ' ! Clean out input buffer + +C +C Initialize CTRL-C AST with AST routine CTRLC_ROUTINE and +C AST parameter FLAG. When CTRLC occurs, FLAG is set to 1 +C + + CALL DECLARE_CTRLC_AST + + LEN_INPUT = 0 ! Nothing inputted yet + + LENGTH = 0 ! Init special variable + DTYPE = 0 ! descriptor so we won't + CLASS = 2 ! run into any memory limit + POINTER = 0 ! during input. + +C +C LIB$GET_INPUT is nice way of getting input from terminal, +C as it handles such thing as accidental wrap around to next line. +C + + IF (DECNET_PROC) THEN + READ (5,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (IER.NE.0) LEN_INPUT = -2 + RETURN + ELSE IF (USE_PROMPT) THEN + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,PROMPT) ! Get line from terminal with prompt + ELSE + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,NULLPROMPT) ! Get line from terminal with no prompt + END IF + + IF (.NOT.IER.AND.IER.NE.%LOC(SMG$_EOF)) CALL EXIT(IER) + + CALL STR$TRIM(DESCRIP,DESCRIP,LEN_INPUT) + + IF (FLAG.EQ.0) THEN ! If no CTRL-C has occurred + CALL CANCEL_CTRLC_AST ! Cancel CTRL-C AST + IF (IER.NE.%LOC(SMG$_EOF)) THEN ! End of input? + LEN_INPUT = MIN(LIMIT,LENGTH) ! No. Get length of line + DO I=0,LEN_INPUT-1 ! Extract from descriptor + CALL GET_VAL(INPUT(I+1:I+1),%VAL(POINTER+I)) + END DO + CALL CONVERT_TABS(INPUT,LEN_INPUT) + LEN_INPUT = MAX(LEN_INPUT,LENGTH) + ELSE + LEN_INPUT = -2 ! If CTRL-Z, say so + END IF + ELSE + LEN_INPUT = -1 ! If CTRL-C, say so + END IF + RETURN + END + + + + SUBROUTINE CONVERT_TABS(INPUT,LEN_INPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT + + PARAMETER TAB = CHAR(9) + + LIMIT = LEN(INPUT) + + DO WHILE (INDEX(INPUT,TAB).GT.0.AND.LEN_INPUT.LT.LIMIT) + TAB_POINT = INDEX(INPUT,TAB) ! Remove tabs + MOVE = ((TAB_POINT-1)/8)*8 + 9 + ADD = MOVE - TAB_POINT + IF (MOVE-1.LE.LIMIT) THEN + INPUT(MOVE:) = INPUT(TAB_POINT+1:) + DO I = TAB_POINT,MOVE-1 + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LEN_INPUT + ADD - 1 + ELSE + DO I = TAB_POINT,LIMIT + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LIMIT+1 + END IF + END DO + + CALL FILTER (INPUT, LEN_INPUT) + + RETURN + END + + + SUBROUTINE FILTER (INCHAR, LENGTH) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INCHAR + + DO I = 1,LENGTH + IF ((INCHAR(I:I).LT.' '.AND. + & INCHAR(I:I).NE.CHAR(13).AND.INCHAR(I:I).NE.CHAR(10))) + & INCHAR(I:I) = '.' + END DO + + RETURN + END + + + SUBROUTINE GET_VAL(OUTPUT,INPUT) ! Used to convert logical + CHARACTER*(*) OUTPUT ! byte to character value + LOGICAL*1 INPUT + OUTPUT = CHAR(INPUT) + RETURN + END + + SUBROUTINE CTRLC_ROUTINE ! CTRL-C AST routine + IMPLICIT INTEGER (A-Z) ! If CTRL-C, come here + + COMMON /CTRLY/ CTRLY + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + IF (FLAG.EQ.2) THEN + CALL LIB$PUT_OUTPUT('Bulletin aborting...') + CALL SYS$CANEXH() + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + CALL EXIT + END IF + FLAG = 1 ! to set flag + RETURN + END + + + + SUBROUTINE DECLARE_CTRLC_AST +C +C SUBROUTINE DECLARE_CTRLC_AST +C +C FUNCTION: +C Declares a CTRLC ast. +C NOTES: +C Assumes terminal assigned to TERM_CHAN in common /TERM_CHAN/. +C + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SETMODE,IO$M_CTRLCAST,CTRLC_ROUTINE + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /CTRLC_FLAG/ FLAG + + FLAG = 0 ! Init CTRL-C flag + IO_CTRLC = %LOC(IO$_SETMODE)+%LOC(IO$M_CTRLCAST) ! Set AST code + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + + ENTRY CANCEL_CTRLC_AST + + IER = SYS$CANCEL(%VAL(TERM_CHAN)) + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + END + + + + + SUBROUTINE GET_INPUT_NOECHO(DATA) +C +C SUBROUTINE GET_INPUT_NOECHO +C +C FUNCTION: Reads data in from terminal without echoing characters. +C Also contains entry to assign terminal. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) DATA,PROMPT + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /READIT/ READIT + + INCLUDE '($TRMDEF)' + + INTEGER TERMSET(2) + + INTEGER MASK(4) + DATA MASK/4*'FFFFFFFF'X/ + + DATA PURGE/.TRUE./ + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NOECHO_PROMPT(DATA,PROMPT) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NUM(DATA,NLEN) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_PURGE,,TERMSET,NLEN,TERM) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA),,, + & TERMSET,NLEN,TERM) + END IF + + IF (TERM.NE.13.AND.TERM.NE.510.AND.NLEN.EQ.0) THEN + ! Input did not end with CR or buffer full + NLEN = 1 + DATA(:1) = CHAR(TERM) + END IF + + RETURN + + ENTRY ASSIGN_TERMINAL + + IER = SYS$ASSIGN('TT',TERM_CHAN,,) ! Assign terminal + + CALL DECLARE_CTRLC_AST + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IF (CLI$PRESENT('KEYPAD')) THEN + CALL SET_KEYPAD + ELSE IF (READIT.EQ.0) THEN + CALL SET_NOKEYPAD + END IF + + TERMSET(1) = 16 + TERMSET(2) = %LOC(MASK) + + DO I=ICHAR('0'),ICHAR('9') + MASK(2) = IBCLR(MASK(2),I-32) + END DO + + RETURN + END + + + + + + SUBROUTINE GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) +C +C SUBROUTINE GETPAGSIZ +C +C FUNCTION: +C Gets page size of the terminal. +C +C OUTPUTS: +C PAGE_LENGTH - Page length of the terminal. +C PAGE_WIDTH - Page size of the terminal. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($DVIDEF)' + + LOGICAL*1 DEVDEPEND(4) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,DVI$_DEVDEPEND,%LOC(DEVDEPEND(1))) + CALL ADD_2_ITMLST(4,DVI$_DEVBUFSIZ,%LOC(PAGE_WIDTH)) + CALL END_ITMLST(GETDVI_ITMLST) ! Get address of itemlist + + CALL SYS$GETDVIW(,,'TT',%VAL(GETDVI_ITMLST),,,,) + + PAGE_LENGTH = ZEXT(DEVDEPEND(4)) + + PAGE_WIDTH = MIN(PAGE_WIDTH,132) + + RETURN + END + + + + + + LOGICAL FUNCTION SLOW_TERMINAL +C +C FUNCTION SLOW_TERMINAL +C +C FUNCTION: +C Indicates that terminal has a slow speed (2400 baud or less). +C +C OUTPUTS: +C SLOW_TERMINAL = .true. if slow, .false. if not. +C + + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SENSEMODE + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON CHAR_BUF(2) + + LOGICAL*1 IOSB(8) + + INCLUDE '($TTDEF)' + + IER = SYS$QIOW(,%VAL(TERM_CHAN),IO$_SENSEMODE,IOSB,,, + & CHAR_BUF,%VAL(8),,,,) + + IF (IOSB(3).LE.TT$C_BAUD_2400) THEN + SLOW_TERMINAL = .TRUE. + ELSE + SLOW_TERMINAL = .FALSE. + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_PRIV +C +C SUBROUTINE SHOW_PRIV +C +C FUNCTION: +C To show privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($PRVDEF)' + + INCLUDE '($SSDEF)' + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + IF (NEW_FLAG(1).EQ.-1.AND.NEW_FLAG(2).EQ.-1) THEN ! Info not present + CALL CLOSE_BULLUSER + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + WRITE (6,'('' Following privileges are needed for privileged + & commands:'')') + DO I=0,38 + IF ((I.LT.32.AND.BTEST(USERPRIV(1),I)).OR. + & (I.GT.31.AND.BTEST(USERPRIV(2),I-32))) THEN + WRITE (6,'(1X,A)') PRIVS(I) + END IF + END DO + ELSE + WRITE (6,'('' ERROR: Cannot show privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + CALL CHKACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE)),IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN + CALL SHOWACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE))) + END IF + + RETURN + + END + + + + + SUBROUTINE SET_PRIV +C +C SUBROUTINE SET_PRIV +C +C FUNCTION: +C To set privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + DATA PRIVS + & /'CMKRNL','CMEXEC','SYSNAM','GRPNAM','ALLSPOOL','DETACH', + & 'DIAGNOSE','LOG_IO','GROUP','ACNT','PRMCEB','PRMMBX','PSWAPM', + & 'ALTPRI','SETPRV','TMPMBX','WORLD','MOUNT','OPER','EXQUOTA', + & 'NETMBX','VOLPRO','PHY_IO','BUGCHK','PRMGBL','SYSGBL','PFNMAP', + & 'SHMEM','SYSPRV','BYPASS','SYSLCK','SHARE','UPGRADE','DOWNGRADE', + & 'GRPPRV','READALL',' ',' ','SECURITY'/ + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + DIMENSION ONPRIV(2),OFFPRIV(2) + + CHARACTER*32 INPUT_PRIV + + IF (.NOT.SETPRV_PRIV().OR..NOT.BTEST(PROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: This command requires SETPRV privileges.'')') + RETURN + END IF + + IF (CLI$PRESENT('ID').OR. + & CLI$PRESENT('ID').EQ.%LOC(CLI$_NEGATED)) THEN + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the IDs + IF (CLI$PRESENT('ID')) THEN + CALL ADD_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + ELSE + CALL DEL_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + END IF + IF (.NOT.IER) CALL SYS_GETMSG(IER) + END DO + RETURN + END IF + + OFFPRIV(1) = 0 + OFFPRIV(2) = 0 + ONPRIV(1) = 0 + ONPRIV(2) = 0 + + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the privileges + PRIV_FOUND = -1 + I = 0 + DO WHILE (I.LT.39.AND.PRIV_FOUND.EQ.-1) + IF (INPUT_PRIV(:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + IF (INPUT_PRIV(3:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + I = I + 1 + END DO + IF (PRIV_FOUND.EQ.-1) THEN + WRITE(6,'('' ERROR: Incorrectly specified privilege = '', + & A)') INPUT_PRIV(:PLEN) + RETURN + ELSE IF (INPUT_PRIV(:2).EQ.'NO') THEN + IF (INPUT_PRIV.EQ.'NOSETPRV') THEN + WRITE(6,'('' ERROR: Cannot remove SETPRV privileges.'')') + RETURN + ELSE IF (PRIV_FOUND.LT.32) THEN + OFFPRIV(1) = IBSET(OFFPRIV(1),PRIV_FOUND) + ELSE + OFFPRIV(2) = IBSET(OFFPRIV(2),PRIV_FOUND-32) + END IF + ELSE + IF (PRIV_FOUND.LT.32) THEN + ONPRIV(1) = IBSET(ONPRIV(1),PRIV_FOUND) + ELSE + ONPRIV(2) = IBSET(ONPRIV(2),PRIV_FOUND-32) + END IF + END IF + END DO + + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + USERPRIV(1) = USERPRIV(1).OR.ONPRIV(1) + USERPRIV(2) = USERPRIV(2).OR.ONPRIV(2) + USERPRIV(1) = USERPRIV(1).AND.(.NOT.OFFPRIV(1)) + USERPRIV(2) = USERPRIV(2).AND.(.NOT.OFFPRIV(2)) + REWRITE (4) USER_HEADER + WRITE (6,'('' Privileges successfully modified.'')') + ELSE + WRITE (6,'('' ERROR: Cannot modify privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + RETURN + + END + + + + + + + SUBROUTINE ADD_ACL(ID,ACCESS,IER) +C +C SUBROUTINE ADD_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + INCLUDE '($SSDEF)' + + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) THEN + IF (IER.EQ.SS$_NOSUCHID.AND.ADDID.AND. + & INDEX(ACCESS,'C').EQ.0) THEN + CALL GET_UAF(ID,USER,GROUP,ACCOUNT,FLAGS,IER) + IF (.NOT.IER) THEN + CALL ERRSNS(IDUMMY,IER) + WRITE (6,'( + & '' ERROR: Specified username cannot be verified.'')') + CALL SYS_GETMSG(IER) + RETURN + END IF + IDENT = USER + ISHFT(GROUP,16) + IER = SYS$ADD_IDENT(ID,%VAL(IDENT),,) + IF (IER) THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + END IF + END IF + END IF + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_ADDACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IF (INDEX(ACCESS,'C').GT.0.AND.INDEX(ACCESS,'W').EQ.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + SUBROUTINE DEL_ACL(ID,ACCESS,IER) +C +C SUBROUTINE DEL_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + IF (ID.NE.' ') THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_DELACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_DELETEACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + END IF + + IF (INDEX(ACCESS,'C').GT.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + + SUBROUTINE CREATE_FOLDER +C +C SUBROUTINE CREATE_FOLDER +C +C FUNCTION: Creates a new bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + IF (.NOT.SETPRV_PRIV().AND.CLI$PRESENT('NEEDPRIV')) THEN + WRITE(6,'('' ERROR: CREATE is a privileged command.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('CREATE_FOLDER',FOLDER,LEN_T) ! Get folder name + + IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + IF (.NOT.SETPRV_PRIV().AND. ! /NOTIFY /READNEW /BRIEF privileged + & (CLI$PRESENT('NOTIFY').OR.CLI$PRESENT('READNEW').OR. + & CLI$PRESENT('BRIEF').OR.CLI$PRESENT('SYSTEM'))) THEN + WRITE (6,'( + & '' ERROR: No privs for SYSTEM, NOTIFY, BRIEF or READNEW.'')') + RETURN + END IF + + IF (CLI$PRESENT('NODE')) THEN ! Remote node specified? + IER = CLI$GET_VALUE('NODE',FOLDER_BBOARD,LEN_B) ! Get node name + FOLDER_BBOARD = '::'//FOLDER_BBOARD(:LEN_B) + FOLDER1_BBOARD = FOLDER_BBOARD + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE IF (CLI$PRESENT('SYSTEM').AND. + & .NOT.BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' ERROR: /SYSTEM not allowed as remote node'', + & '' is not SYSTEM folder.'')') + RETURN + END IF + END IF + + LENDES = 0 + DO WHILE (LENDES.EQ.0) + IF (CLI$PRESENT('DESCRIPTION')) THEN ! DESCRIPTION specified? + IER = CLI$GET_VALUE('DESCRIPTION',FOLDER_DESCRIP,LENDES) + ELSE + WRITE (6,'('' Enter one line description of folder.'')') + CALL GET_LINE(FOLDER_DESCRIP,LENDES) ! Get input line + FOLDER_DESCRIP = FOLDER_DESCRIP(:LENDES) ! End fill with spaces + END IF + IF (LENDES.LE.0) THEN + WRITE (6,'('' Aborting folder creation.'')') + RETURN + ELSE IF (LENDES.GT.80) THEN ! If too many characters + WRITE(6,'('' ERROR: folder must be < 80 characters.'')') + LENDES = 0 + END IF + END DO + + CALL OPEN_BULLFOLDER ! Open folder file + READ (7,IOSTAT=IER,KEY=FOLDER,KEYID=0) + ! See if folder exists + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Specified folder already exists.'')') + GO TO 1000 + END IF + + IF (CLI$PRESENT('OWNER')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: /OWNER requires privileges.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner not valid username.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + FOLDER_OWNER = FOLDER1_OWNER + END IF + END IF + ELSE + FOLDER_OWNER = USERNAME ! Get present username + FOLDER1_OWNER = FOLDER_OWNER ! Save for later + END IF + + FOLDER_SET = .TRUE. + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + +C +C Folder file is placed in the directory FOLDER_DIRECTORY. +C The file prefix is the name of the folder. +C + + FD_LEN = TRIM(FOLDER_DIRECTORY) + IF (FD_LEN.EQ.0) THEN + WRITE (6,'('' ERROR: System programmer has disabled folders.'')') + GO TO 910 + ELSE + FOLDER_FILE = FOLDER_DIRECTORY(:FD_LEN)//FOLDER + END IF + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder directory file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='NEW', + 1 ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',IOSTAT=IER) + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder message file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + FOLDER_FLAG = 0 + + IF (CLI$PRESENT('PRIVATE').OR.CLI$PRESENT('SEMIPRIVATE')) THEN + ! Will folder have access limitations? + FOLDER1_FILE = FOLDER_FILE + CLOSE (UNIT=1) + CLOSE (UNIT=2) + IF (CLI$PRESENT('SEMIPRIVATE')) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER_OWNER,'R+W+C',IER) + OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLDIR',STATUS='OLD',IOSTAT=IER1) + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='OLD',IOSTAT=IER1) + IF (.NOT.IER) THEN + WRITE(6, + & '('' ERROR: Cannot create private folder using ACLs.'')') + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + + IER = 0 + LAST_NUMBER = 1 + DO WHILE (IER.EQ.0.AND.LAST_NUMBER.LT.FOLDER_MAX-1) + READ (7,IOSTAT=IER,KEY=LAST_NUMBER,KEYID=1) + LAST_NUMBER = LAST_NUMBER + 1 + END DO + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder limit of '',I,'' has been reached.'')') + & FOLDER_MAX + WRITE (6,'('' Unable to add specified folder.'')') + GO TO 910 + ELSE + FOLDER1_NUMBER = LAST_NUMBER - 1 + END IF + + IF (.NOT.CLI$PRESENT('NODE')) THEN + FOLDER_BBOARD = 'NONE' + IF (REMOTE_SET) CLOSE (UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + FOLDER_BBEXPIRE = 14 + F_NBULL = 0 + NBULL = 0 + F_NEWEST_BTIM(1) = 0 + F_NEWEST_BTIM(2) = 0 + F_NEWEST_NOSYS_BTIM(1) = 0 + F_NEWEST_NOSYS_BTIM(2) = 0 + F_EXPIRE_LIMIT = 0 + FOLDER_NUMBER = FOLDER1_NUMBER + ELSE + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + IF (FOLDER1.NE.FOLDER) THEN ! Different remote folder name? + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! If so, store name in directory file + BULLDIR_HEADER(13:) = FOLDER1 + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:LEN_B+2)//'*' + FOLDER1 = FOLDER + END IF + REMOTE_SET = .TRUE. + IF (BTEST(FOLDER1_FLAG,0)) FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + FOLDER1_FLAG = FOLDER_FLAG + FOLDER1_DESCRIP = FOLDER_DESCRIP + FOLDER_COM = FOLDER1_COM + NBULL = F_NBULL + END IF + + FOLDER_OWNER = FOLDER1_OWNER + + IF (CLI$PRESENT('SYSTEM')) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + END IF + + CALL WRITE_FOLDER_FILE(IER) + CALL MODIFY_SYSTEM_LIST(0) + + CLOSE (UNIT=1) + CLOSE (UNIT=2) + + NOTIFY = 0 + READNEW = 0 + BRIEF = 0 + IF (CLI$PRESENT('NOTIFY')) NOTIFY = 1 + IF (CLI$PRESENT('READNEW')) READNEW = 1 + IF (CLI$PRESENT('SHOWNEW')) BRIEF = 1 + IF (CLI$PRESENT('BRIEF')) THEN + BRIEF = 1 + READNEW = 1 + END IF + CALL SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) + + WRITE (6,'('' Folder is now set to '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + + GO TO 1000 + +910 WRITE (6,'('' Aborting folder creation.'')') + IF (FOLDER_NUMBER.EQ.0) FOLDER_SET = .FALSE. + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + +1000 CALL CLOSE_BULLFOLDER + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + diff --git a/decus/lt89b1/bulletin/bulletin5.for b/decus/lt89b1/bulletin/bulletin5.for new file mode 100644 index 0000000..212e3fa --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin5.for @@ -0,0 +1,1606 @@ +C +C BULLETIN5.FOR, Version 10/24/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) +C +C SUBROUTINE SET_FOLDER_DEFAULT +C +C FUNCTION: Sets flag defaults for specified folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL CLI$_NEGATED + + IF (.NOT.SETPRV_PRIV().AND.INCMD(:3).EQ.'SET') THEN + WRITE (6,'( + & '' ERROR: No privs to change all defaults.'')') + RETURN + END IF + + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_HEADER(IER) + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + REWRITE(4) USER_HEADER + + FLAG = 0 + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',TEMP_USER) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',TEMP_USER) + END IF + READ (TEMP_USER(:1),'(I1)',IOSTAT=IER) FLAG + + IF (NOTIFY.EQ.1.AND.BTEST(FLAG,1).AND. + & CLI$PRESENT('CLUSTER').EQ.%LOC(CLI$_NEGATED)) THEN + CALL OPEN_BULLNOTIFY + READ (10,KEY='*',IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=10) + FLAG = -1 + END IF + + IF (BRIEF.NE.-1.AND.NOTIFY.NE.-1.AND.READNEW.NE.-1) THEN + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + IF (TEMP_USER(:1).NE.'*'.AND.TEMP_USER(:1).NE.':') THEN + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG,FOLDER_NUMBER) + REWRITE(4) TEMP_USER//USER_ENTRY(13:) + IF (FLAG.EQ.-1) WRITE (10,IOSTAT=IER) TEMP_USER + END IF + CALL READ_USER_FILE(IER) + END DO + END IF + + IF (FLAG.EQ.-1) THEN + CALL CLOSE_BULLNOTIFY + ELSE IF (NOTIFY.EQ.1.AND.BTEST(FLAG,1).AND. + & CLI$PRESENT('CLUSTER').NE.%LOC(CLI$_NEGATED)) THEN + WRITE (6,'('' NOTE: In a cluster, /ALL or /DEFAULT '', + & ''causes all users to be notified.'')') + WRITE (6,'('' They will not be able to disable this.'', + & '' See HELP SET NOTIFY for more info.'')') + CALL OPEN_BULLNOTIFY + CALL CLOSE_BULLNOTIFY_DELETE + CALL OPEN_BULLNOTIFY + WRITE (10) '* ' + CALL CLOSE_BULLNOTIFY + ELSE IF (NOTIFY.EQ.0.AND.BTEST(FLAG,1)) THEN + CALL OPEN_BULLNOTIFY + READ (10,IOSTAT=IER) TEMP_USER + IF ((IER.EQ.0.AND.TEMP_USER.EQ.'*').OR. + & (BRIEF.NE.-1.AND.READNEW.NE.-1)) THEN + CALL CLOSE_BULLNOTIFY_DELETE + ELSE + CALL CLOSE_BULLNOTIFY + END IF + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + SUBROUTINE REMOVE_FOLDER +C +C SUBROUTINE REMOVE_FOLDER +C +C FUNCTION: Removes a bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,TEMP*80 + + IER = CLI$GET_VALUE('REMOVE_FOLDER',FOLDER1,LEN_T) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + IF (.NOT.FOLDER_SET) THEN + WRITE (6,'('' ERROR: No folder specified.'')') + RETURN + ELSE + FOLDER1 = FOLDER + END IF + ELSE IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Are you sure you want to remove folder ' + & //FOLDER1(:TRIM(FOLDER1))//' (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not removed.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if folder exists + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + GO TO 1000 + END IF + + IF ((FOLDER1_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()).OR. + & FOLDER1_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: You are not able to remove the folder.'')') + GO TO 1000 + END IF + + TEMP = FOLDER_FILE + FOLDER_FILE = FOLDER1_FILE + + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER1_FLAG,2)) THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) FLEN = FLEN - 1 + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER1_BBOARD(3:FLEN) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Deregister remote SYSTEM folder + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + IF (IER.EQ.1) FOLDER1 = BULLDIR_HEADER(13:) + CALL CLOSE_BULLDIR + END IF + WRITE (17,'(2A)',IOSTAT=IER) 1,FOLDER1 ! Select folder + IF (IER.EQ.0) READ(17,'(5A)',IOSTAT=IER) ! Throw away response + IF (IER.EQ.0) WRITE(17,'(2A)',IOSTAT=IER) 14,0 ! Deregister + CLOSE (UNIT=17) + END IF + END IF + + TEMPSET = FOLDER_SET + FOLDER_SET = .TRUE. + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + ! in case files don't exist and are created. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL OPEN_BULLNOTIFY + CALL CLOSE_BULLNOTIFY_DELETE + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + FOLDER_FILE = TEMP + FOLDER_SET = TEMPSET + + DELETE (7) + + TEMP_NUMBER = FOLDER_NUMBER + FOLDER_NUMBER = FOLDER1_NUMBER + CALL SET_FOLDER_DEFAULT(0,0,0) + FOLDER_NUMBER = TEMP_NUMBER + + WRITE (6,'('' Folder removed.'')') + + IF (FOLDER.EQ.FOLDER1) THEN + FOLDER_SET = .FALSE. + ELSE + REMOTE_SET = REMOTE_SET_SAVE + END IF + +1000 CALL CLOSE_BULLFOLDER + + RETURN + + END + + + SUBROUTINE SELECT_FOLDER(OUTPUT,IER) +C +C SUBROUTINE SELECT_FOLDER +C +C FUNCTION: Selects the specified folder. +C +C INPUTS: +C OUTPUT - Specifies whether status messages are outputted. +C +C NOTES: +C FOLDER_NUMBER is used for selecting the folder. +C If FOLDER_NUMBER = -1, the name stored in FOLDER1 is used. +C If FOLDER_NUMBER = -2, the name stored in FOLDER1 is used, +C but the folder is not selected if it is remote. +C If the specified folder is on a remote node and does not have +C a local entry (i.e. specified via NODENAME::FOLDERNAME), then +C FOLDER_NUMBER is set to -1. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + INCLUDE '($SSDEF)' + + COMMON /POINT/ BULL_POINT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /TAGS/ BULL_TAG,READ_TAG + + EXTERNAL CLI$_ABSENT + + CHARACTER*80 LOCAL_FOLDER1_DESCRIP + + DIMENSION FIRST_TIME(FLONG) ! Bit set for folder if folder has + DATA FIRST_TIME /FLONG*0/ ! been selected before this. + + COMMAND = (INCMD(:3).EQ.'ADD').OR.(INCMD(:3).EQ.'DEL').OR. + & (INCMD(:3).EQ.'DIR').OR.(INCMD(:3).EQ.'IND').OR. + & (INCMD(:3).EQ.'REP').OR.(INCMD(:3).EQ.'SEL').OR. + & (INCMD(:3).EQ.'SET') + + IF (.NOT.OUTPUT.OR.FOLDER_NUMBER.NE.-1.OR.COMMAND) THEN + IF (OUTPUT) THEN ! Get folder name + IER = CLI$GET_VALUE('SELECT_FOLDER',FOLDER1) + END IF + + FLEN = TRIM(FOLDER1) ! Add GENERAL after :: if no + IF (FLEN.GT.1) THEN ! name specified after the :: + IF (FOLDER1(FLEN-1:FLEN).EQ.'::') THEN + FOLDER1 = FOLDER1(:FLEN)//'GENERAL' + END IF + END IF + + IF (((IER.EQ.%LOC(CLI$_ABSENT).OR.FOLDER1.EQ.'GENERAL').AND. + & OUTPUT).OR.((FOLDER_NUMBER.EQ.0.OR.(FOLDER1.EQ.'GENERAL'.AND. + & FOLDER_NUMBER.LE.-1)).AND..NOT.OUTPUT)) THEN ! Select GENERAL + FOLDER_NUMBER = 0 + FOLDER1 = 'GENERAL' + END IF + END IF + + CALL OPEN_BULLFOLDER_SHARED ! Go find folder + + REMOTE_TEST = 0 + + IF (OUTPUT.OR.FOLDER_NUMBER.LE.-1) THEN + REMOTE_TEST = INDEX(FOLDER1,'::') + IF (REMOTE_TEST.GT.0) THEN + FOLDER1_BBOARD = '::'//FOLDER1(:REMOTE_TEST-1) + FOLDER1 = FOLDER1(REMOTE_TEST+2:TRIM(FOLDER1)) + FOLDER1_NUMBER = -1 + IER = 0 + ELSE IF (INCMD(:2).EQ.'SE') THEN + CALL READ_FOLDER_FILE_KEYNAME_TEMP + & (FOLDER1(:TRIM(FOLDER1)),IER) + ELSE + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + END IF + ELSE + FOLDER1_NUMBER = FOLDER_NUMBER + CALL READ_FOLDER_FILE_KEYNUM_TEMP(FOLDER_NUMBER,IER) + END IF + + IF (BTEST(FOLDER1_FLAG,29)) THEN ! Error in folder flag!! + FOLDER1_FLAG = FOLDER1_FLAG.AND.3 + F1_EXPIRE_LIMIT = 0 + CALL REWRITE_FOLDER_FILE_TEMP + END IF + + CALL CLOSE_BULLFOLDER + + IF (IER.EQ.0.AND.FOLDER1_BBOARD(:2).EQ.'::') THEN + IF (FOLDER_NUMBER.EQ.-2) RETURN ! Don't allow + LOCAL_FOLDER1_FLAG = FOLDER1_FLAG + LOCAL_FOLDER1_DESCRIP = FOLDER1_DESCRIP + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + IF (OUTPUT) THEN + WRITE (6,'('' ERROR: Unable select the folder.'')') + WRITE (6,'('' Cannot connect to node '',A,''.'')') + & FOLDER1_BBOARD(3:TRIM(FOLDER1_BBOARD)) + END IF + RETURN + END IF + IF (REMOTE_TEST.GT.0) THEN ! Folder specified with "::" + FOLDER1 = FOLDER1_BBOARD(3:TRIM(FOLDER1_BBOARD))//'::'// + & FOLDER1 + FOLDER1_NUMBER = -1 + ELSE ! True remote folder + FOLDER1_DESCRIP = LOCAL_FOLDER1_DESCRIP ! Use local description + IF (BTEST(FOLDER1_FLAG,0)) THEN ! Copy remote folder protection + LOCAL_FOLDER1_FLAG = IBSET(LOCAL_FOLDER1_FLAG,0) + ELSE + LOCAL_FOLDER1_FLAG = IBCLR(LOCAL_FOLDER1_FLAG,0) + END IF + FOLDER1_FLAG = LOCAL_FOLDER1_FLAG ! Use local flag info + CALL OPEN_BULLFOLDER ! Update local folder information + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + FOLDER_COM = FOLDER1_COM + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + END IF + REMOTE_SET = .TRUE. + END IF + + IF (IER.EQ.0) THEN ! Folder found + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + IF (BTEST(FOLDER1_FLAG,0).AND.FOLDER1_BBOARD(:2).NE.'::' + & .AND..NOT.SETPRV_PRIV()) THEN + ! Is folder protected and not remote? + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER1_OWNER) THEN + IF (SETPRV_PRIV()) THEN + READ_ACCESS = 1 + WRITE_ACCESS = 1 + ELSE + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + END IF + IF (.NOT.READ_ACCESS.AND..NOT.WRITE_ACCESS) THEN + IF (OUTPUT) THEN + WRITE(6,'('' You are not allowed to access folder.'')') + WRITE(6,'('' See '',A,'' if you wish to access folder.'')') + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + ELSE IF (TEST2(BRIEF_FLAG,FOLDER1_NUMBER).OR. + & TEST2(SET_FLAG,FOLDER1_NUMBER)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER1_NUMBER) + CALL CLR2(SET_FLAG,FOLDER1_NUMBER) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + IER = 0 + RETURN + END IF + ELSE IF (BTEST(FOLDER1_FLAG,0).AND. + & IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER1) + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + ELSE ! Folder not protected + IER = SS$_ACLEMPTY.OR.SS$_NORMAL ! Indicate folder selected + END IF + + IF (FOLDER1_BBOARD(:2).NE.'::') THEN + IF (REMOTE_SET) CLOSE(UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + END IF + + IF (IER) THEN + FOLDER_COM = FOLDER1_COM ! Folder successfully set so + FOLDER_FILE = FOLDER1_FILE ! update folder parameters + + IF (FOLDER_NUMBER.NE.0) THEN + FOLDER_SET = .TRUE. + ELSE + FOLDER_SET = .FALSE. + END IF + + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + WRITE (6,'('' Folder has been set to '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + BULL_POINT = 0 ! Reset pointer to first bulletin + END IF + + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER_OWNER) THEN + IF (.NOT.WRITE_ACCESS) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') + & WRITE (6,'('' Folder only accessible for reading.'')') + READ_ONLY = .TRUE. + ELSE + READ_ONLY = .FALSE. + END IF + ELSE + READ_ONLY = .FALSE. + END IF + + IF (FOLDER_NUMBER.GT.0) THEN + IF (TEST_BULLCP()) THEN + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + ELSE IF (.NOT.TEST2(FIRST_TIME,FOLDER_NUMBER)) THEN + ! If first select, look for expired messages. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) ! Get header info from BULLDIR.DAT + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired? + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)) + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown bulletins exist? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER.GT.20*356.OR.IER1.LE.0) THEN + CALL UPDATE ! Need to update + END IF + ELSE + NBULL = 0 + END IF + CALL CLOSE_BULLDIR + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + END IF + END IF + + IF (OUTPUT) THEN + IF (FOLDER_NUMBER.GE.0.AND.CLI$PRESENT('MARKED')) THEN + READ_TAG = .TRUE. + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + IF (INCMD(:3).NE.'DIR') THEN + IF (IER.EQ.0) THEN + WRITE(6,'('' NOTE: Only marked messages'', + & '' will be shown.'')') + ELSE + WRITE(6,'('' ERROR: No marked messages found.'')') + END IF + END IF + ELSE + READ_TAG = .FALSE. + END IF + END IF + + IF (FOLDER_NUMBER.NE.0.AND..NOT.READ_TAG) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN ! If new unread messages + CALL FIND_NEWEST_BULL ! See if we can find it + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + END IF + END IF + END IF + END IF + IER = 1 + ELSE IF (OUTPUT) THEN + WRITE (6,'('' Cannot access specified folder.'')') + CALL SYS_GETMSG(IER) + END IF + ELSE ! Folder not found + IF (OUTPUT) WRITE (6,'('' ERROR: Folder does not exist.'')') + IER = 0 + END IF + + RETURN + + END + + + + SUBROUTINE CONNECT_REMOTE_FOLDER(READ_ONLY,IER) +C +C SUBROUTINE CONNECT_REMOTE_FOLDER +C +C FUNCTION: Connects to folder that is located on other DECNET node. +C + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_UNIT /15/ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*12 FOLDER_BBOARD_SAVE,FOLDER_OWNER_SAVE + CHARACTER*25 FOLDER_SAVE + + DIMENSION DUMMY(2) + + REMOTE_UNIT = 31 - REMOTE_UNIT + + SAME = .TRUE. + LEN_BBOARD = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN ! Remote folder name different + SAME = .FALSE. ! from local? Yes. + LEN_BBOARD = LEN_BBOARD - 1 + END IF + + OPEN (UNIT=REMOTE_UNIT,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=FOLDER1_BBOARD(3:LEN_BBOARD)//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IF (.NOT.SAME) THEN + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + FOLDER_FILE = FOLDER1_FILE + FOLDER_SAVE = FOLDER1 + FOLDER1 = BULLDIR_HEADER(13:) + END IF + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 1,FOLDER1 + FOLDER_OWNER_SAVE = FOLDER1_OWNER + FOLDER_BBOARD_SAVE = FOLDER1_BBOARD + FOLDER_NUMBER_SAVE = FOLDER1_NUMBER + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(5A)',IOSTAT=IER)IER1,READ_ONLY, + & DUMMY(1),DUMMY(2),FOLDER1_COM + END IF + IF (.NOT.SAME) FOLDER1 = FOLDER_SAVE + END IF + + IF (IER.NE.0.OR..NOT.IER1) THEN + CLOSE (UNIT=REMOTE_UNIT) + REMOTE_UNIT = 31 - REMOTE_UNIT + IF (IER.EQ.0.AND.FOLDER_NUMBER_SAVE.GE.0) THEN + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + & .OR.TEST2(SET_FLAG,FOLDER_NUMBER_SAVE)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + CALL CLR2(SET_FLAG,FOLDER_NUMBER_SAVE) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + END IF + IER = 2 + ELSE + FOLDER1_BBOARD = FOLDER_BBOARD_SAVE + FOLDER1_NUMBER = FOLDER_NUMBER_SAVE + FOLDER1_OWNER = FOLDER_OWNER_SAVE + CLOSE (UNIT=31-REMOTE_UNIT) +C +C If remote folder has returned a last read time for the folder, +C and if in /LOGIN mode, or last selected folder was a different +C folder, or folder specified with "::", then update last read time. +C + IF (((FOLDER_NUMBER.NE.FOLDER1_NUMBER.OR.LOGIN_SWITCH) + & .AND.(DUMMY(1).NE.0.OR.DUMMY(2).NE.0)) + & .OR.FOLDER1_NUMBER.EQ.-1) THEN + LAST_READ_BTIM(1,FOLDER1_NUMBER+1) = DUMMY(1) + LAST_READ_BTIM(2,FOLDER1_NUMBER+1) = DUMMY(2) + END IF + IER = 0 + END IF + + RETURN + END + + + + + + + + + + SUBROUTINE UPDATE_FOLDER +C +C SUBROUTINE UPDATE_FOLDER +C +C FUNCTION: Updates folder info due to new message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (FOLDER_NUMBER.LT.0) RETURN + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + + F_NBULL = NBULL + + IF (FOLDER_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + + IF (.NOT.BTEST(SYSTEM,0)) THEN ! Is non-system message? + F_NEWEST_NOSYS_BTIM(1) = F_NEWEST_BTIM(1) ! If so, update latest + F_NEWEST_NOSYS_BTIM(2) = F_NEWEST_BTIM(2) ! system time. + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + SUBROUTINE SHOW_FOLDER +C +C SUBROUTINE SHOW_FOLDER +C +C FUNCTION: Shows the information on any folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + INCLUDE '($SSDEF)' + + INCLUDE '($RMSDEF)' + + EXTERNAL CLI$_ABSENT + + IF (INDEX(INCMD,'/A').GT.0.OR.INDEX(INCMD,'/a').GT.0) THEN + WRITE (6,'('' ERROR: /ALL is invalid qualifier.'')') + RETURN + END IF + + IF (CLI$GET_VALUE('SHOW_FOLDER',FOLDER1).EQ.%LOC(CLI$_ABSENT)) + & FOLDER1 = FOLDER + + IF (INDEX(FOLDER1,'::').NE.0) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Specified folder was not found.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (FOLDER.EQ.FOLDER1) THEN + WRITE (6,1000) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + ELSE + WRITE (6,1010) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + END IF + + IF (CLI$PRESENT('FULL')) THEN + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL).OR.(.NOT.IER)) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND. ! Is folder remote + & BTEST(FOLDER1_FLAG,0)) THEN ! and private? + WRITE (6,'('' Folder is a private folder.'')') + ELSE + WRITE (6,'('' Folder is not a private folder.'')') + END IF + ELSE + IF (SETPRV_PRIV()) THEN + READ_ACCESS = 1 + WRITE_ACCESS = 1 + ELSE + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + END IF + IF (WRITE_ACCESS) + & CALL SHOWACL(FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL') + END IF + IF (SETPRV_PRIV().OR.USERNAME.EQ.FOLDER1_OWNER) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').EQ.0) THEN + WRITE (6,'('' Folder is located on node '', + & A,''.'')') FOLDER1_BBOARD(3:FLEN) + ELSE + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + WRITE (6,'('' Folder is located on node '', + & A,''. Remote folder name is '',A,''.'')') + & FOLDER1_BBOARD(3:FLEN-1), + & BULLDIR_HEADER(13:TRIM(BULLDIR_HEADER)) + END IF + ELSE IF (FOLDER1_BBOARD.NE.'NONE') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (FLEN.GT.0) THEN + WRITE (6,'('' BBOARD for folder is '',A,''.'')') + & FOLDER1_BBOARD(:FLEN) + END IF + IF ((USERB1.EQ.0.AND.GROUPB1.EQ.0).OR.BTEST(USERB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /SPECIAL.'')') + IF (BTEST(GROUPB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /VMSMAIL.'')') + END IF + END IF + ELSE + WRITE (6,'('' No BBOARD has been defined.'')') + END IF + IF (FOLDER1_BBEXPIRE.GT.0) THEN + WRITE (6,'('' Default expiration is '',I3,'' days.'')') + & FOLDER1_BBEXPIRE + ELSE IF (FOLDER1_BBEXPIRE.EQ.-1) THEN + WRITE (6,'('' Default expiration is permanent.'')') + ELSE + WRITE (6,'('' No default expiration set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' SYSTEM has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,1)) THEN + WRITE (6,'('' DUMP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,3)) THEN + WRITE (6,'('' NOPROMPT_EXPIRE has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,4)) THEN + WRITE (6,'('' STRIP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,5)) THEN + WRITE (6,'('' DIGEST has been set.'')') + END IF + IF (F1_EXPIRE_LIMIT.GT.0) THEN + WRITE (6,'('' EXPIRATION limit is '',I3,'' days.'')') + & F1_EXPIRE_LIMIT + END IF + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_HEADER(IER) + IF (TEST2(SET_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is BRIEF.'')') + ELSE + WRITE (6,'('' Default is READNEW.'')') + END IF + ELSE + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is SHOWNEW.'')') + ELSE + WRITE (6,'('' Default is NOREADNEW.'')') + END IF + END IF + IF (TEST2(NOTIFY_FLAG_DEF,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is NOTIFY.'')') + ELSE + WRITE (6,'('' Default is NONOTIFY.'')') + END IF + CALL CLOSE_BULLUSER + END IF + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + +1000 FORMAT(' Current folder is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) +1010 FORMAT(' Folder name is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) + END + + + SUBROUTINE DIRECTORY_FOLDERS(FOLDER_COUNT) +C +C SUBROUTINE DIRECTORY_FOLDERS +C +C FUNCTION: Display all FOLDER entries. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + DATA SCRATCH_D1/0/ + + CHARACTER*17 DATETIME + + IF (FOLDER_COUNT.GT.0) GO TO 50 ! Skip init steps if this is + ! not the 1st page of folder + + IF (CLI$PRESENT('DESCRIBE')) THEN + NLINE = 2 ! Include folder descriptor if /DESCRIBE specified + ELSE + NLINE = 1 + END IF + +C +C Folder listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C folder file, and to avoid the possibility of the user holding the screen, +C and thus causing the folder file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + CALL INIT_QUEUE(SCRATCH_D1,FOLDER1_COM) + SCRATCH_D = SCRATCH_D1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDER = 0 + IER = 0 + FOLDER1 = ' ' ! Start folder search + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0) THEN + IF (BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + NUM_FOLDER = NUM_FOLDER + 1 + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + IF (NUM_FOLDER.EQ.0) THEN + WRITE (6,'('' There are no folders.'')') + RETURN + END IF + +C +C Folder entries are now in queue. Output queue entries to screen. +C + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + + FOLDER_COUNT = 1 ! Init folder number counter + +50 CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + WRITE (6,'(1X,''Folder'',22X,''Last message'',7X,''Messages'', + & 2X,''Owner'',/,1X,80(''-''))') + + IF (.NOT.PAGING) THEN + DISPLAY = (NUM_FOLDER-FOLDER_COUNT+1)*NLINE+2 + ELSE + DISPLAY = MIN((NUM_FOLDER-FOLDER_COUNT+1)*NLINE+2,PAGE_LENGTH-4) + ! If more entries than page size, truncate output + END IF + + DO I=FOLDER_COUNT,FOLDER_COUNT+(DISPLAY-2)/NLINE-1 + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + DIFF = COMPARE_BTIM + & (LAST_READ_BTIM(1,FOLDER1_NUMBER+1),F1_NEWEST_BTIM) + IF (F1_NBULL.GT.0) THEN + CALL SYS$ASCTIM(,DATETIME,F1_NEWEST_BTIM,) + ELSE + DATETIME = ' NONE' + END IF + IF (DIFF.GE.0.OR.F1_NBULL.EQ.0) THEN + WRITE (6,1000) ' '//FOLDER1,DATETIME,F1_NBULL,FOLDER1_OWNER + ELSE + WRITE (6,1000) '*'//FOLDER1,DATETIME,F1_NBULL,FOLDER1_OWNER + END IF + IF (NLINE.EQ.2) WRITE (6,'(1X,A)') FOLDER1_DESCRIP + FOLDER_COUNT = FOLDER_COUNT + 1 ! Update folder counter + END DO + + IF (FOLDER_COUNT.GT.NUM_FOLDER) THEN ! Outputted all entries? + FOLDER_COUNT = 0 ! Yes. Set counter to 0. + ELSE + WRITE(6,1010) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(1X,A26,2X,A17,2X,I8,2X,A12) +1010 FORMAT(1X,/,' Press RETURN for more...',/) + + END + + + SUBROUTINE SET_ACCESS(ACCESS) +C +C SUBROUTINE SET_ACCESS +C +C FUNCTION: Set access on folder for specified ID. +C +C PARAMETERS: +C ACCESS - Logical: If .true., grant access, if .false. deny access +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + LOGICAL ACCESS,ALL,READONLY + + EXTERNAL CLI$_ABSENT + + CHARACTER ID*64,RESPONSE*1 + + CHARACTER INPUT*132 + + IF (CLI$PRESENT('ALL')) THEN + ALL = .TRUE. + ELSE + ALL = .FALSE. + END IF + + IF (CLI$PRESENT('READONLY')) THEN + READONLY = .TRUE. + ELSE + READONLY = .FALSE. + END IF + + IER = CLI$GET_VALUE('ACCESS_FOLDER',FOLDER1,LEN) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + FOLDER1 = FOLDER + ELSE IF (LEN.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if it exists + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + ELSE IF (FOLDER1_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6, + & '('' ERROR: You are not able to modify access to the folder.'')') + ELSE + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + IF ((ALL.AND..NOT.READONLY).OR.(.NOT.ACCESS)) THEN + WRITE (6,'('' ERROR: Folder is not a private folder.'')') + RETURN + END IF + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Folder is not private. Do you want to make it so? (Y/N): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder access was not changed.'')') + RETURN + ELSE + FOLDER1_FLAG = IBSET(FOLDER1_FLAG,0) + IF (READONLY.AND.ALL) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + IF (ALL) THEN ! All finished, so exit + WRITE (6,'('' Access to folder has been modified.'')') + GOTO 100 + END IF + END IF + END IF + + IF (ALL) THEN + IF (ACCESS) THEN + CALL DEL_ACL(' ','R+W',IER) + IF (READONLY) THEN + CALL ADD_ACL('*','R',IER) + ELSE + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + END IF + ELSE + CALL DEL_ACL('*','R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access.'')') + CALL SYS_GETMSG(IER) + END IF + END IF + + DO WHILE (CLI$GET_VALUE('ACCESS_ID',INPUT,ILEN) + & .NE.%LOC(CLI$_ABSENT).AND..NOT.ALL) + IER = SYS_TRNLNM(INPUT,INPUT) + IF (INPUT(:1).EQ.'@') THEN + ILEN = INDEX(INPUT,',') - 1 + IF (ILEN.EQ.-1) ILEN = TRIM(INPUT) + OPEN (UNIT=3,STATUS='OLD',FILE=INPUT(2:ILEN), + & DEFAULTFILE='.DIS',IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Cannot find file '',A)') + & INPUT(2:ILEN) + RETURN + END IF + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + ELSE + FILE_OPEN = .TRUE. + END IF + ELSE + FILE_OPEN = .FALSE. + END IF + DO WHILE (TRIM(INPUT).GT.0) + COMMA = INDEX(INPUT,',') + IF (INPUT(:1).EQ.'[') COMMA = INDEX(INPUT,']') + 1 + IF (INPUT(:1).EQ.'"') COMMA = INDEX(INPUT(2:),'"') + 2 + IF (COMMA.GT.0) THEN + ID = INPUT(1:COMMA-1) + INPUT = INPUT(COMMA+1:) + ELSE + ID = INPUT + INPUT = ' ' + END IF + ILEN = TRIM(ID) + IF (ID.EQ.FOLDER1_OWNER) THEN + WRITE (6,'('' ERROR: Cannot modify access'', + & '' for owner of folder.'')') + ELSE + IF (ACCESS) THEN + IF (READONLY) THEN + CALL ADD_ACL(ID,'R',IER) + ELSE + CALL ADD_ACL(ID,'R+W',IER) + END IF + ELSE + CALL DEL_ACL(ID,'R+W',IER) + IF (.NOT.IER) CALL DEL_ACL(ID,'R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access for '',A, + & ''.'')') ID(:ILEN) + CALL SYS_GETMSG(IER) + ELSE + WRITE(6,'('' Access modified for '',A,''.'')') + & ID(:ILEN) + END IF + END IF + IF (TRIM(INPUT).EQ.0.AND.FILE_OPEN) THEN + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + FILE_OPEN = .FALSE. + END IF + END IF + END DO + END DO + +100 IF (OLD_FOLDER1_FLAG.NE.FOLDER1_FLAG) THEN + CALL OPEN_BULLFOLDER ! Open folder file + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FLAG = OLD_FOLDER1_FLAG + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + END IF + + RETURN + + END + + + + SUBROUTINE CHKACL(FILENAME,IERACL) +C +C SUBROUTINE CHKACL +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C IERACL - Error returned for attempt to open file. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) FILENAME + + INCLUDE '($ACLDEF)' + INCLUDE '($SSDEF)' + + CHARACTER*255 ACLENT,ACLSTR + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IERACL=SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + IF (IERACL.EQ.SS$_ACLEMPTY) THEN + IERACL = SS$_NORMAL.OR.IERACL + END IF + + RETURN + END + + + + SUBROUTINE CHECK_ACCESS(FILENAME,USERNAME,READ_ACCESS,WRITE_ACCESS) +C +C SUBROUTINE CHECK_ACCESS +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C USERNAME - Name of user to check access for. +C READ_ACCESS - Error returned indicating read access. +C WRITE_ACCESS - Error returned indicating write access. +C If initially set to -1, indicates just +C folder for read access. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER FILENAME*(*),USERNAME*(*),ACE*255,OUTPUT*80 + + INCLUDE '($ACLDEF)' + INCLUDE '($CHPDEF)' + INCLUDE '($ARMDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,CHP$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(4,CHP$_ACCESS,%LOC(ACCESS)) + CALL ADD_2_ITMLST(LEN(ACE),CHP$_MATCHEDACE,%LOC(ACE)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + FLAGS = 0 ! Default is no access + + ACCESS = ARM$M_READ ! Check if user has read access + READ_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + IF (.NOT.SETPRV_PRIV().AND.ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'READ').EQ.0) READ_ACCESS = 0 + ELSE IF (ICHAR(ACE(:1)).EQ.0.AND.READ_ACCESS) THEN + READ_ACCESS = 0 + END IF + + IF (WRITE_ACCESS.EQ.-1) THEN ! Only check read access + RETURN + ELSE IF (READ_ACCESS.EQ.0) THEN ! If no read access, then of + WRITE_ACCESS = 0 ! course there is no write access. + RETURN + END IF + + ACCESS = ARM$M_WRITE ! Check if user has write access + WRITE_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + IF (.NOT.SETPRV_PRIV().AND.ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'WRITE').EQ.0) WRITE_ACCESS = 0 + END IF + + RETURN + END + + + + + SUBROUTINE SHOWACL(FILENAME) +C +C SUBROUTINE SHOWACL +C +C FUNCTION: Shows users who are allowed to read private bulletin. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER*(*) FILENAME + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + CALL LIB$GET_VM(ACLLENGTH+8,ACLSTR) + CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) + + CALL READACL(FILENAME,%VAL(ACLSTR),ACLLENGTH) + + RETURN + END + + + + SUBROUTINE FOLDER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLFOLDER.INC' + + ENTRY WRITE_FOLDER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + WRITE (7,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + ENTRY REWRITE_FOLDER_FILE + + REWRITE (7) FOLDER_COM + + RETURN + + ENTRY REWRITE_FOLDER_FILE_TEMP + + REWRITE (7) FOLDER1_COM + + RETURN + + ENTRY READ_FOLDER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_TEMP(IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM(KEY_NUMBER,IER) + + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER_COM + END DO + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM_TEMP(KEY_NUMBER,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME_TEMP(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + END + + + SUBROUTINE USER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 SAVE_USERNAME + + ENTRY READ_USER_FILE(IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) USER_ENTRY + END DO + + TEMP_USER = USERNAME + USERNAME = SAVE_USERNAME + + RETURN + + ENTRY READ_USER_FILE_KEYNAME(KEY_NAME,IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=KEY_NAME,IOSTAT=IER) USER_ENTRY + END DO + + USERNAME = SAVE_USERNAME + TEMP_USER = KEY_NAME + + RETURN + + ENTRY READ_USER_FILE_HEADER(IER) + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=' ',IOSTAT=IER) USER_HEADER + END DO + + RETURN + + ENTRY WRITE_USER_FILE_NEW(IER) + + SET_FLAG(1) = SET_FLAG_DEF(1) + SET_FLAG(2) = SET_FLAG_DEF(2) + BRIEF_FLAG(1) = BRIEF_FLAG_DEF(1) + BRIEF_FLAG(2) = BRIEF_FLAG_DEF(2) + NOTIFY_FLAG(1) = NOTIFY_FLAG_DEF(1) + NOTIFY_FLAG(2) = NOTIFY_FLAG_DEF(2) + + ENTRY WRITE_USER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + WRITE (4,IOSTAT=IER) USER_ENTRY + END DO + + RETURN + + END + + + + + + SUBROUTINE SET_GENERIC(GENERIC) +C +C SUBROUTINE SET_GENERIC +C +C FUNCTION: Enables or disables "GENERIC" display, i.e. displaying +C general bulletins continually for a certain amount of days. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change GENERIC.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + IF (IER.EQ.0) THEN + IF (GENERIC) THEN + IF (CLI$PRESENT('DAYS')) THEN + IER = CLI$GET_VALUE('DAYS',BULL_PARAMETER) + CALL LIB$MOVC3(4,%REF(BULL_PARAMETER),NEW_FLAG(2)) + ELSE + NEW_FLAG(2) = ' 7' + END IF + ELSE + NEW_FLAG(2) = 0 + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET_LOGIN(LOGIN) +C +C SUBROUTINE SET_LOGIN +C +C FUNCTION: Enables or disables bulletin display at login. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER TODAY*23 + + DIMENSION NOLOGIN_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change LOGIN.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + IF (IER.EQ.0) THEN + IF (LOGIN.AND.COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + CALL SYS_BINTIM(TODAY,LOGIN_BTIM) + ELSE IF (.NOT.LOGIN) THEN + LOGIN_BTIM(1) = NOLOGIN_BTIM(1) + LOGIN_BTIM(2) = NOLOGIN_BTIM(2) + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE GET_UAF(USERNAME,USER,GROUP,ACCOUNT,FLAGS,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER USERNAME*(*),ACCOUNT*(*) + + INCLUDE '($UAIDEF)' + + INTEGER*2 UIC(2) + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(LEN(ACCOUNT),UAI$_ACCOUNT,%LOC(ACCOUNT)) + CALL ADD_2_ITMLST(4,UAI$_UIC,%LOC(UIC)) + CALL END_ITMLST(GETUAI_ITMLST) + + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) + + USER = UIC(1) + GROUP = UIC(2) + + RETURN + END + + + + SUBROUTINE DCLEXH(EXIT_ROUTINE) + + IMPLICIT INTEGER (A-Z) + + INTEGER*4 EXBLK(4) + + EXBLK(2) = EXIT_ROUTINE + EXBLK(3) = 1 + EXBLK(4) = %LOC(EXBLK(4)) + + CALL SYS$DCLEXH(EXBLK(1)) + + RETURN + END diff --git a/decus/lt89b1/bulletin/bulletin6.for b/decus/lt89b1/bulletin/bulletin6.for new file mode 100644 index 0000000..f567bff --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin6.for @@ -0,0 +1,1586 @@ +C +C BULLETIN6.FOR, Version 10/26/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE CLOSE_FILE +C +C SUBROUTINE CLOSE_FILE +C +C FUNCTION: To close out the bulletin files and enable CTRL-C & -Y +C + DATA LUN /0/ + + ENTRY CLOSE_BULLNOTIFY + LUN = LUN + 1 ! Unit = 10 + + ENTRY CLOSE_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY CLOSE_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY CLOSE_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY CLOSE_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY CLOSE_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN) + + LUN = 0 + + RETURN + END + + + SUBROUTINE CLOSE_FILE_DELETE + + IMPLICIT INTEGER (A-Z) + + DATA LUN /0/ + + ENTRY CLOSE_BULLNOTIFY_DELETE + LUN = LUN + 8 ! Unit = 10 + + ENTRY CLOSE_BULLDIR_DELETE + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL_DELETE + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN,STATUS='DELETE') + + LUN = 0 + + RETURN + END + + + SUBROUTINE OPEN_FILE(UNIT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($FORIOSDEF)' + + INCLUDE '($PRVDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + DATA LUN /0/ + + LUN = UNIT - 10 ! 10 gets added to LUN + + ENTRY OPEN_BULLNOTIFY + LUN = LUN + 1 ! Unit = 10 + + ENTRY OPEN_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL ! No breaks while file is open + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + WRITE (4,FMT=USER_FMT) USER_HEADER_KEY,NEWEST_BTIM, + & BBOARD_BTIM,PRV$M_OPER.OR.PRV$M_CMKRNL.OR. + & PRV$M_SETPRV,(0,I=1,FLONG*4-1) + CLOSE (UNIT=4) + IDUMMY = FILE_LOCK(IER,IER1) + ELSE IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + FOLDER1 = 'GENERAL' + FOLDER1_OWNER = 'SYSTEM' + FOLDER1_DESCRIP = 'Default general bulletin folder.' + FOLDER1_BBOARD = 'NONE' + FOLDER1_BBEXPIRE = 14 + NBULL = 0 + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER2, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + WRITE (7,FMT=FOLDER_FMT,IOSTAT=IER2) + & FOLDER1,0,FOLDER1_OWNER,FOLDER1_DESCRIP + & ,FOLDER1_BBOARD,FOLDER1_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,4,0,F_NEWEST_NOSYS_BTIM + ! 4 means system folder + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = 0 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.10) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=10,STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=3, + & ORGANIZATION='INDEXED',KEY=(1:12:CHARACTER), + & FORM='UNFORMATTED', + & FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.NOTIFY') + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (IER.NE.0) THEN + WRITE (6,'( + & '' Cannot open file in OPEN_FILE, unit = '',I)') LUN + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT ! Enable CTRL-Y & -C & EXIT + END IF + + LUN = 0 + + RETURN + END + + + + SUBROUTINE TIMER_ERR(UNIT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*14 NAMES(6) + DATA NAMES/'directory','message','BULLUSER.DAT','BULLFOLDER.DAT', + & 'BULLINF.DAT','notify'/ + INTEGER NAME(10) + DATA NAME/1,2,0,3,0,0,4,0,5,6/ + + IF (TEST_BULLCP().NE.2) THEN ! If BULLCP process, don't log error + WRITE(6,'('' ERROR: Unable to open '',A, + & '' file after 30 secs.'')') + & NAMES(NAME(UNIT))(:TRIM(NAMES(NAME(UNIT)))) + WRITE (6,'('' Please try again later.'')') + END IF + + CALL ENABLE_CTRL_EXIT ! No breaks while file is open + END + + + + SUBROUTINE OPEN_FILE_SHARED + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + EXTERNAL LNM_MODE_EXEC,ENABLE_CTRL_EXIT +C +C The following 2 files were used prior to V1.1. +C + CHARACTER*80 BULLDIR_FILE /'BULL_DIR:BULLDIR.DAT'/ + CHARACTER*80 BULLETIN_FILE /'BULL_DIR:BULLETIN.DAT'/ + + CHARACTER*25 SAVE_FOLDER + DATA SAVE_BLOCK/-1/ + + DATA LUN /0/ + + ENTRY OPEN_BULLNOTIFY_SHARED + LUN = LUN + 1 ! Unit = 10 + + ENTRY OPEN_BULLINF_SHARED + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF_SHARED + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER_SHARED + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER_SHARED + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR_SHARED + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL_SHARED + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.(FOLDER_NUMBER.EQ.0 + & .OR.FOLDER.EQ.'GENERAL')) THEN + IER2 = LIB$RENAME_FILE(BULLETIN_FILE,'GENERAL.BULLFIL') + IER2 = LIB$RENAME_FILE(BULLDIR_FILE,'GENERAL.BULLDIR') + IF (IER2) IDUMMY = FILE_LOCK(IER,IER1) ! Don't break out of loop + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND.REMOTE_SET.AND.(SAVE_BLOCK.NE.BLOCK.OR. + & SAVE_FOLDER.NE.FOLDER)) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,BULL_POINT + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + SAVE_BLOCK = BLOCK + SAVE_FOLDER = FOLDER + CALL GET_REMOTE_MESSAGE(IER) + IER = 0 + END IF + ELSE IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED',IOSTAT=IER,SHARED) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + + IF (IER.EQ.0) THEN + INQUIRE(UNIT=7,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.FOLDER_RECORD/4) THEN + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_BULLFOLDER(ASK_SIZE) + NTRIES = 0 + END IF + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.8) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=8,FILE='SYSUAF',DEFAULTFILE='SYS$SYSTEM:SYSUAF.DAT', + & ACCESS='KEYED',FORM='UNFORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,IOSTAT=IER,SHARED, + & USEROPEN=LNM_MODE_EXEC) + END DO + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.10) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=10,STATUS='OLD',IOSTAT=IER, + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=3, + & ORGANIZATION='INDEXED',KEY=(1:12:CHARACTER), + & FORM='UNFORMATTED', + & FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.NOTIFY') + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.LUN.NE.8) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + CALL OPEN_FILE(LUN) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + ELSE IF (IER.NE.0) THEN + WRITE (6,'( + & '' Cannot open file in OPEN_FILE_SHARE, unit = '',I)') LUN + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT + END IF + + LUN = 0 + + RETURN + END + + + + + + SUBROUTINE CONVERT_BULLDIRS + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER BUFFER*115 + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP', + & IOSTAT=IER) + + IF (IER.NE.0) GO TO 900 ! No BULLDIR file found. + + READ (2'1,IOSTAT=IER1) BUFFER + + CALL LIB$MOVC3(4,%REF(BUFFER(39:)),NBULL) + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+5 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END IF + + IF (IER1.NE.0) GO TO 800 + + CALL SYS_BINTIM(BUFFER(1:11)//' '//BUFFER(12:19),NEWEST_EXBTIM) + CALL SYS_BINTIM(BUFFER(20:30)//' '//BUFFER(31:38),NEWEST_MSGBTIM) + BULLDIR_HEADER(29:40) = BUFFER(39:) + CALL SYS_BINTIM(BUFFER(51:61)//' '//BUFFER(62:69),SHUTDOWN_BTIM) + BULLDIR_HEADER(49:52) = BUFFER(70:) + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) BULLDIR_HEADER + + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ (2'ICOUNT,IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + MSG_NUM = ICOUNT - 1 + DESCRIP = BUFFER(1:) + FROM = BUFFER(54:) + BULLDIR_ENTRY(78:81) = BUFFER(85:) + BULLDIR_ENTRY(90:97) = BUFFER(108:) + CALL SYS_BINTIM(BUFFER(89:99)//' '//BUFFER(100:107),EX_BTIM) + CALL SYS_BINTIM(BUFFER(66:76)//' '//BUFFER(77:84),MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (9,IOSTAT=IER) BULLDIR_ENTRY + ICOUNT = ICOUNT + 1 + END IF + END DO + +800 CLOSE (UNIT=9,DISPOSE='KEEP') + CLOSE (UNIT=2) + +900 CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFILES +C +C SUBROUTINE CONVERT_BULLFILES +C +C FUNCTION: Converts bulletin files to new format file. +C Add expiration time to directory file, add extra byte to bulletin +C file to show where each bulletin starts (for redunancy sake in +C case crash occurs). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*81 BUFFER + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=107,ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP',FORM='FORMATTED', + & SHARED,READONLY,IOSTAT=IER) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=10,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=80, + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=81, + & FORM='FORMATTED') + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + NEWEST_EXTIME = '00:00:00.00' + READ (9'1,1000,IOSTAT=IER) + & NEWEST_EXDATE,NEWEST_DATE,NEWEST_TIME(:8), + & NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_DATE,SHUTDOWN_TIME(:8) + NEMPTY = 0 + IF (IER.EQ.0) CALL WRITEDIR(0,IER1) + + EXTIME = '00:00:00.00' + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ(9'ICOUNT,1010,IOSTAT=IER) + & DESCRIP,FROM,DATE,TIME(:8),LENGTH,EXDATE,SYSTEM,BLOCK + IF (IER.EQ.0) THEN + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER(1:80)//CHAR(1) + DO I=2,LENGTH + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER + END DO + CALL WRITEDIR(ICOUNT-1,IER1) + ICOUNT = ICOUNT + 1 + END IF + END DO + + CLOSE (UNIT=9) + CLOSE (UNIT=2) + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + RETURN + +1000 FORMAT(A11,A11,A8,A4,A4,A4,A11,A8) +1010 FORMAT(A53,A12,A11,A8,A4,A11,A4,A4) + + END + + SUBROUTINE CONVERT_BULLFILE +C +C SUBROUTINE CONVERT_BULLFILE +C +C FUNCTION: Converts bulletin data file to new format file. +C +C NOTE: CONVERT_BULLFILES converts from 80 to 81 byte length. +C This converts from 81 byte length to 128 compressed format. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*80 BUFFER,NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL CLOSE_BULLDIR + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + CALL OPEN_BULLFOLDER + +100 READ (7,FMT=FOLDER_FMT,ERR=200) + & FOLDER,FOLDER_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + NEW_FILE = FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFILOLD' + OPEN (UNIT=10,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL' + & ,STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=81,ACCESS='DIRECT', + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.BULLFIL;-1',NEW_FILE) + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + IF (IER.EQ.1) THEN + NBLOCK = 0 + DO I=1,NBULL + CALL READDIR(I,IER) + NBLOCK = NBLOCK + 1 + SBLOCK = NBLOCK + DO J=BLOCK,LENGTH+BLOCK-1 + READ(10'J,'(A)') BUFFER + ILEN = TRIM(BUFFER) + IF (ILEN.EQ.0) ILEN = 1 + CALL STORE_BULL(ILEN,BUFFER,NBLOCK) + END DO + CALL FLUSH_BULL(NBLOCK) + LENGTH = NBLOCK - SBLOCK + 1 + BLOCK = SBLOCK + CALL WRITEDIR(I,IER) + END DO + + NEMPTY = 0 + CALL WRITEDIR(0,IER) + END IF + + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL CLOSE_BULLDIR + GOTO 100 + +200 CALL OPEN_BULLDIR_SHARED + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFOLDER(ASK_SIZE) +C +C SUBROUTINE CONVERT_BULLFOLDER +C +C FUNCTION: Converts bulletin folder file to new format. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + INCLUDE '($FORIOSDEF)' + + CHARACTER*80 NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + + EODIR = MAX(INDEX(BULLFOLDER_FILE,':'),INDEX(BULLFOLDER_FILE,']')) + SUFFIX = INDEX(BULLFOLDER_FILE(EODIR:),'.') + EODIR - 1 + NEW_FILE = BULLFOLDER_FILE(:SUFFIX)//'OLD' + + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + END DO + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=19,FILE=NEW_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER),DISPOSE='DELETE') + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + IF (ASK_SIZE.EQ.173/4) THEN + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8,5A4)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + IF (IER.EQ.0) THEN + WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + & ,F_NEWEST_BTIM + F_NUMBER = F_NUMBER + 1 + END IF + END DO + ELSE + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + IF (IER.EQ.0) THEN + FOLDER_FLAG = 0 + IF (F_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_BULLDIRS + END IF + END DO + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + F_NEWEST_BTIM(1) = 0 + F_NEWEST_BTIM(2) = 0 + ELSE + CALL READDIR(0,IER) + IF (NEWEST_DATE.EQ.'5-NOV-1956 ') THEN + IF (NBULL.GT.0) THEN + CALL READDIR(NBULL,IER) + NEWEST_DATE = DATE + NEWEST_TIME = TIME + CALL WRITEDIR(0,IER) + END IF + END IF + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + CLOSE (UNIT=2) + END IF + WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,FOLDER_FLAG,0,F_NEWEST_BTIM + F_NUMBER = F_NUMBER + 1 + END IF + END DO + END IF + + CLOSE (UNIT=7) + CLOSE (UNIT=19,STATUS='SAVE') + + IER = LIB$RENAME_FILE(NEW_FILE,BULLFOLDER_FILE) + IER = LIB$RENAME_FILE(BULLFOLDER_FILE//';-1',NEW_FILE) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:TRIM(BBOARD_DIRECTORY)) + & //'BOARD.COM;*') ! BULLETIN$ is referenced in old file + + RETURN + END + + SUBROUTINE CONVERT_USERFILE +C +C SUBROUTINE CONVERT_USERFILE +C +C FUNCTION: Converts user file to new format which has 8 bytes added. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER BUFFER*74,NEW_FILE*80 + + CHARACTER*11 LOGIN_DATE,READ_DATE + CHARACTER*8 LOGIN_TIME,READ_TIME + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + EODIR = MAX(INDEX(BULLUSER_FILE,':'),INDEX(BULLUSER_FILE,']')) + SUFFIX = INDEX(BULLUSER_FILE(EODIR:),'.') + EODIR - 1 + NEW_FILE = BULLUSER_FILE(:SUFFIX)//'OLD' + IER = LIB$RENAME_FILE(BULLUSER_FILE,NEW_FILE) + + OPEN (UNIT=9,FILE=NEW_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + INQUIRE (UNIT=9,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IER = LIB$RENAME_FILE(NEW_FILE,BULLUSER_FILE) + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + IF (IER.EQ.0) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot convert user file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + CALL SYS_GETMSG(IER1) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + CALL ENABLE_CTRL_EXIT + END IF + + DO I=1,FLONG + NEW_FLAG(I) = 'FFFFFFFF'X + NOTIFY_FLAG(I) = 0 + BRIEF_FLAG(I) = 0 + SET_FLAG(I) = 0 + END DO + + IF (RECL.EQ.42.OR.RECL.EQ.50.OR.RECL.EQ.58.OR.RECL.EQ.66.OR. + & RECL.EQ.74) THEN ! Old format + IF (RECL.LE.58) RECL = 50 + IER = 0 + DO WHILE (IER.EQ.0) + READ (9,'(A)',IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + TEMP_USER = BUFFER(1:12) + LOGIN_DATE = BUFFER(13:23) + LOGIN_TIME = BUFFER(24:31) + READ_DATE = BUFFER(32:42) + READ_TIME = BUFFER(43:50) + IF (RECL.EQ.58) + & CALL LIB$MOVC3(8,%REF(BUFFER(51:)),SET_FLAG(1)) + IF (RECL.EQ.66) + & CALL LIB$MOVC3(8,%REF(BUFFER(59:)),NEW_FLAG(1)) + IF (RECL.EQ.74) + & CALL LIB$MOVC3(8,%REF(BUFFER(67:)),NOTIFY_FLAG(1)) + CALL SYS_BINTIM(LOGIN_DATE//' '//LOGIN_TIME,LOGIN_BTIM) + CALL SYS_BINTIM(READ_DATE//' '//READ_TIME,READ_BTIM) + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + IF (RECL.LT.66) THEN + READ (4,KEY=USER_HEADER_KEY,FMT=USER_FMT) TEMP_USER, + & LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + NEW_FLAG(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + ELSE ! Folder maxmimum increase + OFLONG = (RECL - 28) / 16 ! Old #longwords/flag + DO WHILE (IER.EQ.0) + READ (9,FMT='(A12,<4+OFLONG*4>A4)',IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM, + & (NEW_FLAG(I),I=1,OFLONG),(SET_FLAG(I),I=1,OFLONG), + & (BRIEF_FLAG(I),I=1,OFLONG),(NOTIFY_FLAG(I),I=1,OFLONG) + IF (IER.EQ.0) THEN + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + END IF + + IER = 0 + + CLOSE (UNIT=9) + CLOSE (UNIT=4) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + END + + + SUBROUTINE READDIR(BULLETIN_NUM,ICOUNT) +C +C SUBROUTINE READDIR +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file and returns the information for that entry. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, gives header info, i.e number of bulls, +C number of blocks in bulletin file, etc. +C OUTPUTS: +C ICOUNT - The last record read by this routine. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + CHARACTER*3 CFOLDER_NUMBER + + ICOUNT = BULLETIN_NUM + + IF (ICOUNT.EQ.0) THEN + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=0,IOSTAT=IER) BULLDIR_HEADER + END DO + IF (IER.EQ.0) THEN + CALL CONVERT_HEADER_FROMBIN + DIR_NUM = 0 + END IF + ELSE + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 8,0 + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_HEADER + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + CALL CONVERT_HEADER_FROMBIN + RETURN + END IF + END IF + IF (IER.EQ.0) THEN + IF (NBULL.LT.0) THEN ! This indicates bulletin deletion + ! was incomplete. + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR + CALL CLEANUP_DIRFILE(1) + CALL UPDATE_FOLDER + END IF + IF (NEMPTY.EQ.' ') NEMPTY = 0 +C +C Check to see if cleanup of empty file space is necessary, which is +C defined here as being 50 blocks (200 128byte records). Also check +C to see if cleanup was in progress but didn't properly finish. +C + IF (NEMPTY.GT.200.AND.TEST_BULLCP().EQ.0) THEN + WRITE (CFOLDER_NUMBER,'(I3)') FOLDER_NUMBER + IER1 = LIB$SPAWN('$'//COMMAND_PROMPT(1:INDEX( + & COMMAND_PROMPT,'>')-1)//'/CLEANUP='//CFOLDER_NUMBER, + & 'NL:','NL:',1,'BULL_CLEANUP') + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLEANUP_BULLFILE + END IF + END IF + ELSE + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + IF (DIR_NUM.EQ.ICOUNT-1) THEN + READ(2,IOSTAT=IER) BULLDIR_ENTRY + IF (MSG_NUM.NE.ICOUNT) IER = 36 + ELSE + READ(2,KEYID=0,KEY=ICOUNT,IOSTAT=IER) BULLDIR_ENTRY + END IF + END DO + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + DIR_NUM = -1 + END IF + ELSE + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 8,ICOUNT + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_ENTRY + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + CALL CONVERT_ENTRY_FROMBIN + RETURN + END IF + END IF + END IF + + IF (IER.EQ.0) ICOUNT = ICOUNT + 1 + + UNLOCK 2 + + RETURN + + END + + + + + + SUBROUTINE READDIR_KEYGE(IER) +C +C SUBROUTINE READDIR_KEYGE +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file corresponding to or later than the date specified. +C +C INPUTS: +C MSG_KEY - Message key (passed via BULLDIR.INC common block). +C OUTPUTS: +C IER - If not 0, no entry found. Else contains message number. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ(2,KEYID=1,KEYGT=MSG_KEY,IOSTAT=IER) BULLDIR_ENTRY + END DO + IF (IER.EQ.0) THEN + IER = MSG_NUM + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + IER = 0 + DIR_NUM = -1 + END IF + UNLOCK 2 + ELSE + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 8,-1,MSG_KEY + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_ENTRY + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + IER = MSG_NUM + CALL CONVERT_ENTRY_FROMBIN + END IF + END IF + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,NEWEST_EXBTIM,) + + NEWEST_EXDATE = DATETIME + NEWEST_EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,NEWEST_MSGBTIM,) + + NEWEST_DATE = DATETIME + NEWEST_TIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,SHUTDOWN_BTIM,) + + SHUTDOWN_DATE = DATETIME + SHUTDOWN_TIME = DATETIME(13:) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,EX_BTIM,) + + EXDATE = DATETIME + EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,MSG_BTIM,) + + DATE = DATETIME + TIME = DATETIME(13:) + + RETURN + END + + + + + + SUBROUTINE WRITEDIR(BULLETIN_NUM,IER) +C +C SUBROUTINE WRITEDIR +C +C FUNCTION: Writes the entry for the specified bulletin in the +C directory file. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, write the header of the directory file. +C OUTPUTS: +C IER - Error status from WRITE. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + INCLUDE 'BULLDIR.INC' + + CONV = .TRUE. + + GO TO 10 + + ENTRY WRITEDIR_NOCONV(BULLETIN_NUM,IER) + + CONV = .FALSE. + +10 IF (BULLETIN_NUM.EQ.0) THEN + IF (CONV) CALL CONVERT_HEADER_TOBIN + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,0,BULLDIR_HEADER + ELSE + IER = -1 + IF (DIR_NUM.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=0,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + IF (IER.NE.0) THEN + WRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + ELSE + IF (CONV) CALL CONVERT_ENTRY_TOBIN + MSG_NUM = BULLETIN_NUM + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,BULLETIN_NUM,BULLDIR_ENTRY + ELSE + IER = -1 + IF (DIR_NUM.EQ.MSG_NUM) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=BULLETIN_NUM,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + ELSE + WRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + END IF + END IF + END IF + + IF (REMOTE_SET.AND.IER.GT.0) CALL ERROR_AND_EXIT + + DIR_NUM = -1 + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(NEWEST_EXDATE//' '//NEWEST_EXTIME,NEWEST_EXBTIM) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_MSGBTIM) + + CALL SYS_BINTIM(SHUTDOWN_DATE//' '//SHUTDOWN_TIME,SHUTDOWN_BTIM) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(EXDATE//' '//EXTIME,EX_BTIM) + + CALL SYS_BINTIM(DATE//' '//TIME,MSG_BTIM) + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + + RETURN + END + + + + + SUBROUTINE READACL(FILENAME,ACLENT,ACLLENGTH) +C +C SUBROUTINE READACL +C +C FUNCTION: Reads the ACL of a file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C ACLENT - String which will be large enough to hold ACL information. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*(*),OUTPUT*80,ACLSTR*255,FILENAME*(*) + CHARACTER NOT_ID*3 + DATA NOT_ID /'=[,'/ + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + DO ACC_TYPE=1,2 + POINT = 1 + OUTLEN = 0 + DO WHILE ((POINT.LT.ACLLENGTH).AND.IER) + IER = SYS$FORMAT_ACL(ACLENT(POINT:POINT-1+ + & ICHAR(ACLENT(POINT:POINT))),ACLLEN,ACLSTR,,,,) + AC = INDEX(ACLSTR,',ACCESS') + IF ((ACC_TYPE.EQ.1.AND.INDEX(ACLSTR(AC:),'WRITE').GT.0).OR. + & (ACC_TYPE.EQ.2.AND.INDEX(ACLSTR(AC:),'READ').GT.0)) THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,',ACCESS') - 1 + IF (ACLSTR(END_ID:END_ID).EQ.']') THEN + START_ID = END_ID - 1 + DO WHILE + & (INDEX(NOT_ID,ACLSTR(START_ID:START_ID)).EQ.0) + START_ID = START_ID - 1 + END DO + START_ID = START_ID + 1 + END_ID = END_ID - 1 + IF (ACLSTR(START_ID:START_ID).EQ.'*') THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,'ACCESS') - 2 + END IF + END IF + IF (OUTLEN.EQ.0) THEN + IF (FILENAME.NE.BULLUSER_FILE) THEN + IF (ACC_TYPE.EQ.1) THEN + WRITE (6,'( + & '' These users can read and write to this folder:'')') + ELSE + WRITE (6,'( + & '' These users can only read this folder:'')') + END IF + ELSE + WRITE (6,'('' The following are rights identifiers'', + & '' which will give privileges.'')') + END IF + OUTLEN = 1 + END IF + IDLEN = END_ID - START_ID + 1 + IF (OUTLEN+IDLEN-1.GT.80) THEN + WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-1) + OUTPUT = ACLSTR(START_ID:END_ID)//',' + OUTLEN = IDLEN + 2 + ELSE IF (OUTLEN+IDLEN-1.EQ.80) THEN + WRITE (6,'(1X,A)') + & OUTPUT(:OUTLEN-1)//ACLSTR(START_ID:END_ID) + OUTLEN = 1 + ELSE + OUTPUT(OUTLEN:) = ACLSTR(START_ID:END_ID)//',' + OUTLEN = OUTLEN + IDLEN + 1 + END IF + END IF + POINT = POINT + ICHAR(ACLENT(POINT:POINT)) + END DO + IF (OUTLEN.GT.1) WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-2) + END DO + + RETURN + END + + + + + SUBROUTINE CONVERT_INFFILE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + OPEN (UNIT=10,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + INQUIRE (UNIT=10,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + RECL = RECL/8 + + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + DO WHILE (IER.EQ.0) + READ (10,IOSTAT=IER) TEMP_USER,((LAST_READ_BTIM(J,I),J=1,2),I=1,RECL) + IF (IER.EQ.0) WRITE (9) TEMP_USER, + & ((LAST_READ_BTIM(J,I),J=1,2),I=1,FOLDER_MAX) + END DO + + CLOSE (UNIT=10,STATUS='DELETE') + + CLOSE (UNIT=9) + + RETURN + END + + + SUBROUTINE ERROR_AND_EXIT + + IMPLICIT INTEGER (A-Z) + + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + CALL ENABLE_CTRL_EXIT + + RETURN + END + + + + + SUBROUTINE COPY_ACL(INFILE,OUTFILE) +C +C SUBROUTINE COPY_ACL +C +C FUNCTION: +C Copy ACLs from one file to another file +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*255 + + CHARACTER*(*) INFILE,OUTFILE + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) + ! Get length needed to store acl output + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,) + + CALL LIB$GET_VM(ACLLENGTH+8,ACLSTR) ! Create character string to + CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) ! store acl + + CALL COPY_ACL1(INFILE,OUTFILE,%VAL(ACLSTR),ACLLENGTH) + ! Pass location of string + RETURN + END + + + SUBROUTINE COPY_ACL1(INFILE,OUTFILE,ACLENT,ACLLENGTH) +C +C SUBROUTINE COPY_ACL1 +C +C FUNCTION: Called by COPY_ACL to actually do the copy. Need 2 routines +C since must convert location of string into a character string. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*(*),INFILE*(*),OUTFILE*(*) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,) + ! Read input file acl + + CALL INIT_ITMLST ! Initialize item list + POINT = 1 + DO WHILE (POINT.LT.ACLLENGTH) ! Transfer all acls to output file + CALL ADD_2_ITMLST(ICHAR(ACLENT(POINT:POINT)),ACL$C_ADDACLENT, + & %LOC(ACLENT(POINT:))) + POINT = POINT + ICHAR(ACLENT(POINT:POINT)) + END DO + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,OUTFILE,%VAL(ACL_ITMLST),,,) + + RETURN + END diff --git a/decus/lt89b1/bulletin/bulletin7.for b/decus/lt89b1/bulletin/bulletin7.for new file mode 100644 index 0000000..398456d --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin7.for @@ -0,0 +1,1763 @@ +C +C BULLETIN7.FOR, Version 10/26/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE UPDATE_LOGIN(ADD_BULL) +C +C SUBROUTINE UPDATE_LOGIN +C +C FUNCTION: Updates the login file when a bulletin has been deleted +C or added. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($BRKDEF)' + + INCLUDE '($SSDEF)' + + DIMENSION READ_BTIM_SAVE(2),TEMP_BTIM(2) + + CHARACTER OUTPUT*160,TERMINAL*7,FLAGS*1 + CHARACTER*1 CR/13/,LF/10/,BELL/7/ + +C +C We want to keep the last read date for comparison when selecting new +C folders, so save it for later restoring. +C + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL OPEN_BULLUSER_SHARED + +C +C Newest date/time in user file only applies to general bulletins. +C This was present before adding folder capability. +C We set flags in user entry to show new folder added for folder bulletins. +C However, the newest bulletin for each folder is not continually updated, +C As it is only used when comparing to the last bulletin read time, and to +C store this for each folder would be too expensive. +C + + TEMP_BTIM(1) = NEWEST_BTIM(1) + TEMP_BTIM(2) = NEWEST_BTIM(2) + CALL READ_USER_FILE_HEADER(IER) + NEWEST_BTIM(1) = TEMP_BTIM(1) + NEWEST_BTIM(2) = TEMP_BTIM(2) + + IF (IER.NE.0) THEN + CALL CLOSE_BULLUSER + RETURN + ELSE IF (FOLDER_NUMBER.EQ.0) THEN + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_BTIM) + REWRITE (4,IOSTAT=IER) USER_HEADER + END IF + + IF (ADD_BULL.AND.FOLDER_NUMBER.GE.0) THEN ! Message added? + IF (FOLDER_NUMBER.GT.0) THEN ! Folder private? + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CHECK_ACL = 0 + ELSE + CHECK_ACL = 1 + END IF + ELSE + CHECK_ACL = 0 + END IF + + OUTPUT = BELL//CR//LF//LF// + & 'New bulletin added to folder '//FOLDER(1:TRIM(FOLDER)) + & //'. From: '//FROM(1:TRIM(FROM))//CR//LF// + & 'Description: '//DESCRIP(1:TRIM(DESCRIP)) + + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',FLAGS) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',FLAGS) + END IF + + FLAG = 0 + BFLAG = 0 + + IF (IER) THEN + READ (FLAGS(:1),'(I1)',IOSTAT=IER) FLAG + IF (BTEST(FLAG,1).AND.IER.EQ.0) THEN ! Node part of cluster? + CALL OPEN_BULLNOTIFY_SHARED ! Yes, get notify list. + DO WHILE (REC_LOCK(IER1)) ! Any entries? + READ (10,IOSTAT=IER1) TEMP_USER + END DO + IF (IER1.NE.0) THEN ! No entries. + CALL READ_USER_FILE(IER) ! Create entries from + DO WHILE (IER.EQ.0) ! user file. + IF (TEMP_USER(:1).NE.':'.AND.TEMP_USER(:1).NE.'*' + & .AND.TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (10) TEMP_USER + END IF + CALL READ_USER_FILE(IER) + END DO + DO WHILE (REC_LOCK(IER1)) ! Reset to first entry. + READ (10,KEYGT=' ',IOSTAT=IER1) + & TEMP_USER + END DO + END IF + + BFLAG = BRK$M_CLUSTER ! Broadcast to all nodes + + IF (TEST2(NOTIFY_FLAG_DEF,FOLDER_NUMBER).AND. ! If /ALL then + & TEMP_USER.EQ.'*'.AND.IER1.EQ.0) THEN ! notify all. + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & ,%VAL(BRK$C_ALLUSERS),,,%VAL(BFLAG),,,,) + IER1 = 1 ! Don't have to loop through notify list + END IF + END IF + END IF + + DO WHILE ((BFLAG.EQ.0.AND.GETUSERS(TEMP_USER,TERMINAL)).OR. + & (BFLAG.NE.0.AND.IER1.EQ.0)) + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + IF (IER.EQ.0.AND.TEMP_USER.NE.FROM.AND. + & TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + IF (CHECK_ACL) THEN + CALL CHECK_ACCESS + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL', + & TEMP_USER,IER,WRITE_ACCESS) + ELSE + IER = 1 + END IF + IF (IER) THEN + IF (BFLAG.EQ.0) THEN + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & TERMINAL(:TRIM(TERMINAL)),%VAL(BRK$C_DEVICE) + & ,,,%VAL(BFLAG),,,,) + ELSE + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & TEMP_USER(:TRIM(TEMP_USER)),%VAL(BRK$C_USERNAME) + & ,,,%VAL(BFLAG),,,,) + END IF + ELSE + CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + REWRITE (4,IOSTAT=IER) TEMP_USER//USER_ENTRY(13:) + END IF + ELSE IF (IER.NE.0.AND.BFLAG.NE.0) THEN + DELETE (UNIT=10) + END IF + IF (BFLAG.NE.0) THEN + DO WHILE (REC_LOCK(IER1)) + READ (10,IOSTAT=IER1) TEMP_USER + END DO + END IF + END DO + IF (BFLAG.NE.0) CALL CLOSE_BULLNOTIFY + END IF + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + ! Reobtain present values as calling programs still uses them + + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + + CALL CLOSE_BULLUSER + + RETURN + + END + + + + + + SUBROUTINE ADD_ENTRY +C +C SUBROUTINE ADD_ENTRY +C +C FUNCTION: Enters a new directory entry in the directory file. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY_TIME*32 + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + IF (REMOTE_SET) THEN + LOCAL = .TRUE. + IF (INCMD(:3).EQ.'ADD') LOCAL = CLI$PRESENT('LOCAL') + IF (LOCAL) THEN + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,0,0,0,0 + ELSE + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,CLI$PRESENT('BROADCAST'), + & CLI$PRESENT('BELL'),CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER') + END IF + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,TODAY_TIME,F1_NEWEST_BTIM,) + NEWEST_DATE = TODAY_TIME(1:11) + NEWEST_TIME = TODAY_TIME(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + CALL UPDATE_LOGIN(.TRUE.) + RETURN + END IF + + CALL SYS$ASCTIM(,TODAY_TIME,,) + DATE = TODAY_TIME(1:11) + TIME = TODAY_TIME(13:) + + CALL READDIR(0,IER) + + IF (IER.NE.1) THEN + NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = '00:00:00.00' + NBULL = 0 + NBLOCK = 0 + SHUTDOWN = 0 + NEMPTY = 0 + END IF + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + NBULL = NBULL + 1 + BLOCK = NBLOCK + 1 + NBLOCK = NBLOCK + LENGTH + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + CALL UPDATE_LOGIN(.TRUE.) + + CALL WRITEDIR(NBULL,IER) + + CALL WRITEDIR(0,IER) + + RETURN + END + + + + + INTEGER FUNCTION COMPARE_BTIM(BTIM1,BTIM2) +C +C FUNCTION COMPARE_BTIM +C +C FUCTION: Compares times in binary format to see which is farther in future. +C +C INPUTS: +C BTIM1 - First time in binary format +C BTIM2 - Second time in binary format +C OUTPUT: +C Returns +1 if first time is farther in future +C Returns -1 if second time is farther in future +C Returns 0 if equal time +C + IMPLICIT INTEGER (A - Z) + + DIMENSION BTIM1(2),BTIM2(2),DIFF(2) + + CALL LIB$SUBX(BTIM1,BTIM2,DIFF) + + IF (DIFF(2).LT.0) THEN + COMPARE_BTIM = -1 + ELSE IF (DIFF(2).GE.0) THEN + COMPARE_BTIM = +1 + END IF + + RETURN + END + + + + + + INTEGER FUNCTION MINUTE_DIFF(DATE2,DATE1) +C +C FUNCTION MINUTE_DIFF +C +C FUNCTION: Finds difference in minutes between 2 binary times. +C +C + IMPLICIT INTEGER (A-Z) + + DIMENSION DATE1(2),DATE2(2) + + CALL LIB$DAY(DAYS1,DATE1,MSECS1) + CALL LIB$DAY(DAYS2,DATE2,MSECS2) + + MINUTE_DIFF = (DAYS2-DAYS1)*24*60 + (MSECS2-MSECS1)/6000 + + RETURN + END + + + + + + + INTEGER FUNCTION COMPARE_DATE(DATE1,DATE2) +C +C FUNCTION COMPARE_DATE +C +C FUCTION: Compares dates to see which is farther in future. +C +C INPUTS: +C DATE1 - First date (dd-mm-yy) +C DATE2 - Second date (If is equal to ' ', then use present date) +C OUTPUT: +C Returns the difference in days between the two dates. +C If the DATE1 is farther in the future, the output is positive, +C else it is negative. +C + IMPLICIT INTEGER (A - Z) + + CHARACTER*(*) DATE1,DATE2 + INTEGER USER_TIME(2) + + CALL SYS_BINTIM(DATE1,USER_TIME) + + CALL VERIFY_DATE(USER_TIME) +C +C LIB$DAY crashes if date invalid, which happened once due to an unknown +C hardware or software error which created a date very far in the future. +C + CALL LIB$DAY(DAY1,USER_TIME) + + IF (DATE2.NE.' ') THEN + CALL SYS_BINTIM(DATE2,USER_TIME) + CALL VERIFY_DATE(USER_TIME) + ELSE + CALL SYS$GETTIM(USER_TIME) + END IF + + CALL LIB$DAY(DAY2,USER_TIME) + + COMPARE_DATE = DAY1 - DAY2 + + RETURN + END + + + + SUBROUTINE VERIFY_DATE(BTIM) + + IMPLICIT INTEGER (A-Z) + + DIMENSION BTIM(2),TEMP(2) + + CALL SYS_BINTIM(' 5-NOV-2011 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.GT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + CALL SYS_BINTIM(' 5-NOV-1955 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.LT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + RETURN + END + + + + INTEGER FUNCTION COMPARE_TIME(TIME1,TIME2) +C +C FUNCTION COMPARE_TIME +C +C FUCTION: Compares times to see which is farther in future. +C +C INPUTS: +C TIME1 - First time (hh:mm:ss.xx) +C TIME2 - Second time +C OUTPUT: +C Outputs (TIME1-TIME2) in seconds. Thus, if TIME1 is further +C in the future, outputs positive number, else negative. +C + + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) TIME1,TIME2 + CHARACTER*23 TODAY_TIME + CHARACTER*11 TEMP2 + + IF (TIME2.EQ.' ') THEN + CALL SYS$ASCTIM(,TODAY_TIME,,) + TEMP2 = TODAY_TIME(13:) + ELSE + TEMP2 = TIME2 + END IF + + COMPARE_TIME = 3600*10*(ICHAR(TIME1(1:1))-ICHAR(TEMP2(1:1))) + & +3600*(ICHAR(TIME1(2:2))-ICHAR(TEMP2(2:2))) + & +60*10*(ICHAR(TIME1(4:4))-ICHAR(TEMP2(4:4))) + & +60*(ICHAR(TIME1(5:5))-ICHAR(TEMP2(5:5))) + & +10*(ICHAR(TIME1(7:7))-ICHAR(TEMP2(7:7))) + & +(ICHAR(TIME1(8:8))-ICHAR(TEMP2(8:8))) + + IF (COMPARE_TIME.EQ.0) THEN + COMPARE_TIME = 10*(ICHAR(TIME1(10:10))-ICHAR(TEMP2(10:10))) + & +(ICHAR(TIME1(11:11))-ICHAR(TEMP2(11:11))) + IF (COMPARE_TIME.GT.0) THEN + COMPARE_TIME = 1 + ELSE IF (COMPARE_TIME.LT.0) THEN + COMPARE_TIME = -1 + END IF + END IF + + RETURN + END + +C------------------------------------------------------------------------- +C +C The following are subroutines to create a linked-list queue for +C temporary buffer storage of data that is read from files to be +C outputted to the terminal. This is done so as to be able to close +C the file as soon as possible. +C +C Each record in the queue has the following format. The first two +C words are used for creating a character variable. The first word +C contains the length of the character variable, the second contains +C the address. The address is simply the address of the 3rd word of +C the record. The last word in the record contains the address of the +C next record. Every time a record is written, if that record has a +C zero link, it adds a new record for the next write operation. +C Therefore, there will always be an extra record in the queue. To +C check for the end of the queue, the last word (link to next record) +C is checked to see if it is zero. +C +C------------------------------------------------------------------------- + SUBROUTINE INIT_QUEUE(HEADER,DATA) + CHARACTER*(*) DATA + INTEGER HEADER + IF (HEADER.NE.0) RETURN ! Queue already initialized + LENGTH = LEN(DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + CALL LIB$GET_VM(LENGTH+12,HEADER) + CALL MAKE_CHAR(%VAL(HEADER),LEN(DATA),LENGTH) + RETURN + END + + + SUBROUTINE WRITE_QUEUE(RECORD,NEXT,DATA) + INTEGER RECORD(1) + CHARACTER*(*) DATA + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,DATA,%VAL(%LOC(RECORD))) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + IF (NEXT.NE.0) RETURN + CALL LIB$GET_VM(LENGTH+12,NEXT) + CALL MAKE_CHAR(%VAL(NEXT),RECORD(1),LENGTH) + RECORD((LENGTH+12)/4) = NEXT + RETURN + END + + SUBROUTINE READ_QUEUE(RECORD,NEXT,DATA) + CHARACTER*(*) DATA + INTEGER RECORD(1) + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,%VAL(%LOC(RECORD)),DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + RETURN + END + + SUBROUTINE COPY_CHAR(LENGTH,INCHAR,OUTCHAR) + CHARACTER*(*) INCHAR,OUTCHAR + OUTCHAR = INCHAR(:LENGTH) + RETURN + END + + SUBROUTINE MAKE_CHAR(IARRAY,CHAR_LEN,REAL_LEN) + IMPLICIT INTEGER (A-Z) + DIMENSION IARRAY(1) + IARRAY(1) = CHAR_LEN + IARRAY(2) = %LOC(IARRAY(3)) + IARRAY(REAL_LEN/4+3) = 0 + RETURN + END + + + + SUBROUTINE DISABLE_PRIVS +C +C SUBROUTINE DISABLE_PRIVS +C +C FUNCTION: Disable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + DATA PRV_DEPTH /0/ + + COMMON /REALPROC/ REALPROCPRIV(2) + + PRV_DEPTH = PRV_DEPTH + 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(0),,,SETPRV) ! Get privileges + + SETPRV(1) = SETPRV(1).AND..NOT.REALPROCPRIV(1) + + CALL SYS$SETPRV(%VAL(0),SETPRV,,) ! Disable installed privs + + RETURN + END + + + + SUBROUTINE ENABLE_PRIVS +C +C SUBROUTINE ENABLE_PRIVS +C +C FUNCTION: Enable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + PRV_DEPTH = PRV_DEPTH - 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(1),SETPRV,,) ! Enable image privs + + RETURN + END + + + + SUBROUTINE CHECK_PRIV_IO(ERROR) +C +C SUBROUTINE CHECK_PRIV_IO +C +C FUNCTION: Checks SYS$OUTPUT and SYS$ERROR to see if they need +C privileges to output to. +C + + IMPLICIT INTEGER (A-Z) + + CALL DISABLE_PRIVS ! Disable SYSPRV + + OPEN (UNIT=6,FILE='SYS$OUTPUT',IOSTAT=IER,STATUS='NEW') + CLOSE (UNIT=6,STATUS='DELETE') + + OPEN (UNIT=4,FILE='SYS$ERROR',IOSTAT=IER1,STATUS='NEW') + IF (IER.NE.0.OR.IER1.NE.0) THEN + IF (IER1.EQ.0) WRITE (4,100) + IF (IER.EQ.0) WRITE (6,200) + ERROR = 1 + ELSE + CLOSE (UNIT=4,STATUS='DELETE') + ERROR = 0 + END IF + + CALL ENABLE_PRIVS ! Enable SYSPRV + +100 FORMAT(1X,'ERROR: SYS$OUTPUT cannot be opened.') +200 FORMAT(1X,'ERROR: SYS$ERROR cannot be opened.') + + RETURN + END + + + SUBROUTINE CHANGE_FLAG(CMD,FLAG) +C +C SUBROUTINE CHANGE_FLAG +C +C FUNCTION: Sets flags for specified folder. +C +C INPUTS: +C CMD - LOGICAL*4 value. If TRUE, set flag. +C If FALSE, clear flag. +C FLAG - If 1, modify NEW_FLAG, if 2, modify SET_FLAG +C If 3, modify BRIEF_FLAG, 4, modify NOTIFY_FLAG +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + + DATA CHANGE_FOLDER /.FALSE./ + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) + IF (IER) THEN + FOLDER_NUMBER_SAVE = FOLDER_NUMBER + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + CALL CLOSE_BULLFOLDER + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder found.'')') + RETURN + END IF + END IF + FOLDER_NUMBER = FOLDER1_NUMBER + CHANGE_FOLDER = .TRUE. + END IF + +C +C Find user entry in BULLUSER.DAT to update information. +C + + ENTRY CHANGE_FLAG_NOCMD(CMD,FLAG) + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.GT.0) THEN ! No entry (how did this happen??) + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's today + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) ! Fake new entry + CALL READ_USER_FILE_HEADER(IER) + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + ELSE + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + CALL CLOSE_FILE (4) + + IF (FLAG.EQ.4) THEN ! If notify, see if cluster + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',TEMP_USER) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',TEMP_USER) + END IF + READ (TEMP_USER(:1),'(I1)',IOSTAT=IER) BFLAG + IF (BTEST(BFLAG,1).AND.IER.EQ.0) THEN + CALL OPEN_BULLNOTIFY_SHARED + DO WHILE (REC_LOCK(IER)) + READ (10,IOSTAT=IER) TEMP_USER + END DO + IF (TEMP_USER.NE.'*') THEN + IF (CMD) THEN + WRITE (10,IOSTAT=IER) USERNAME + ELSE + DO WHILE (REC_LOCK(IER)) + READ (10,KEY=USERNAME,IOSTAT=IER) + END DO + IF (IER.EQ.0) DELETE (UNIT=10) + END IF + END IF + CALL CLOSE_BULLNOTIFY + END IF + END IF + + IF (CHANGE_FOLDER) THEN + FOLDER_NUMBER = FOLDER_NUMBER_SAVE + CHANGE_FOLDER = .FALSE. + END IF + + RETURN + + END + + + + + SUBROUTINE SET_VERSION +C +C SUBROUTINE SET_VERSION +C +C FUNCTION: Sets version number. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + +C +C Find user entry in BULLUSER.DAT to update information. +C + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.EQ.0) THEN + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY ! Write modified entry + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + CALL CLOSE_FILE (4) + RETURN + + END + + + + + + SUBROUTINE CONFIRM_PRIV(USERNAME,ALLOW) +C +C SUBROUTINE CONFIRM_PRIV +C +C FUNCTION: Confirms that given username has SETPRV. +C +C INPUTS: +C USERNAME - Username +C OUTPUTS: +C ALLOW - Returns 1 if account has SETPRV. +C returns 0 if account has no SETPRV. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + INCLUDE '($PRVDEF)' + + INCLUDE '($UAIDEF)' + + INTEGER DEF_PRIV(2) + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(8,UAI$_DEF_PRIV,%LOC(DEF_PRIV)) + CALL END_ITMLST(GETUAI_ITMLST) + + ALLOW = 0 ! Set return false + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) ! Read Record + IF (IER) THEN ! If username found + IF (BTEST(DEF_PRIV(1),PRV$V_SETPRV).OR. ! SETPRV or CMRKNL + & BTEST(DEF_PRIV(1),PRV$V_CMKRNL)) THEN ! privileges? + ALLOW = 1 ! Yep + END IF + END IF + + RETURN ! Return + END ! End + + + + + + SUBROUTINE CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) +C +C SUBROUTINE CHECK_NEWUSER +C +C FUNCTION: Checks flags for a new: Whether DISMAIL is set, +C and what the last password change was. +C +C INPUTS: +C USERNAME - Username +C OUTPUTS: +C DISMAIL - Returns 1 if account has DISMAIL. +C returns 0 if account has no DISMAIL. +C PASSCHANGE - Date of last password change. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + INTEGER PASSCHANGE(2) + + INCLUDE '($UAIDEF)' + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(8,UAI$_PWD_DATE,%LOC(PASSCHANGE)) + CALL END_ITMLST(GETUAI_ITMLST) + + DISMAIL = 0 ! Set return false + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) ! Read Record + IF (IER) THEN ! If username found + IF (BTEST(FLAGS,UAI$V_NOMAIL)) THEN ! DISMAIL SET? + DISMAIL = 1 ! Yep + END IF + END IF + + RETURN ! Return + END ! End + + + + INTEGER FUNCTION SYS_TRNLNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM = SYS$TRNLNM(,'LNM$FILE_DEV',INPUT(:TRIM(INPUT)),, + & %VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM) OUTPUT = OUTPUT(:OLEN) + + RETURN + END + + + + + INTEGER FUNCTION SYS_TRNLNM_SYSTEM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM_SYSTEM = SYS$TRNLNM(,'LNM$SYSTEM', + & INPUT(:TRIM(INPUT)),,%VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM_SYSTEM) OUTPUT = OUTPUT(:OLEN) + + RETURN + END + + + + INTEGER FUNCTION FILE_LOCK(IER,IER1) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($RMSDEF)' + + DATA INIT /.TRUE./ + + IF (INIT) THEN + FILE_LOCK = 1 + INIT = .FALSE. + ELSE + IF (IER.GT.0) THEN + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.RMS$_FLK) THEN + FILE_LOCK = 1 + CALL WAIT_SEC('01') + ELSE + FILE_LOCK = 0 + INIT = .TRUE. + END IF + ELSE + FILE_LOCK = 0 + IER1 = 0 + INIT = .TRUE. + END IF + END IF + + RETURN + END + + + + SUBROUTINE ENABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + QUIT = 1 + + ENTRY ENABLE_CTRL_EXIT + + QUIT = QUIT.AND.1 ! If called via entry, QUIT = 0 + IF (QUIT.EQ.1) LEVEL = LEVEL - 1 + + IF (LEVEL.LT.0.AND.QUIT.EQ.1) THEN + WRITE (6,'('' ERROR: Error in CTRL.'')') + END IF + + IF (LEVEL.EQ.0.OR.QUIT.EQ.0) THEN + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + END IF + + IF (QUIT.EQ.0) THEN + CALL UPDATE_USERINFO + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL EXIT + END IF + QUIT = 0 ! Reinitialize + + RETURN + END + + + SUBROUTINE DISABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + DATA LEVEL /0/ + + IF (LEVEL.EQ.0) CALL LIB$DISABLE_CTRL(CTRLY,) + LEVEL = LEVEL + 1 + + RETURN + END + + + + + SUBROUTINE CLEANUP_BULLFILE +C +C SUBROUTINE CLEANUP_BULLFILE +C +C FUNCTION: Searches for empty space in bulletin file and deletes it. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER FILENAME*132,BUFFER*128 + + CALL OPEN_BULLDIR_SHARED + +C +C NOTE: Can't use READDIR for reading header since it'll spawn a +C BULL/CLEANUP. (Fooey). +C + + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=HEADER_KEY,IOSTAT=IER) BULLDIR_HEADER + END DO + + IF (NEMPTY.EQ.0) THEN ! No cleanup necessary + CALL CLOSE_BULLDIR + RETURN + ELSE IF (NEMPTY.GT.0) THEN + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,,) + + OPEN (UNIT=11,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + 1 STATUS='UNKNOWN',IOSTAT=IER,DISPOSE='DELETE', + 1 RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',INITIALSIZE=((NBLOCK-NEMPTY)*128)/512) + ! Compressed version is number 1 + + IF (IER.NE.0) THEN + OPEN (UNIT=11, + 1 FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + 1 STATUS='UNKNOWN',IOSTAT=IER,DISPOSE='DELETE', + 1 RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED') + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + RETURN + END IF + END IF + + CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL', + & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL') + + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + + NBLOCK = 0 + + DO I=1,NBULL ! Copy bulletins to new file + CALL READDIR(I,IER) + ICOUNT = BLOCK + DO J=1,LENGTH + NBLOCK = NBLOCK + 1 + DO WHILE (REC_LOCK(IER1)) + READ(1'ICOUNT,IOSTAT=IER1) BUFFER + END DO + IF (IER1.NE.0) THEN ! This file is corrupt + NBLOCK = NBLOCK - 1 + NBULL = I - 1 + GO TO 100 + END IF + WRITE(11) BUFFER + ICOUNT = ICOUNT + 1 + END DO + END DO + +100 CALL CLOSE_BULLFIL + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + RETURN + END IF + + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+1 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.NE.0) THEN + CLOSE (UNIT=11) + CALL CLOSE_BULLDIR + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + RETURN + END IF + END IF + + CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR', + & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR') + + NEMPTY = 0 + WRITE (12,IOSTAT=IER) BULLDIR_HEADER ! Write directory header + + NBLOCK = 0 ! Update directory entry pointers + DO I=1,NBULL + CALL READDIR(I,IER) + BLOCK = NBLOCK + 1 + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (12,IOSTAT=IER) BULLDIR_ENTRY + NBLOCK = NBLOCK + LENGTH + END DO + + CLOSE (UNIT=12,STATUS='KEEP') + CLOSE (UNIT=11,STATUS='KEEP') + + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + + NEMPTY = -1 ! Copying done, indicate that in case of crash + WRITE (2,IOSTAT=IER) BULLDIR_HEADER ! Write new directory header + + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + + RETURN + END + + + + + SUBROUTINE CLEANUP_DIRFILE(DELETE_ENTRY) +C +C SUBROUTINE CLEANUP_DIRFILE +C +C FUNCTION: Reorder directory file after deletions. +C Is called either directly after a deletion, or is +C called if it is detected that a deletion was not fully +C completed due to the fact that the deleting process +C was abnormally terminated. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + CHARACTER*11 DATE_SAVE,EXDATE_SAVE + CHARACTER*11 TIME_SAVE,EXTIME_SAVE + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + DATE_SAVE = DATE + TIME_SAVE = TIME + EXDATE_SAVE = EXDATE + EXTIME_SAVE = EXTIME + + NBULL = -NBULL ! Negative # Bulls signals deletion in progress + MOVE_TO = 0 ! Moving directory entries starting here + MOVE_FROM = 0 ! Moving directory entries from here + I = DELETE_ENTRY ! Start search point for first deleted entries + DO WHILE (MOVE_TO.EQ.0.AND.I.LE.NBULL) + CALL READDIR(I,IER) + IF (IER.NE.I+1) THEN ! Have we found a deleted entry? + MOVE_TO = I ! If so, start moving entries to here + J=I+1 ! Search for next entry in file + DO WHILE (MOVE_FROM.EQ.0.AND.J.LE.NBULL) + CALL READDIR(J,IER) + IF (IER.EQ.J+1) MOVE_FROM = J + J = J + 1 + END DO + IF (MOVE_FROM.EQ.0) THEN ! There are no more entries + NBULL = I - 1 ! so just update number of bulletins + CALL WRITEDIR(0,IER) + RETURN + END IF + LENGTH = -LENGTH ! Indicate starting point by writing + CALL WRITEDIR(I,IER) ! next entry into deleted entry + FIRST_DELETE = I ! with negative length + MOVE_FROM = MOVE_FROM + 1 ! Set up pointers to move rest of + MOVE_TO = MOVE_TO + 1 ! the entries + ELSE IF (LENGTH.LT.0) THEN ! If negative length found, deletion + FIRST_DELETE = I ! was previously in progress + J = I ! Try to find where entry came from + CALL INIT_QUEUE(ENTRY_Q1,BULLDIR_ENTRY) + ENTRY_Q = ENTRY_Q1 + DO K=J,NBULL + CALL READDIR(K,IER) + IF (IER.EQ.K+1) THEN + CALL WRITE_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + END IF + END DO + ENTRY_QLAST = ENTRY_Q + ENTRY_Q2 = ENTRY_Q1 + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q2.NE.ENTRY_QLAST) + CALL READ_QUEUE(%VAL(ENTRY_Q2),ENTRY_Q,BULLDIR_ENTRY) + ENTRY_Q2 = ENTRY_Q + BLOCK_SAVE = BLOCK + MSG_NUM_SAVE = MSG_NUM + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q.NE.ENTRY_QLAST) + ! Search for duplicate entries + CALL READ_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + IF (BLOCK_SAVE.EQ.BLOCK) THEN + MOVE_TO = MSG_NUM_SAVE + 1 + MOVE_FROM = MSG_NUM + 1 + END IF + END DO + ! If no duplicate entry found for this + ! entry, see if one exists for any + END DO ! of the other entries + END IF + I = I + 1 + END DO + + IF (I.LE.NBULL) THEN ! Move reset of entries if necessary + IF (MOVE_FROM.GT.0) THEN + DO J=MOVE_FROM,NBULL + CALL READDIR(J,IER) + IF (IER.EQ.J+1) THEN ! Skip any other deleted entries + CALL WRITEDIR(MOVE_TO,IER) + MOVE_TO = MOVE_TO + 1 + END IF + END DO + END IF + DO J=MOVE_TO,NBULL ! Delete empty records at end of file + CALL READDIR(J,IER) + DELETE(UNIT=2,IOSTAT=IER) + END DO + NBULL = MOVE_TO - 1 ! Update # bulletin count + END IF + + CALL READDIR(FIRST_DELETE,IER) + IF (IER.EQ.FIRST_DELETE+1.AND.LENGTH.LT.0) THEN + LENGTH = -LENGTH ! Fix entry which has negative length + CALL WRITEDIR(FIRST_DELETE,IER) + END IF + + CALL WRITEDIR(0,IER) + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + DATE = DATE_SAVE + TIME = TIME_SAVE + EXDATE = EXDATE_SAVE + EXTIME = EXTIME_SAVE + + RETURN + END + + + SUBROUTINE SHOW_FLAGS +C +C SUBROUTINE SHOW_FLAGS +C +C FUNCTION: Show user flags. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + +C +C Find user entry in BULLUSER.DAT to obtain flags. +C + + CALL OPEN_BULLUSER_SHARED ! Open user file + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + WRITE (6,'('' For the selected folder '',A)') FOLDER(1:TRIM(FOLDER)) + + IF (TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' NOTIFY is set.'')') + END IF + + IF (TEST2(SET_FLAG,FOLDER_NUMBER).AND. + & (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER))) THEN + WRITE (6,'('' READNEW is set.'')') + ELSE IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' BRIEF is set.'')') + ELSE IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' SHOWNEW is set.'')') + ELSE IF (.NOT.TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' No flags are set.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(2) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBSET(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + SUBROUTINE CLR2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBCLR(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + LOGICAL FUNCTION TEST2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + TEST2 = BTEST(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + + INTEGER FUNCTION GETUSERS(USERNAME,TERMINAL) +C +C FUNCTION GETUSERS +C +C FUNCTION: +C To get names of all users that are logged in. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CHARACTER USERNAME*(*),TERMINAL*(*) + + DATA WILDCARD /-1/ + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL ADD_2_ITMLST(LEN(TERMINAL),JPI$_TERMINAL,%LOC(TERMINAL)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = 1 + TERMINAL(1:1) = CHAR(0) + DO WHILE (IER.AND.TERMINAL(1:1).EQ.CHAR(0)) + ! Get next interactive process + IER = SYS$GETJPIW(,WILDCARD,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + + IF (.NOT.IER) WILDCARD = -1 + + GETUSERS = IER + + RETURN + END + + + + + + SUBROUTINE OPEN_USERINFO +C +C SUBROUTINE OPEN_USERINFO +C +C FUNCTION: Opens the file in SYS$LOGIN which contains user information. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /USERINFO/ USERINFO_READ + DATA USERINFO_READ /.FALSE./ + + CALL OPEN_BULLINF_SHARED + + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2 ! Is this BULLCP process? + & .AND.CONFIRM_USER(USERNAME).NE.0) THEN ! Not real user? + USERNAME = 'DECNET' + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + + IF (IER.NE.0) THEN + OPEN (UNIT=10,FILE='SYS$LOGIN:BULLETIN.INF',STATUS='OLD', + & RECORDTYPE='FIXED',FORM='UNFORMATTED',IOSTAT=IER) + INQUIRE(UNIT=10,RECORDSIZE=INF_SIZE) + IF (IER.EQ.0) THEN + READ (10) + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,INF_SIZE/2) + CLOSE (UNIT=10,STATUS='DELETE') + ELSE + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Find user's info + CALL CLOSE_BULLUSER + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2) THEN ! BULLCP process? + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's date + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) + CALL READ_USER_FILE_HEADER(IER) + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + END IF + IF (IER.EQ.0) THEN + DO I=1,FOLDER_MAX + LAST_READ_BTIM(1,I) = READ_BTIM(1) + LAST_READ_BTIM(2,I) = READ_BTIM(2) + END DO + END IF + END IF + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + + CALL CLOSE_BULLINF + + USERINFO_READ = .TRUE. + + RETURN + END + + + + SUBROUTINE UPDATE_USERINFO +C +C SUBROUTINE UPDATE_USERINFO +C +C FUNCTION: Updates the latest message read times for each folder. +C + IMPLICIT INTEGER (A - Z) + + COMMON /USERINFO/ USERINFO_READ + + INCLUDE 'BULLUSER.INC' + + IF (.NOT.USERINFO_READ) RETURN + + CALL OPEN_BULLINF_SHARED + + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) REWRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + + CALL CLOSE_BULLINF + + RETURN + END + + + INTEGER FUNCTION SYS_BINTIM(TIME,BTIM) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*(*) TIME + + IF (TRIM(TIME).EQ.20) THEN + SYS_BINTIM = SYS$BINTIM(TIME//'.00',BTIM) + ELSE + SYS_BINTIM = SYS$BINTIM(TIME,BTIM) + END IF + + RETURN + END + + + + + SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C FUNCTION: +C +C Update user's last read bulletin date. If new bulletins have been +C added since the last time bulletins have been read, position bulletin +C pointer so that next bulletin read is the first new bulletin, and +C alert user. If READNEW set and no new bulletins, just exit. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /POINT/ BULL_POINT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + DIMENSION LOGIN_BTIM_SAVE(2) + + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + CALL UPDATE_READ ! Update login time + + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL SELECT_FOLDER(.TRUE.,IER) + IF (IER) RETURN + END IF + + CALL INIT_QUEUE(FOLDER_Q1,FOLDER_COM) + FOLDER_Q = FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Go find folders + + DO FOLDER_NUMBER = 0,FOLDER_MAX-1 + CALL CLR2(NEW_MSG,FOLDER_NUMBER) ! Clear new message flag + IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL SET2(NEW_MSG,FOLDER_NUMBER) + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + ELSE IF ((NEW_FLAG(1).LT.142.OR.NEW_FLAG(1).GT.143).AND. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + CALL CHANGE_FLAG_NOCMD(0,3) + CALL SET_VERSION + ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & (FOLDER_NUMBER.GT.0.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND.READIT.EQ.1)) THEN + CALL READ_FOLDER_FILE_KEYNUM(FOLDER_NUMBER,IER) +C +C Unknown problem caused system folder flag in folder file to disappear +C so this tests to see if the flag has disappeared and resets if needed. +C + IF (TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND. + & .NOT.BTEST(FOLDER_FLAG,2).AND.IER.EQ.0) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + CALL REWRITE_FOLDER_FILE + END IF + IF (IER.NE.0) THEN + CALL CHANGE_FLAG_NOCMD(0,2) + CALL CHANGE_FLAG_NOCMD(0,3) + CALL CHANGE_FLAG_NOCMD(0,4) + IF (TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + FOLDER_FLAG = 0 + CALL MODIFY_SYSTEM_LIST(0) + END IF + ELSE IF (READIT.EQ.1.AND.SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM, + & F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.READIT.EQ.1) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.DIFF.GE.0) THEN + IER = MINUTE_DIFF(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + IF (IER.LE.15) DIFF = -1 + END IF + END IF + END IF + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN ! If new unread messages + CALL SET2(NEW_MSG,FOLDER_NUMBER) ! Set new message flag + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER + + FOLDER_Q = FOLDER_Q1 + + IF (READIT.EQ.0) THEN ! If not in READNEW mode + IF (TEST2(NEW_MSG,0)) THEN + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + NEW_MESS = .FALSE. + DO FOLDER_NUMBER = 1,FOLDER_MAX-1 + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN ! Are there unread messages? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_NOSYS_BTIM) + IF (DIFF.GT.0) THEN ! Unread non-system messages? + DIFF = COMPARE_BTIM(LOGIN_BTIM,F_NEWEST_BTIM) + ! No. Unread system messages? + IF (DIFF.GT.0) THEN ! No, update last read time. + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(2) + END IF + END IF + IF (DIFF.LT.0) THEN + WRITE (6,'('' There are new messages in '', + & ''folder '',A,''.'',$)') FOLDER(1:TRIM(FOLDER)) + NEW_MESS = .TRUE. + END IF + END IF + END IF + END DO + IF (NEW_MESS) THEN + WRITE (6,'('' Type SELECT followed by foldername to'', + & '' read above messages.'')') + END IF + FOLDER_NUMBER = 0 + CALL SELECT_FOLDER(.FALSE.,IER) + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN + CALL FIND_NEWEST_BULL ! See if there are new messages + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new GENERAL messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + END IF + ELSE ! READNEW mode. + DO FOLDER_NUMBER = 0,FOLDER_MAX-1 + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + CALL SELECT_FOLDER(.FALSE.,IER) + IF (IER) THEN + IF (SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + END IF + IF (DIFF.LT.0) THEN + IF (FOLDER_NUMBER.GT.0) CALL LOGIN_FOLDER + IF (BULL_POINT.NE.-1) THEN + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + IF (FOLDER_NUMBER.GT.0) THEN + WRITE (6,'('' There are new messages in folder '', + & A,''.'')') FOLDER(1:TRIM(FOLDER)) + END IF + ELSE IF (FOLDER_NUMBER.EQ.0.OR. + & .NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + SAVE_BULL_POINT = BULL_POINT + REDO = .TRUE. + DO WHILE (REDO) + REDO = .FALSE. + CALL READNEW(REDO) + IF (REDO) CALL REDISPLAY_DIRECTORY + BULL_POINT = SAVE_BULL_POINT + END DO + END IF + END IF + END IF + END IF + END IF + END DO + CALL EXIT + END IF + + RETURN + END + + + + + SUBROUTINE DISCONNECT_REMOTE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + WRITE (6,'('' ERROR: Connection to remote folder disconnected.'')') + + FOLDER_NUMBER = -1 + FOLDER1 = 'GENERAL' + + CALL SELECT_FOLDER(.FALSE.,IER) + + WRITE (6,'('' Resetting to GENERAL folder.'')') + + RETURN + END diff --git a/decus/lt89b1/bulletin/bulletin8.for b/decus/lt89b1/bulletin/bulletin8.for new file mode 100644 index 0000000..7d2c223 --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin8.for @@ -0,0 +1,1556 @@ +C +C BULLETIN8.FOR, Version 8/18/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE START_DECNET + + IMPLICIT INTEGER (A - Z) + + CHARACTER NAMEDESC*9 /'BULLETIN1'/ + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for + INTEGER*2 MBX_IOSB ! terminal QIO calls. + LOGICAL*1 MBX_BUF + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + DIMENSION NFBDESC(2) + LOGICAL*1 NFB(5) + + EXTERNAL IO$_ACPCONTROL + + PARAMETER NFB$C_DECLNAME = '15'X + + IF (CONFIRM_USER('DECNET').EQ.0) THEN + CALL SETDEFAULT('DECNET') + END IF + +C CALL SET_TIMER('02') + + IER = SYS$CREMBX(%VAL(0),MBX_CHAN,%VAL(132),%VAL(528),,, + & 'BULL_MBX') + IF (.NOT.IER) CALL EXIT(IER) + + IER = SYS$ASSIGN('_NET:',DCL_CHAN,,'BULL_MBX') ! Assign net device + IF (.NOT.IER) CALL EXIT(IER) + + NFBDESC(1) = 5 + NFBDESC(2) = %LOC(NFB) + + NFB(1) = NFB$C_DECLNAME + + IER = SYS$QIOW(,%VAL(DCL_CHAN),IO$_ACPCONTROL,,,, + & NFBDESC,NAMEDESC,,,,) + IF (.NOT.IER) CALL EXIT(IER) + + DO I=1,MAXLINK + CALL LIB$GET_EF(READ_EFS(I)) + CALL LIB$GET_EF(WRITE_EFS(I)) + END DO + + CALL READ_MBX + + RETURN + END + + + SUBROUTINE SETDEFAULT(USERNAME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LNMDEF)' + + INCLUDE '($PSLDEF)' + + INCLUDE '($UAIDEF)' + + CHARACTER DEFDIR*64,DEFDEV*16,USERNAME*(*),ACCOUNT*9 + + 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 SYS$SETDDIR(DEFDIR(2:ICHAR(DEFDIR(:1))+1),,) + + RETURN + END + + + + SUBROUTINE READ_MBX + + IMPLICIT INTEGER (A-Z) + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + 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) + + IER = SYS$QIO(%VAL(MBX_EF),%VAL(MBX_CHAN),IO$_READVBLK,MBX_IOSB, + & MBX_AST,,MBX_BUF,%VAL(132),,,,) + IF (.NOT.IER) CALL EXIT(IER) + + RETURN + + END + + + + + SUBROUTINE MBX_AST + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($MSGDEF)' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + 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*6,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 CONNECT(NODENAME,USERNAME,FROMNAME) + ELSE IF ((MBXMSG.EQ.MSG$_INTMSG.OR.MBXMSG.EQ.MSG$_REJECT.OR. + & MBXMSG.EQ.MSG$_CONFIRM).AND.MBX_IOSB(1)) THEN + CALL READ_MBX + 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 + END IF + + RETURN + END + + + + + SUBROUTINE READ_CHAN(CHAN,UNIT_INDEX) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + EXTERNAL READ_AST + + EXTERNAL IO$_READVBLK + + IER = SYS$QIO(%VAL(READ_EFS(UNIT_INDEX)),%VAL(CHAN),IO$_READVBLK, + & READ_IOSB(1,UNIT_INDEX),READ_AST, + & %VAL(UNIT_INDEX),READ_BUF(1,UNIT_INDEX),%VAL(200),,,,) + + RETURN + + END + + + + + SUBROUTINE WRITE_CHAN(NUM,OUTPUT,UNIT_INDEX,IER) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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)) + + IER = SYS$QIO(%VAL(WRITE_EFS(UNIT_INDEX)), + & %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 WRITE_AST(ASTPRM) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) + COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,FROM_SAVE*12,NODE_SAVE*12 + + CHARACTER*128 INPUT + + 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) + END IF + + RETURN + END + + + + SUBROUTINE READ_AST(ASTPRM) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) + + UNIT_INDEX = %LOC(ASTPRM) + + IF (.NOT.READ_IOSB(1,UNIT_INDEX)) RETURN + + IO(UNIT_INDEX) = IO(UNIT_INDEX) + 1 + + CALL EXECUTE_COMMAND(UNIT_INDEX) + + CALL READ_CHAN(DEVS(UNIT_INDEX),UNIT_INDEX) + + RETURN + END + + + + + + SUBROUTINE CONNECT(NODENAME,USERNAME,FROMNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /ANY_ACTIVITY/ CONNECT_COUNT + DATA CONNECT_COUNT /0/ + + CHARACTER*(*) USERNAME,FROMNAME + + EXTERNAL IO$_ACCESS,IO$M_ABORT + + CONNECT_COUNT = CONNECT_COUNT + 1 + + IO_REJECT = %LOC(IO$_ACCESS)+%LOC(IO$M_ABORT) + + CALL CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, + & NODENAME,USERNAME,FROMNAME) + + IF (REJECT.NE.IO_REJECT) THEN + CALL READ_CHAN(CHAN,UNIT_INDEX) + END IF + + CALL READ_MBX + + RETURN + END + + + SUBROUTINE CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, + & NODENAME,USERNAME,FROMNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for + INTEGER*2 MBX_IOSB ! terminal QIO calls. + LOGICAL*1 MBX_BUF + + PARAMETER MAXLINK = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,FROM_SAVE*12,NODE_SAVE*12 + + 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 + ELSE + IER = SYS$ASSIGN('_NET:',DEV_CHAN,,'BULL_MBX') + + 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).GT.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 + 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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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 + + IF (UNITS(UNIT_INDEX).EQ.0) RETURN + + CALL SYS$DASSGN(%VAL(DEVS(UNIT_INDEX))) + + CALL UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + COUNT = COUNT - 1 + DEVS(UNIT_INDEX) = 0 + UNITS(UNIT_INDEX) = 0 + + 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 TIMBUF*13,MIN*2 + DATA TIMBUF/'0 00:00:00.00'/ + + EXTERNAL CHECK_CONNECTIONS + + CALL LIB$GET_EF(WAITEFN) + + TIMBUF(6:7) = MIN + + IER=SYS$BINTIM(TIMBUF,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 = 10 + + COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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) + + 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 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,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 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + DIMENSION SCRATCH(MAXLINK),OUT_HEAD(MAXLINK) + DATA SCRATCH/MAXLINK*0/,OUT_HEAD/MAXLINK*0/ + + EXTERNAL ENABLE_CTRL_EXIT,SS$_NOSUCHNODE,SS$_NOSUCHOBJ + + PARAMETER TIMEOUT = -10*1000*1000*30 + DIMENSION TIMEBUF(2) + DATA TIMEBUF /TIMEOUT,-1/, TIMEEFN/0/ + + CHARACTER BUFFER*(FOLDER_RECORD+16),DESCRIP_TEMP*53 + CHARACTER NODENAME*6,BULLCP_USER*12,INQUEUE*128 + + EQUIVALENCE (BUFFER,CMD_TYPE),(BUFFER,INQUEUE) + + INTEGER BULLCP_PRIV(2) + + BULLCP_PRIV(1) = PROCPRIV(1) + BULLCP_PRIV(2) = PROCPRIV(2) + + ILEN = READ_IOSB(2,UNIT_INDEX) + CALL LIB$MOVC3(ILEN,READ_BUF(1,UNIT_INDEX),%REF(BUFFER)) + + REC_SAVE(UNIT_INDEX) = 0 + USERNAME = USER_SAVE(UNIT_INDEX) + FOLDER = FOLDER_NAME(UNIT_INDEX) + FOLDER_NUMBER = FOLDER_NUM(UNIT_INDEX) + NODENAME = NODE_SAVE(UNIT_INDEX) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,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) THEN ! Do we need priv info? + IF (PROCPRIV(1).EQ.0.AND.PROCPRIV(2).EQ.0) THEN + CALL GET_USER_PRIV(USERNAME,PRIV_SAVE(1,UNIT_INDEX)) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,UNIT_INDEX) + IF ( (PROCPRIV(1).AND.NEEDPRIV(1)).EQ.0.AND. + & (PROCPRIV(2).AND.NEEDPRIV(2)).EQ.0) THEN + CALL CHECK_BULLETIN_PRIV(USERNAME) + PRIV_SAVE(1,UNIT_INDEX) = PROCPRIV(1) + PRIV_SAVE(2,UNIT_INDEX) = PROCPRIV(2) + END IF + END IF + END IF + + IF (CMD_TYPE.EQ.1) THEN ! Select folder + FOLDER1 = BUFFER(5:ILEN) + FOLDER_NUMBER = -2 + CALL SELECT_FOLDER(.FALSE.,IER) + CALL LIB$MOVC3(4,IER,%REF(BUFFER(1:1))) + CALL LIB$MOVC3(4,READ_ONLY,%REF(BUFFER(5: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13:13))) + ELSE + CALL LIB$MOVC3(8,LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & %REF(BUFFER(9: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13:13))) + END IF + BUFFER = BUFFER(:16)//FOLDER_COM + CALL WRITE_CHAN(16+LEN(FOLDER_COM),BUFFER,UNIT_INDEX,IER1) + IF (IER.AND.IER1) THEN + FOLDER_NAME(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(53,%REF(BUFFER(5:5)),%REF(DESCRIP)) + CALL LIB$MOVC3(11,%REF(BUFFER(58:58)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(69:69)),%REF(EXTIME)) + CALL LIB$MOVC3(4,%REF(BUFFER(80:80)),SYSTEM) + 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.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.NE.0.AND..NOT.SETPRV_PRIV()) THEN ! Priv test + IF (FOLDER_OWNER.NE.USERNAME) THEN + SYSTEM = 0 + ELSE ! Allow permanent if + SYSTEM = SYSTEM.AND.2 ! owner of folder + END IF + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + 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(84:84)),BROAD) + IF (BROAD.AND..NOT.SETPRV_PRIV().AND..NOT.OPER_PRIV()) THEN + BROAD = 0 + END IF + CALL LIB$MOVC3(4,%REF(BUFFER(88:88)),BELL) + CALL LIB$MOVC3(4,%REF(BUFFER(92:92)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(97:97)),CLUSTER) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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 + 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 (1) + 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:).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 + IER = SYS$SETIMR(%VAL(TIMEEFN),TIMEBUF,ENABLE_CTRL_EXIT, + & %VAL(1)) + 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 + IER = SYS$CANTIM(%VAL(1),) + END DO + ELSE IF (CMD_TYPE.EQ.8) THEN ! Read directory entry + CALL LIB$MOVC3(4,%REF(BUFFER(5:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + IF (ICOUNT.GE.0) THEN + CALL READDIR(ICOUNT,IER) + ELSE + CALL LIB$MOVC3(8,%REF(BUFFER(9:9)),%REF(MSG_KEY(1:1))) + CALL READDIR_KEYGE(IER) + END IF + CALL CLOSE_BULLDIR + CALL LIB$MOVC3(4,IER,%REF(BUFFER(1: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:5)),SBULL) + CALL LIB$MOVC3(4,%REF(BUFFER(9:9)),EBULL) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),BULL_DELETE) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR + CALL LIB$MOVC3(53,%REF(BUFFER(5:5)),%REF(DESCRIP_TEMP)) + CALL LIB$MOVC3(4,%REF(BUFFER(58:58)),ICOUNT) + 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(53,%REF(BUFFER(62:62)),%REF(DESCRIP)) + CALL LIB$MOVC3(4,%REF(BUFFER(115:115)),%REF(MSGTYPE)) + CALL LIB$MOVC3(11,%REF(BUFFER(119:119)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(130:130)),%REF(EXTIME)) + 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:5)),BULL_DELETE) + DESCRIP_TEMP = BUFFER(9:61) + 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(11,%REF(BUFFER(62:62)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(73:73)),%REF(EXTIME)) + 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 + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) + CALL GET_NEWEST_MSG(%REF(BUFFER(5: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: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:5)),BLENGTH) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:13)), + & %VAL(SCRATCH(UNIT_INDEX)+START-1)) + ELSE + CALL LIB$MOVC3(BLENGTH,%VAL(SCRATCH(UNIT_INDEX)), + & %REF(BMESSAGE(1:1))) + CALL LIB$MOVC3(4,%REF(BUFFER(13:13)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(17:17)),CLUSTER) + CALL LIB$FREE_VM(BRDCST_LIMIT,SCRATCH(UNIT_INDEX)) + IF (ILEN.GT.20) THEN + CALL LIB$MOVC3(4,%REF(BUFFER(21:21)),FOLDER_NUMBER) + FOLDER = BUFFER(25:) + GO TO 100 + ELSE IF (SETPRV_PRIV().OR.OPER_PRIV()) THEN + CALL BROADCAST(ALL,CLUSTER) + END IF + END IF + END IF + +1000 PROCPRIV(1) = BULLCP_PRIV(1) + PROCPRIV(2) = BULLCP_PRIV(2) + + RETURN + END + + + + SUBROUTINE UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) + COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,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.GE.0) RETURN + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = LAST_SAVE(1,UNIT_INDEX) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = LAST_SAVE(2,UNIT_INDEX) + 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 + + END + + + + + SUBROUTINE CHECK_BULLETIN_PRIV(USERNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + INCLUDE 'BULLFILES.INC' + + 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) THEN + PROCPRIV(1) = NEEDPRIV(1) + PROCPRIV(2) = NEEDPRIV(2) + END IF + 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 + REC_LOCK = 1 + 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) + + CHARACTER*80 MESSAGE + + 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 + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER LOCAL_NODE*32,NODE_TEMP*256 + + 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)) + IF (INDEX(NODES(NODE_NUM),'::').GT.0) THEN ! Remove :: if + NLEN = INDEX(NODES(NODE_NUM),'::') - 1 ! addedd + END IF + IF (LOCAL_NODE(1:L_NODE).EQ.NODES(NODE_NUM)(1:NLEN)) THEN + NODE_NUM = NODE_NUM - 1 + LOCAL_NODE_FOUND = .TRUE. + ELSE + POINT_NODE = NODE_NUM + OPEN (UNIT=9+NODE_NUM,NAME=NODES(NODE_NUM)(1: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 diff --git a/decus/lt89b1/bulletin/bulletin9.for b/decus/lt89b1/bulletin/bulletin9.for new file mode 100644 index 0000000..ecabd14 --- /dev/null +++ b/decus/lt89b1/bulletin/bulletin9.for @@ -0,0 +1,1826 @@ +C +C BULLETIN9.FOR, Version 10/10/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE DELETE_NODE +C +C SUBROUTINE DELETE_NODE +C +C FUNCTION: Deletes files sent via ADD/NODES at remote hosts. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER PASSWORD*31,INLINE*80,DEFAULT_USER*12 + + CALL GET_NODE_INFO + + IF (NODE_ERROR) GO TO 940 + + IF (NODE_NUM.EQ.0.OR.LOCAL_NODE_FOUND) THEN + WRITE (6,'('' ERROR: Cannot specify local node.'')') + GO TO 999 + END IF + + IER = CLI$GET_VALUE('USERNAME',DEFAULT_USER) + IF (.NOT.IER) DEFAULT_USER = USERNAME + IER = CLI$GET_VALUE('SUBJECT',DESCRIP) + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + SEMI = INDEX(NODES(POINT_NODE),'::') ! Look for semicolon after node + NLEN = TRIM(NODES(POINT_NODE)) ! Length of node name + IF (SEMI.GT.0) THEN ! Is semicolon present? + IF (NLEN.GT.SEMI+1) THEN ! Yes, is username after node? + TEMP_USER = NODES(POINT_NODE)(SEMI+2:) ! Yes, set username + NLEN = SEMI - 1 ! Remove semicolon + ELSE ! No username after nodename + TEMP_USER = DEFAULT_USER ! Set username to default + NLEN = SEMI - 1 ! Remove semicolon + SEMI = 0 ! Indicate no username + END IF + ELSE ! No semicolon present + TEMP_USER = DEFAULT_USER ! Set username to default + END IF + INLINE = 'DELETE/SUBJECT="'//DESCRIP(:TRIM(DESCRIP))// + & '"/USERNAME='//TEMP_USER(:TRIM(TEMP_USER)) + IF (CLI$PRESENT('USERNAME').OR.SEMI.GT.0) THEN ! If username was + IER = 1 ! specified, prompt for password + DO WHILE (IER.NE.0) + WRITE(6,'('' Enter password for node '',2A)') + & NODES(POINT_NODE),CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) GO TO 910 + OPEN (UNIT=10+NODE_NUM,NAME=NODES(POINT_NODE)(:NLEN) + & //'"'//TEMP_USER(1:TRIM(TEMP_USER))//' '// + & PASSWORD(1:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10+NODE_NUM) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + END IF + END DO + END IF + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INLINE + IF (INLINE.EQ.'END') THEN + WRITE (6,'('' Message successfully deleted from node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while deleting message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INLINE + END IF + END DO + + GO TO 999 + +910 WRITE (6,1010) + GO TO 999 + +940 WRITE (6,1015) NODES(POINT_NODE) + +999 DO WHILE (NODE_NUM.GT.0) + CLOSE(UNIT=9+NODE_NUM) + NODE_NUM = NODE_NUM - 1 + END DO + + RETURN + +1010 FORMAT (' ERROR: Deletion aborted.') +1015 FORMAT (' ERROR: Unable to reach node ',A) + + END + + + + + SUBROUTINE SET_FOLDER_FLAG(SETTING,FLAG,FLAGNAME) +C +C SUBROUTINE SET_FOLDER_FLAG +C +C FUNCTION: Sets or clears specified flag for folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*(*) FLAGNAME + + IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (SETTING) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,FLAG) + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,FLAG) + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + WRITE (6,'(1X,A,'' has been modified for folder.'')') + & FLAGNAME + ELSE + WRITE (6,'(1X,'' You are not authorized to modify '',A)') + & FLAGNAME//'.' + END IF + + RETURN + END + + + + + SUBROUTINE SET_FOLDER_EXPIRE_LIMIT(LIMIT) +C +C SUBROUTINE SET_FOLDER_EXPIRE_LIMIT +C +C FUNCTION: Sets folder expiration limit. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (LIMIT.LT.0) THEN + WRITE (6,'('' ERROR: Invalid expiration length specified.'')') + ELSE IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + F_EXPIRE_LIMIT = LIMIT + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + WRITE (6,'('' Folder expiration date modified.'')') + ELSE + WRITE (6,'('' You are not allowed to modify folder.'')') + END IF + + RETURN + END + + + + + + SUBROUTINE MERGE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + ENTRY INITIALIZE_MERGE(IER1) + + DO WHILE (FILE_LOCK(IER1,IER2)) + OPEN (UNIT=13,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER1.NE.0) RETURN + + NBULL = 0 + + WRITE(13,IOSTAT=IER1) BULLDIR_HEADER + CALL CONVERT_HEADER_FROMBIN + + TO_POINTER = 1 + + RETURN + + ENTRY ADD_MERGE_TO(IER1) + + IER1 = 0 + + DO WHILE (IER1.EQ.0) + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + + CALL READDIR(TO_POINTER,IER) + + DIFF = COMPARE_BTIM(%REF(BULLDIR_ENTRY_SAVE),MSG_BTIM) + IF (DIFF.LT.0.OR.TO_POINTER+1.NE.IER) THEN + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + CALL CONVERT_ENTRY_FROMBIN + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + END DO + + CLOSE (UNIT=13) + + RETURN + + ENTRY ADD_MERGE_FROM(IER1) + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + BLOCK = NBLOCK - LENGTH + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + RETURN + + ENTRY ADD_MERGE_REST(IER1) + + CALL UPDATE_LOGIN(.TRUE.) + + DO WHILE (IER1.EQ.0) + + CALL READDIR(TO_POINTER,IER) + IF (TO_POINTER+1.NE.IER) THEN + READ (13,KEYID=0,KEY=0,IOSTAT=IER1) + CALL CONVERT_HEADER_TOBIN + REWRITE(13,IOSTAT=IER1) BULLDIR_HEADER + IF (IER1.EQ.0) THEN + CLOSE (UNIT=13,DISPOSE='KEEP') + CALL LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.TMPDIR',FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR') + ELSE + CLOSE (UNIT=13) + END IF + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + END DO + + CLOSE (UNIT=13) + + RETURN + END + + + + + SUBROUTINE SET_NOKEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + INCLUDE '($SMGDEF)' + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'SET KEYPAD',) + + RETURN + END + + + + + + SUBROUTINE SET_KEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + INCLUDE '($SMGDEF)' + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF1',,,,'GOLD') + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'HELP',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2','GOLD',TERM,'SET NOKEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3',,,'EXTRACT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3','GOLD',,'FILE ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4',,TERM,'SHOW KEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4','GOLD',TERM, + & 'SHOW KEYPAD/PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0',,TERM, + & 'SHOW FOLDER/FULL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0','GOLD',TERM,'SHOW FLAGS',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1',,TERM,'BACK',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1','GOLD',TERM,'NEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2',,TERM,'PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2','GOLD',TERM,'PRINT/NONOTIFY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3',,TERM,'DIR',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3','GOLD',TERM,'DIR/FOLDER',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4',,TERM,'CURRENT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4','GOLD',TERM,'CURRENT/EDIT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5',,TERM,'RESPOND',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5','GOLD',TERM,'RESP/EDIT/TEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP6',,TERM,'LAST',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7',,TERM,'ADD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7','GOLD',TERM,'ADD/EDIT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8',,TERM,'REPLY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8','GOLD',TERM,'REPL/EDIT/TEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9',,TERM,'MAIL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9','GOLD',TERM,'MAIL/NOHEAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS',,TERM,'READ/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS','GOLD',TERM,'SHOW NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA',,TERM,'DIR/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA','GOLD',TERM,'INDEX',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD',,TERM,'DELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD','GOLD',TERM,'UNDELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'ENTER','GOLD',,'SELECT ',) + + RETURN + END + + + + SUBROUTINE SHOW_KEYPAD(LIBRARY) + + IMPLICIT INTEGER (A-Z) + EXTERNAL LIB$PUT_OUTPUT,PRINT_OUTPUT + CHARACTER*(*) LIBRARY + + INCLUDE '($HLPDEF)' + + IF (CLI$PRESENT('PRINT')) THEN + OPEN (UNIT=8,STATUS='NEW',FILE='SYS$PRINT:KEYPAD.DAT', + & IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR WHILE OPENING FILE TO PRINTER.'')') + ELSE + CALL LBR$OUTPUT_HELP(PRINT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + CLOSE (UNIT=8) + END IF + ELSE + CALL LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + END IF + + RETURN + END + + INTEGER FUNCTION PRINT_OUTPUT(INPUT) + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) INPUT + WRITE (8,'(1X,A)',IOSTAT=IER) INPUT(:TRIM(INPUT)) + IF (IER.EQ.0) PRINT_OUTPUT = 1 + RETURN + END + + + + SUBROUTINE OUTPUT_HELP(PARAMETER,LIBRARY) +C +C SUBROUTINE OUTPUT_HELP +C +C FUNCTION: +C To create interactive help session. Prompting is enabled. +C INPUTS: +C PARAMETER - Character string. Optional input parameter +C containing a list of help keys. +C LIBRARY - Character string. Name of help library. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LBRDEF)' + + COMMON /HELP/ HELP_PAGE,DISPLAY_ID,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID + CHARACTER*80 HELP_INPUT + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + + EXTERNAL PUT_OUTPUT + + CHARACTER*(*) LIBRARY,PARAMETER + + CHARACTER*80 PROMPT + + DATA DISPLAY_ID/0/,KEYBOARD_ID/0/ + + IER = SMG$CREATE_PASTEBOARD(PASTEBOARD_ID) ! Initialize terminal + IF (DISPLAY_ID.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_DISPLAY(PAGE_LENGTH, + & PAGE_WIDTH,DISPLAY_ID) + END IF + IER = SMG$PASTE_VIRTUAL_DISPLAY(DISPLAY_ID,PASTEBOARD_ID,1,1) + + IF (KEYBOARD_ID.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + END IF + + CALL STR$TRIM(HELP_INPUT,PARAMETER,HELP_INPUT_LEN) ! Trim input + + CALL LBR$INI_CONTROL(LINDEX,LBR$C_READ) ! Init library read + CALL LBR$OPEN(LINDEX,LIBRARY) ! Specify library name + + DO I=1,10 ! Initialize key lengths + KEYL(I) = 0 + END DO + + NKEY = 0 ! Number of help keys + + DO WHILE (1) ! Do until CTRL-Z entered or no more keys + + HELP_PAGE = 0 ! Init line counter + NEED_ERASE = .TRUE. ! Need to erase screen + + OLD_NKEY = NKEY ! Save old key count + EXACT = .TRUE. ! Exact key match + + DO WHILE (NKEY.LT.10.AND.HELP_INPUT_LEN.GT.0.AND. + & HELP_INPUT(:1).NE.'?') + ! Break input into keys + NKEY = NKEY + 1 ! Increment key counter + + DO WHILE (HELP_INPUT(1:1).EQ.' '.AND.HELP_INPUT_LEN.GT.0) + HELP_INPUT = HELP_INPUT(2:HELP_INPUT_LEN) ! Strip spaces + HELP_INPUT_LEN = HELP_INPUT_LEN - 1 ! at start of input + END DO + + NEXT_KEY = 2 + + DO WHILE (NEXT_KEY.LE.HELP_INPUT_LEN ! Search for + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.' ' ! space or + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.'/') ! backslash + NEXT_KEY = NEXT_KEY + 1 ! indicating start of next key + END DO + + IF (NEXT_KEY.GT.HELP_INPUT_LEN) THEN ! Found the last key + KEY(NKEY) = HELP_INPUT(:HELP_INPUT_LEN) ! Key string + KEYL(NKEY) = HELP_INPUT_LEN ! Key length + HELP_INPUT_LEN = 0 + ELSE ! Found the next key + KEY(NKEY) = HELP_INPUT(:NEXT_KEY-1) + HELP_INPUT = HELP_INPUT(NEXT_KEY:HELP_INPUT_LEN) + KEYL(NKEY) = NEXT_KEY - 1 + HELP_INPUT_LEN = HELP_INPUT_LEN - NEXT_KEY + 1 + END IF + END DO + HELP_INPUT_LEN = 0 + IER = LBR$GET_HELP(LINDEX,,PUT_OUTPUT,, ! Display help + & KEY(1)(:KEYL(1)),KEY(2)(:KEYL(2)), + & KEY(3)(:KEYL(3)),KEY(4)(:KEYL(4)),KEY(5)(:KEYL(5)), + & KEY(6)(:KEYL(6)),KEY(7)(:KEYL(7)),KEY(8)(:KEYL(8)), + & KEY(9)(:KEYL(9)),KEY(10)(:KEYL(10))) + + IF (IER.EQ.0.AND.HELP_INPUT_LEN.GT.0) IER = 1 + ! IER = 0 special case means input given to full screen prompt + + IF (KEY(NKEY).EQ.'*'.OR..NOT.EXACT) THEN ! If not exact match + DO I=OLD_NKEY+1,NKEY ! then don't update + KEYL(I) = 0 ! new keys + END DO + NKEY = OLD_NKEY + END IF + + DO WHILE (HELP_INPUT_LEN.EQ.0.AND.IER.AND.NKEY.GE.0) + IF (NKEY.EQ.0) THEN ! If top level, prompt for topic + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Topic? ',HELP_INPUT_LEN) + ELSE ! If not top level, prompt for subtopic + LPROMPT = 0 ! Create subtopic prompt line + DO I=1,NKEY ! Put spaces in between keys + PROMPT = PROMPT(:LPROMPT)//KEY(I)(:KEYL(I))//' ' + LPROMPT = LPROMPT + KEYL(I) + 1 + END DO + PROMPT = PROMPT(:LPROMPT)//'Subtopic? ' + LPROMPT = LPROMPT + 10 + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,PROMPT(:LPROMPT),HELP_INPUT_LEN) + END IF + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) + IF (IER.AND.HELP_INPUT_LEN.EQ.0) THEN ! If RETURN entered + KEYL(NKEY) = 0 ! Back up one key level + NKEY = NKEY - 1 + END IF + END DO + + IF (.NOT.IER.OR.NKEY.LT.0) THEN ! If CTRL-Z above top level, + CALL LBR$CLOSE(LINDEX) ! then close library, + CALL SMG$UNPASTE_VIRTUAL_DISPLAY(DISPLAY_ID,PASTEBOARD_ID) + ! remove virtual display + RETURN ! and end help session. + END IF + + END DO + + END + + + + INTEGER FUNCTION PUT_OUTPUT(INPUT,INFO,DATA,LEVEL) +C +C FUNCTION PUT_OUTPUT +C +C FUNCTION: +C Output routine for input from LBR$GET_HELP. Displays +C help text on terminal with full screen prompting. +C INPUTS: +C INPUT - Character string. Line of input text. +C INFO - Longword. Contains help flag bits. +C DATA - Longword. Not presently used. +C LEVEL - Longword. Contains current key level. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($HLPDEF)' + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + COMMON /HELP/ HELP_PAGE,DISPLAY_ID,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID + CHARACTER*80 HELP_INPUT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + + CHARACTER INPUT*(*) + + CHARACTER SPACES*20 + DATA SPACES /' '/ + + IF ((INFO.AND.HLP$M_NOHLPTXT).NE.0) THEN ! Key cannot be found + NEED_ERASE = .FALSE. ! Don't erase screen + IF (HELP_PAGE.EQ.0) THEN ! If first line of help text + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were inputted, as they are + END DO ! not valid, as no match + NKEY = OLD_NKEY ! could be found. + END IF + ELSE IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0.AND.NKEY.GT.0.AND. + & LEVEL.GT.OLD_NKEY.AND.KEY(NKEY)(:KEYL(NKEY)).NE.'*'.AND. + & %LOC(INPUT).NE.0) THEN ! If text contains key names + ! Update if not wildcard search and they are new keys + IF (KEYL(LEVEL).GT.0) THEN ! If key already updated + EXACT = .FALSE. ! Must be more than one match possible + END IF ! so indicate not exact match. + START_KEY = 1 ! String preceeding spaces. + DO WHILE (INPUT(START_KEY:START_KEY).EQ.' ') + START_KEY = START_KEY + 1 + END DO + KEY(LEVEL) = INPUT(START_KEY:) ! Store new key + CALL STR$TRIM(KEY(LEVEL),KEY(LEVEL),KEYL(LEVEL)) ! & key length + ELSE IF (HELP_PAGE.EQ.0) THEN ! If first line of text, + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were just inputted, allowing + END DO ! this routine to fill them. + END IF + + IF (NEED_ERASE) THEN ! Need to erase screen? + IER = SMG$ERASE_DISPLAY(DISPLAY_ID) ! i.e. start of new topic. + NEED_ERASE = .FALSE. + END IF + + HELP_PAGE = HELP_PAGE + 1 ! Increment screen counter + IF (PAGING.AND.HELP_PAGE.GT.PAGE_LENGTH-2) THEN ! End of page? + HELP_PAGE = 0 ! Reinitialize screen counter + CALL LIB$PUT_OUTPUT(' ') ! Skip line and prompt for next screen + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Press RETURN to continue ... ',HELP_INPUT_LEN) + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) ! Trim input + IF (.NOT.IER.OR.HELP_INPUT_LEN.GT.0) THEN ! CTRL-Z or Text input? + EXACT = .TRUE. ! If more than one match was found and being + ! displayed, text input specifies that the + ! current displayed match is desired. + PUT_OUTPUT = 0 ! Stop any more of current help display. + ELSE ! Else if RETURN entered + IER = SMG$ERASE_DISPLAY(DISPLAY_ID) ! Erase display + NSPACES = LEVEL*2 ! Number of spaces to indent output + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + ! Key name lines are indented 2 less than help description. + IF (NSPACES.GT.0) THEN ! Add spaces if present to output + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE ! Else just output text. + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + HELP_PAGE = 1 ! Increment page counter. + END IF + ELSE ! Else if not end of page + NSPACES = LEVEL*2 ! Just output text line + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + IF (NSPACES.GT.0) THEN + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_VERSION + + IMPLICIT INTEGER (A-Z) + + CHARACTER VERSION*10,DATE*23 + + CALL READ_HEADER(VERSION,DATE) + + WRITE (6,'(A)') ' BULLETIN Version '//VERSION(:TRIM(VERSION)) + + WRITE (6,'(A)') ' Linked on '//DATE(:TRIM(DATE)) + + RETURN + END + + + + + + + SUBROUTINE TAG(ADD_OR_DEL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + DATA BULL_TAG /.FALSE./,READ_TAG /.FALSE./ + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + IF (.NOT.BULL_TAG) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + IF (.NOT.CLI$PRESENT('NUMBER')) THEN + IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER) + ELSE + CALL DEL_TAG(IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Message was not marked.'')') + END IF + END IF + RETURN + END IF + + CALL OPEN_BULLDIR_SHARED + + IER1 = 0 + DO WHILE (CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + & .NE.%LOC(CLI$_ABSENT).AND.IER1.EQ.0) ! Get the specified messages + + DECODE(LEN_P,'(I)',BULL_PARAMETER) MESSAGE_NUMBER + + CALL READDIR(MESSAGE_NUMBER,IER) ! Get info for bulletin + + IF (IER.NE.MESSAGE_NUMBER+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER1) + ELSE + CALL DEL_TAG(IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Message '',I, + & '' was not marked.'')') MESSAGE_NUMBER + END IF + END IF + END DO + + CALL CLOSE_BULLDIR + + RETURN + +1010 FORMAT(' ERROR: You have not read any message.') +1030 FORMAT(' ERROR: Message was not found.') + + END + + + + SUBROUTINE ADD_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER*12 TAG_KEY + + WRITE (13,IOSTAT=IER) TAG_KEY(FOLDER_NUMBER,MSG_KEY) + + IF (IER.EQ.FOR$IOS_INCKEYCHG) THEN + WRITE (6,'('' Message was already marked.'')') + ELSE IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Unable to add mark.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + END IF + + RETURN + END + + + + + SUBROUTINE DEL_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER*12 TAG_KEY + + DO WHILE (REC_LOCK(IER)) + READ (13,KEYEQ=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) + END DO + IF (IER.NE.0) RETURN + + DELETE (UNIT=13,IOSTAT=IER) + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Unable to delete mark.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + END IF + + RETURN + END + + + + + + SUBROUTINE OPEN_OLD_TAG + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + IF (.NOT.IER) RETURN + + NTRIES = 0 + + DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) + OPEN (UNIT=13,FILE='BULL_MARK:'// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + NTRIES = NTRIES + 1 + END DO + + IF (IER.NE.0.AND.IER.NE.FOR$IOS_FILNOTFOU) THEN + WRITE (6,'('' Unable to open mark file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + RETURN + END IF + + IF (IER.EQ.0) BULL_TAG = .TRUE. + + RETURN + END + + + + + SUBROUTINE OPEN_NEW_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*64 BULL_MARK + + IER = SYS_TRNLNM('BULL_MARK',BULL_MARK) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: BULL_MARK must be defined.'', + & '' See HELP MARK.'')') + RETURN + ELSE + IER1 = SYS_TRNLNM_SYSTEM('BULL_MARK',BULL_PARAMETER) + IF (.NOT.IER1.OR.BULL_MARK.NE.BULL_PARAMETER) THEN + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + CALL DISABLE_PRIVS + IER1 = 0 + END IF + OPEN (UNIT=13,FILE='BULL_MARK:'// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & RECORDSIZE=3, + & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + IF (.NOT.IER1) CALL ENABLE_PRIVS + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot create mark file.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + IER = 0 + ELSE + CALL SYS_GETMSG(IER1) + IER = IER1 + END IF + ELSE + BULL_TAG = .TRUE. + IER = 1 + END IF + END IF + + RETURN + END + + + + CHARACTER*12 FUNCTION TAG_KEY(FOLDER_NUMBER,MSG_KEY) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) MSG_KEY + + CALL LIB$MOVC3(4,FOLDER_NUMBER,%REF(TAG_KEY)) + + CALL GET_MSGKEY(%REF(MSG_KEY),TAG_KEY(5:)) + + RETURN + END + + + + + SUBROUTINE GET_FIRST_TAG(FOLDER_NUMBER,IER,MESSAGE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + CHARACTER*12 TAG_KEY,INPUT_KEY + + IF (.NOT.BULL_TAG) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + MSG_KEY = BULLDIR_HEADER + + HEADER = .TRUE. + GO TO 10 + + ENTRY GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) + + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + + ENTRY GET_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) + + HEADER = .FALSE. + +10 DO WHILE (1) + DO WHILE (REC_LOCK(IER)) + READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) + & INPUT_KEY + END DO + + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),MSG_KEY) + CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER) + END IF + + IF (FOLDER1_NUMBER.NE.FOLDER_NUMBER.OR.IER.NE.0) THEN + IER = 1 + UNLOCK 13 + RETURN + ELSE + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL OPEN_BULLDIR + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),INPUT_KEY(5:)) + IF (IER.NE.0.AND.MSG_KEY.EQ.INPUT_KEY(5:)) THEN + UNLOCK 13 + MESSAGE = MSG_NUM + IF (HEADER) THEN + MESSAGE = MESSAGE - 1 + MSG_KEY = BULLDIR_HEADER + END IF + IER = 0 + RETURN + ELSE + DELETE (UNIT=13) + IER = 1 + END IF + END IF + + END DO + + END + + + + + + + SUBROUTINE FULL_DIR(INDEX_COUNT) +C +C Add INDEX command to BULLETIN, display directories of ALL +C folders. Added per request of a faculty member for his private +C board. Changes to BULLETIN.FOR should be fairly obvious. +C +C Brian Nelson, Brian@uoft02.bitnet (or .ccnet, node 8.2) +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + INCLUDE 'BULLFILES.INC' + INCLUDE 'BULLFOLDER.INC' + INCLUDE 'BULLUSER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /TAGS/ BULL_TAG,READ_TAG + + DATA FOLDER_Q1/0/ + + BULL_POINT = 0 + + IF (NUM_FOLDERS.GT.0.AND..NOT.CLI$PRESENT('RESTART') + & .AND.INDEX_COUNT.EQ.1) THEN + INDEX_COUNT = 2 + DIR_COUNT = 0 + END IF + + IF (INDEX_COUNT.EQ.1) THEN + CALL INIT_QUEUE(FOLDER_Q1,FOLDER1_COM) + + FOLDER_Q = FOLDER_Q1 + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0) THEN + IF (BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + WRITE (6,1000) + WRITE (6,1020) + DO J = 1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + WRITE (6,1030) FOLDER1(:15),F1_NBULL, + & FOLDER1_DESCRIP(:MIN(TRIM(FOLDER1_DESCRIP),59)) + END DO + WRITE (6,1060) + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + INDEX_COUNT = 2 + DIR_COUNT = 0 + READ_TAG = .FALSE. + IF (CLI$PRESENT('MARKED')) READ_TAG = .TRUE. + RETURN + ELSE IF (INDEX_COUNT.EQ.2) THEN + IF (DIR_COUNT.EQ.0) THEN + F1_NBULL = 0 + DO WHILE (NUM_FOLDERS.GT.0.AND.F1_NBULL.EQ.0) + NUM_FOLDERS = NUM_FOLDERS - 1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + IF (F1_NBULL.GT.0) THEN + FOLDER_NUMBER = -1 + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) F1_NBULL = 0 + END IF + END DO + + IF (F1_NBULL.EQ.0) THEN + WRITE (6,1050) + INDEX_COUNT = 0 + RETURN + END IF + END IF + + IF (READ_TAG) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + END IF + + CALL DIRECTORY(DIR_COUNT) + IF (DIR_COUNT.GT.0) RETURN + + IF (NUM_FOLDERS.GT.0) THEN + WRITE (6,1040) + ELSE + INDEX_COUNT = 0 + END IF + END IF + + RETURN + +1000 FORMAT (' The following folders are present'/) +1020 FORMAT (' Name Count Description'/) +1030 FORMAT (1X,A15,I5,1X,A) +1040 FORMAT (' Type Return to continue to the next folder...') +1050 FORMAT (' End of folder search.') +1060 FORMAT (' Type Return to continue...') + + END + + + + + SUBROUTINE SHOW_USER +C +C SUBROUTINE SHOW_USER +C +C FUNCTION: Shows information for specified users. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + DIMENSION NOLOGIN_BTIM(2) + + CHARACTER*17 DATETIME + + ALL = CLI$PRESENT('NOLOGIN').OR.CLI$PRESENT('ALL') + & .OR.CLI$PRESENT('LOGIN') + IF (.NOT.ALL) THEN + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + IF (.NOT.IER) TEMP_USER = USERNAME + END IF + + IF (.NOT.SETPRV_PRIV().AND.(ALL.OR.USERNAME.NE.TEMP_USER)) THEN + WRITE (6,'('' ERROR: No privs to user command.'')') + RETURN + END IF + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + + CALL OPEN_BULLUSER_SHARED + + IF (.NOT.ALL) THEN + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + IF (IER.EQ.0) THEN + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + WRITE (6,'('' NOLOGIN set for specified user.'')') + ELSE + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'('' User last logged in at '',A,''.'')') + & DATETIME + END IF + ELSE + WRITE (6,'('' Entry for specified user not found.'')') + END IF + ELSE + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + CALL READ_USER_FILE(IER) + IF (IER.EQ.0.AND.TEMP_USER(:1).NE.':'.AND. + & TEMP_USER(:1).NE.'*') THEN + IER1 = COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM) + IF (.NOT.CLI$PRESENT('LOGIN').AND.IER1.GE.0) THEN + WRITE (6,'('' NOLOGIN set for '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)) + ELSE IF (.NOT.CLI$PRESENT('NOLOGIN').AND.IER1.LT.0) THEN + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'(1X,A,'' last logged in at '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)),DATETIME + END IF + END IF + END DO + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + SUBROUTINE INIT_MESSAGE_ADD(IN_FOLDER,IN_FROM,IN_DESCRIP,IER) +C +C SUBROUTINE INIT_MESSAGE_ADD +C +C FUNCTION: Opens specified folder in order to add message. +C +C INPUTS: +C IN_FOLDER - Character string containing folder name +C IN_FROM - Character string containing name of owner of message. +C If empty, the message is searched for either a +C Reply-to: field or a From: field. If none, then +C the owner of the process is used. If IN_FROM +C ends with a %, it is assumed that it is simply +C the prefix that should be when responding to the +C address via MAIL. I.e. the PMDF interface sends +C IN%, so when the From: field is found, the message +C owner becomes IN%"from-address". +C IN_DESCRIP - Character string containing subject of message. +C If empty, the message is searched for a line +C which starts with "Subj:" or "Subject:". +C OUTPUTS: +C IER - Error status. True if properly connected to folder. +C False if folder not found. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + DATA LPRO/0/ + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + CHARACTER*(*) IN_FOLDER,IN_FROM,IN_DESCRIP + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + BULLCP = 1 ! Inhibit folder cleanup subprocess + + CALL OPEN_BULLFOLDER ! Get folder file + + CALL READ_FOLDER_FILE_KEYNAME(IN_FOLDER(:TRIM(IN_FOLDER)),IER) + + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + RETURN + ELSE + IER = 1 + END IF + + ENTRY INIT_MESSAGE_ADD_BBOARD(IN_FROM,IN_DESCRIP,IER) + + TEXT = .FALSE. ! No text written, as of yet + + FIRST_BREAK = .TRUE. + + IF (FOLDER_NUMBER.EQ.0) THEN ! If GENERAL folder + FOLDER_SET = .FALSE. ! indicate it + ELSE ! Else it's another folder + FOLDER_SET = .TRUE. ! indicate it + END IF + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER ! set folder file names + + ENTRY INIT_MESSAGE_ADD_DIGEST(IN_FROM,IN_DESCRIP,IER) + + CALL OPEN_BULLDIR ! Open directory file + + CALL OPEN_BULLFIL ! Open data file + + CALL READDIR(0,IER1) ! Get NBLOCK + IF (IER1.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + NBLOCK = NBLOCK + 1 + LENGTH = NBLOCK ! Initialize line count + + LEN_FROM = TRIM(IN_FROM) + + IF (IN_FROM(LEN_FROM:LEN_FROM).EQ.'%') THEN ! Just protocol + PROTOCOL = IN_FROM(:LEN_FROM)//'"' + LPRO = LEN_FROM + 1 + LEN_FROM = 0 + END IF + + IF (LEN_FROM.GT.0) THEN + INFROM = IN_FROM + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_FROM(INFROM,LEN_FROM) + ELSE IF (INDEX(INFROM,'%"').GT.0) THEN ! Store any protocol + LPRO = INDEX(INFROM,'%"') + 1 + PROTOCOL = INFROM(:LPRO) + END IF + LEN_DESCRP = TRIM(IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + ELSE + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) + SAVE_IN_DESCRIP = IN_DESCRIP + SAVE_IN_FROM = ' ' + END IF + + CALL STRIP_HEADER(INPUT,0,IER1) + + RETURN + END + + + + SUBROUTINE WRITEOUT_STORED + + CHARACTER*255 BUFFER + + REWIND (UNIT=3) + + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(A)',IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + CALL WRITE_MESSAGE_LINE(BUFFER) + END IF + END DO + + CLOSE (UNIT=3) + + RETURN + END + + + + SUBROUTINE WRITE_MESSAGE_LINE(BUFFER) +C +C SUBROUTINE WRITE_MESSAGE_LINE +C +C FUNCTION: Writes one line of message into folder. +C +C INPUTS: +C BUFFER - Character string containing line to be put into message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + DATA FIRST_BREAK/.TRUE./ + + COMMON /STRIP_HEADER/ STRIP + DATA STRIP/.TRUE./ + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + CHARACTER*(*) BUFFER + + DATA OLD_BUFFER_FROM /.FALSE./ + + LEN_BUFFER = TRIM(BUFFER) + + IF (LEN_FROM.EQ.0) THEN + WRITE (3,'(A)') BUFFER(:LEN_BUFFER) + IF (OLD_BUFFER_FROM.AND.BUFFER(:1).EQ.' ') THEN + SAVE_IN_FROM = + & SAVE_IN_FROM(:TRIM(SAVE_IN_FROM))//BUFFER + OLD_BUFFER_FROM = .FALSE. + ELSE IF (BUFFER(:5).EQ.'From:'.AND.SAVE_IN_FROM.EQ.' ') THEN + IF (LEN_BUFFER.GE.7) SAVE_IN_FROM = BUFFER(7:) + OLD_BUFFER_FROM = .TRUE. + ELSE IF (BUFFER(:9).EQ.'Reply-to:'.OR.LEN_BUFFER.EQ.0) THEN + IF (BUFFER(:9).EQ.'Reply-to:') THEN + IF (LEN_BUFFER.GE.11) SAVE_IN_FROM = BUFFER(11:) + OLD_BUFFER_FROM = .TRUE. + RETURN + ELSE IF (LEN_BUFFER.EQ.0.AND.SAVE_IN_FROM.EQ.' ') THEN + CALL GETUSER(SAVE_IN_FROM) + END IF + LEN_FROM = TRIM(SAVE_IN_FROM) + IF (LEN_FROM.GT.0) THEN + OLD_BUFFER_FROM = .FALSE. + INFROM = SAVE_IN_FROM + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_FROM(INFROM,LEN_FROM) + ELSE IF (INDEX(INFROM,'%"').GT.0) THEN + LPRO = INDEX(INFROM,'%"') + 1 + PROTOCOL = INFROM(:LPRO) + END IF + LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = SAVE_IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + CALL WRITEOUT_STORED + END IF + END IF + RETURN + END IF + + IF (BTEST(FOLDER_FLAG,5)) THEN + IF (INDEX(BUFFER,'-------------').EQ.1) THEN + BREAK = .TRUE. + DO I=1,LEN_BUFFER + IF (BUFFER(I:I).NE.'-') BREAK = .FALSE. + END DO + ELSE + BREAK = .FALSE. + END IF + IF (BREAK) THEN + IF (.NOT.FIRST_BREAK) THEN + CALL FINISH_MESSAGE_ADD + CALL INIT_MESSAGE_ADD_DIGEST(INFROM,INDESCRIP,IER) + ELSE + FIRST_BREAK = .FALSE. + END IF + LFROM = 0 + LDESCR = 0 + RETURN + ELSE IF (.NOT.FIRST_BREAK) THEN + IF (LDESCR.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + LDESCR = LEN_BUFFER - 9 + CALL STORE_DESCRP(BUFFER(10:),LDESCR) + IF (LFROM.EQ.0) THEN + LFROM = LEN_FROM + CALL STORE_FROM(INFROM,LFROM) + END IF + ELSE IF (BUFFER(:6).EQ.'From: ') THEN + LFROM = LEN_BUFFER - 6 + IF (LFROM.LE.0) THEN + LFROM = TRIM(SAVE_IN_FROM) + IF (LPRO.GT.0) THEN + LFROM = LFROM + LPRO + 1 + CALL STORE_FROM(PROTOCOL(:LPRO)// + & SAVE_IN_FROM//'"',LFROM) + ELSE + CALL STORE_FROM(SAVE_IN_FROM,LFROM) + END IF + ELSE IF (LPRO.GT.0) THEN + LFROM = LFROM + LPRO + 1 + CALL STORE_FROM(PROTOCOL(:LPRO)// + & BUFFER(7:LEN_BUFFER)//'"',LFROM) + ELSE + CALL STORE_FROM(BUFFER(7:),LFROM) + END IF + END IF + RETURN + END IF + ELSE + RETURN + END IF + END IF + + IF (LEN_BUFFER.EQ.0) THEN ! If empty line + IF (.NOT.STRIP) THEN + CALL STORE_BULL(1,' ',NBLOCK) ! just store one space + ELSE + CALL STRIP_HEADER(BUFFER,LEN_BUFFER,IER) + END IF + ELSE + IF (LEN_DESCRP.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + DESCRIP = BUFFER(INDEX(BUFFER,' ')+1:) + LEN_DESCRP = LEN_BUFFER + END IF + END IF + IF (STRIP) THEN + CALL STRIP_HEADER(BUFFER,LEN_BUFFER,IER) + IF (IER) THEN + RETURN + ELSE + STRIP = .FALSE. + END IF + END IF + CALL STORE_BULL(MIN(LEN_BUFFER,LINE_LENGTH),BUFFER,NBLOCK) + TEXT = .TRUE. + END IF + + RETURN + END + + + + + SUBROUTINE FINISH_MESSAGE_ADD +C +C SUBROUTINE FINISH_MESSAGE_ADD +C +C FUNCTION: Writes message entry into directory file and closes folder +C +C NOTE: Only should be run if INIT_MESSAGE_ADD was successful. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + COMMON /STRIP_HEADER/ STRIP + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + IF (LEN_FROM.EQ.0) THEN + CALL GETUSER(FROM) + INFROM = FROM + LEN_FROM = TRIM(INFROM) + LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = SAVE_IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + CALL WRITEOUT_STORED + END IF + + STRIP = .TRUE. ! Reset strip flag + + CALL FLUSH_BULL(NBLOCK) + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + IF ((BTEST(FOLDER_FLAG,5).AND.LDESCR.EQ.0).OR. ! End of digest msg + & .NOT.TEXT) THEN ! or no message text found + CALL CLOSE_BULLDIR ! then don't add message entry + RETURN + END IF + + IF (FOLDER_BBEXPIRE.EQ.-1) THEN ! Folder has expiration time? + EXDATE = '5-NOV-2000' ! no, so set date far in future + SYSTEM = 2 ! indicate permanent message + ELSE ! Else set expiration date + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + SYSTEM = 0 + END IF + EXTIME = '00:00:00.00' + + LENGTH = NBLOCK - LENGTH + 1 ! Number of records + + CALL ADD_ENTRY ! Add the new directory entry + + CALL CLOSE_BULLDIR ! Totally finished with add + + CALL UPDATE_FOLDER + + RETURN + END + + + + + SUBROUTINE STORE_FROM(IFROM,LEN_INFROM) + + IMPLICIT INTEGER (A-Z) + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) IFROM + + CHARACTER*(LINE_LENGTH) INFROM + + INFROM = IFROM + + IF (LPRO.GT.0) THEN ! Protocol present? + I = INDEX(INFROM,'%"') + 2 ! Make usable for VMS MAIL + IF (I.EQ.2) THEN + INFROM = PROTOCOL(:LPRO)//INFROM(:LEN_INFROM)//'"' + I = LPRO + 1 + LEN_INFROM = LEN_INFROM + LPRO + 1 + END IF + DO WHILE (I.LT.LEN_INFROM) + IF (INFROM(I:I).EQ.'"') THEN + INFROM(I:I) = '''' + ELSE IF (INFROM(I:I).EQ.'\') THEN + INFROM(I+1:) = '\'//INFROM(I+1:) + LEN_INFROM = LEN_INFROM + 1 + I = I + 1 + ELSE IF (INFROM(I:I).EQ.'''') THEN + INFROM(I:) = '\s'//INFROM(I+1:) + LEN_INFROM = LEN_INFROM + 1 + I = I + 2 + END IF + I = I + 1 + END DO + END IF + + DO I=1,LEN_INFROM ! Remove control characters + IF (INFROM(I:I).LT.' ') INFROM(I:I) = ' ' + END DO + + DO WHILE (LEN_INFROM.GT.0.AND.INFROM(:1).EQ.' ') + INFROM = INFROM(2:) + LEN_INFROM = LEN_INFROM - 1 + END DO + + TWO_SPACE = INDEX(INFROM,' ') + DO WHILE (TWO_SPACE.GT.0.AND.TWO_SPACE.LT.LEN_INFROM) + INFROM = INFROM(:TWO_SPACE)//INFROM(TWO_SPACE+2:) + LEN_INFROM = LEN_INFROM - 1 + TWO_SPACE = INDEX(INFROM,' ') + END DO + + CALL STORE_BULL(6+LEN_INFROM,'From: '//INFROM(:LEN_INFROM), + & NBLOCK) + + IF (INDEX(INFROM,'%"').GT.0) ! Strip off protocol program + & INFROM = INFROM(INDEX(INFROM,'%"')+2:) + + IF (INDEX(INFROM,'::').GT.0) ! Strip off node name + & INFROM = INFROM(INDEX(INFROM,'::')+2:) ! I.e. HOST::USER + + DO WHILE (INDEX(INFROM,'!').GT.0.AND. ! Unix address go backwards. + & INDEX(INFROM,'!').LT.INDEX(INFROM,'@')) + INFROM = INFROM(INDEX(INFROM,'!')+1:) ! I.e. host!user + END DO + + IF (INDEX(INFROM,'<').GT.0) THEN ! Name may be of form + INFROM = INFROM(INDEX(INFROM,'<'):) ! personal-name + END IF + + IF (INDEX(INFROM,'(').GT.0.AND. ! personal-name (net-name) + & INDEX(INFROM,'@').GT.INDEX(INFROM,'(')) THEN + INFROM = INFROM(INDEX(INFROM,'(')+1:) + END IF + + I = 1 ! Trim username to start at first alpha character + DO WHILE (I.LE.LEN_INFROM.AND.(INFROM(I:I).EQ.' '.OR. + & INFROM(I:I).EQ.'%'.OR.INFROM(I:I).EQ.'.'.OR. + & INFROM(I:I).EQ.'@'.OR.INFROM(I:I).EQ.'<'.OR. + & INFROM(I:I).EQ.'"')) + I = I + 1 + END DO + INFROM = INFROM(I:) + + I = 1 ! Trim username to end at a alpha character + DO WHILE (I.LE.12.AND.INFROM(I:I).NE.' '.AND. + & INFROM(I:I).NE.'%'.AND.INFROM(I:I).NE.'.'.AND. + & INFROM(I:I).NE.'@'.AND.INFROM(I:I).NE.'<'.AND. + & INFROM(I:I).NE.'"') + I = I + 1 + END DO + FROM = INFROM(:I-1) + + DO J=2,I-1 + IF ((FROM(J:J).GE.'A'.AND.FROM(J:J).LE.'Z').AND. + & ((FROM(J-1:J-1).GE.'A'.AND.FROM(J-1:J-1).LE.'Z').OR. + & (FROM(J-1:J-1).GE.'a'.AND.FROM(J-1:J-1).LE.'z'))) THEN + FROM(J:J) = CHAR(ICHAR(FROM(J:J))-ICHAR('A')+ICHAR('a')) + END IF + END DO + + RETURN + END + + + + + SUBROUTINE STORE_DESCRP(INDESCRIP,LEN_DESCRP) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) INDESCRIP + + DO I=1,LEN_DESCRP ! Remove control characters + IF (INDESCRIP(I:I).LT.' ') INDESCRIP(I:I) = ' ' + END DO + + DO WHILE (LEN_DESCRP.GT.0.AND.INDESCRIP(:1).EQ.' ') + INDESCRIP = INDESCRIP(2:) + LEN_DESCRP = LEN_DESCRP - 1 + END DO + + IF (LEN_DESCRP.GT.LEN(DESCRIP)) THEN + ! Is length > allowable subject length? + CALL STORE_BULL(6+LEN_DESCRP,'Subj: '// + & INDESCRIP(:LEN_DESCRP),NBLOCK) + END IF + + DESCRIP = INDESCRIP(:MIN(LEN_DESCRP,LEN(DESCRIP))) + + RETURN + END + + + + + + SUBROUTINE STRIP_HEADER(BUFFER,BLEN,IER) +C +C SUBROUTINE STRIP_HEADER +C +C FUNCTION: Indicates whether line is part of mail message header. +C +C INPUTS: +C BUFFER - Character string containing input line of message. +C BLEN - Length of character string. If = 0, initialize subroutine. +C +C OUTPUTS: +C IER - If true, line should be stripped. Else, end of header. +C + IMPLICIT INTEGER (A - Z) + + CHARACTER*(*) BUFFER + + INCLUDE 'BULLFOLDER.INC' + + IF (.NOT.BTEST(FOLDER_FLAG,4).OR.TRIM(BUFFER).EQ.0) THEN + ! If STRIP not set for folder or empty line + IER = .FALSE. + CONT_LINE = .FALSE. + RETURN + END IF + + IF (BLEN.EQ.0) CONT_LINE = .FALSE. + + IER = .TRUE. + + IF (CONT_LINE.AND.(BUFFER(:1).EQ.' '.OR. ! If line is continuation + & BUFFER(:1).EQ.CHAR(9))) RETURN ! of previous header line + + I = 1 + DO WHILE (I.LE.BLEN.AND.BUFFER(I:I).NE.' ') + IF (BUFFER(I:I).EQ.':') THEN ! Header line found + CONT_LINE = .TRUE. ! Next line might be continuation + RETURN + ELSE + I = I + 1 + END IF + END DO + + IER = .FALSE. + CONT_LINE = .FALSE. + + RETURN + END diff --git a/decus/lt89b1/bulletin/bullfiles.inc b/decus/lt89b1/bulletin/bullfiles.inc new file mode 100644 index 0000000..33021bc --- /dev/null +++ b/decus/lt89b1/bulletin/bullfiles.inc @@ -0,0 +1,28 @@ +C +C FOLDER_DIRECTORY IS THE DIRECTORY THAT FILES FOR FOLDERS THAT +C ARE CREATED ARE KEPT IN. IF YOU WISH TO PREVENT FOLDER CREATION, +C YOU SHOULD MODIFY BULLCOM.CLD TO MAKE THE CREATE COMMAND A PRIVILEGED +C COMMAND (OR SIMPLY REMOVE THE LINES WHICH DEFINE THE CREATE COMMAND). +C +C BBOARD_DIRECTORY IS THE SCRATCH AREA USED BY BBOARD WHEN EXTRACTING +C MAIL. IF IT IS UNDEFINED, BBOARD WILL NOT BE ABLE TO BE USED. +C NOTE THAT EITHER THE BBOARD ACCOUNTS MUST HAVE ACCESS TO THIS DIRECTORY, +C OR THE BBOARD ACCOUNTS MUST BE GIVEN SYSPRV PRIVILEGES TO BE ABLE +C TO WRITE INTO THIS DIRECTORY. ALSO, FOR BBOARD TO WORK, MAKE SURE +C THAT THE SUBPROCESS LIMIT FOR USERS IS AT LEAST 2. YOU WILL ALSO HAVE +C TO INCREASE THE FOLLOWING SYSTEM PARAMETERS WHICH AFFECT DETACHED PROCESES: +C PQL_DPGFLQUOTA = 10000, PQL_DWSQUOTA = 500, & PQL_DFILLM = 30. +C (NOTE: ACCESS CAN BE GIVEN TO THE DIRECTORY FOR THE BBOARD ACCOUNTS USING +C ACLS, I.E. " SET ACL/ACL=(ID=bboard,ACCESS=R+W)/OBJ=FILE directory.DIR") +C + COMMON /FILES/ BULLFOLDER_FILE,FOLDER_DIRECTORY,BBOARD_DIRECTORY + COMMON /FILES/ BULLUSER_FILE,BULLINF_FILE + CHARACTER*80 FOLDER_DIRECTORY /'BULL_DIR:'/ + CHARACTER*80 BBOARD_DIRECTORY /'BULL_DIR:'/ +C +C NOTE: THE FOLLOWING DEFINITIONS ASSUME THAT BULL_DIR IS USED. IF IT +C IS NOT, THEN THEY SHOULD ALSO BE CHANGED. +C + CHARACTER*80 BULLUSER_FILE /'BULL_DIR:BULLUSER.DAT'/ + CHARACTER*80 BULLFOLDER_FILE /'BULL_DIR:BULLFOLDER.DAT'/ + CHARACTER*80 BULLINF_FILE /'BULL_DIR:BULLINF.DAT'/ diff --git a/decus/lt89b1/bulletin/bullfolder.inc b/decus/lt89b1/bulletin/bullfolder.inc new file mode 100644 index 0000000..6e31f77 --- /dev/null +++ b/decus/lt89b1/bulletin/bullfolder.inc @@ -0,0 +1,46 @@ +! +! The following 2 parameters can be modified if desired before compilation. +! + PARAMETER BBEXPIRE_LIMIT = 30 ! Maxmimum time limit in days that + ! BBOARDS can be set to. + PARAMETER BBOARD_UPDATE = 15 ! Number of minutes between checks + ! for new BBOARD mail. (Note: Check + ! only occurs via BULLETIN/LOGIN. + ! Check is forced via BULLETIN/BBOARD). + ! NOT APPLICABLE IF BULLCP IS RUNNING. + PARAMETER ADDID = .TRUE. ! Allows users who are not in the + ! rights data base to be added + ! according to uic number. + + PARAMETER FOLDER_FMT = '(A25,A4,A12,A80,A12,3A4,A8,7A4)' + PARAMETER FOLDER_RECORD = 184 ! Must be multiple of 4 + + COMMON /BULL_FOLDER/ FOLDER,FOLDER_NUMBER,FOLDER_OWNER, + & FOLDER_DESCRIP,FOLDER_BBOARD,FOLDER_BBEXPIRE, + & USERB,GROUPB,ACCOUNTB, + & F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,F_EXPIRE_LIMIT, + & F_NEWEST_NOSYS_BTIM,FILLER, + & FOLDER_FILE,FOLDER_SET + INTEGER F_NEWEST_BTIM(2) + INTEGER F_NEWEST_NOSYS_BTIM(2) + LOGICAL FOLDER_SET + DATA FOLDER_SET /.FALSE./, FOLDER/'GENERAL'/ + CHARACTER FOLDER_OWNER*12,FOLDER*25,ACCOUNTB*8 + CHARACTER FOLDER_FILE*80,FOLDER_DESCRIP*80,FOLDER_BBOARD*12 + + CHARACTER*(FOLDER_RECORD) FOLDER_COM + EQUIVALENCE (FOLDER,FOLDER_COM) + + COMMON /BULL_FOLDER1/ FOLDER1,FOLDER1_NUMBER,FOLDER1_OWNER, + & FOLDER1_DESCRIP,FOLDER1_BBOARD,FOLDER1_BBEXPIRE, + & USERB1,GROUPB1,ACCOUNTB1, + & F1_NBULL,F1_NEWEST_BTIM,FOLDER1_FLAG,F1_EXPIRE_LIMIT, + & F1_NEWEST_NOSYS_BTIM,FILLER1, + & FOLDER1_FILE + CHARACTER FOLDER1_OWNER*12,FOLDER1*25,ACCOUNTB1*8 + CHARACTER FOLDER1_FILE*80,FOLDER1_DESCRIP*80,FOLDER1_BBOARD*12 + INTEGER F1_NEWEST_BTIM(2) + INTEGER F1_NEWEST_NOSYS_BTIM(2) + + CHARACTER*(FOLDER_RECORD) FOLDER1_COM + EQUIVALENCE (FOLDER1,FOLDER1_COM) diff --git a/decus/lt89b1/bulletin/bulluser.inc b/decus/lt89b1/bulletin/bulluser.inc new file mode 100644 index 0000000..04dc139 --- /dev/null +++ b/decus/lt89b1/bulletin/bulluser.inc @@ -0,0 +1,42 @@ +! +! The parameter FOLDER_MAX should be changed to increase the maximum number +! of folders available. Due to storage via longwords, the maximum number +! available is always a multiple of 32. Thus, it will probably make sense +! to specify a multiple of 32 for FOLDER_MAX, as that it what really will be +! the capacity. Note that the default general folder counts as a folder also, +! so that if you specify 64, you will be able to create 63 folders on your own. +! + PARAMETER FOLDER_MAX = 96 + PARAMETER FLONG = (FOLDER_MAX + 31)/ 32 + + PARAMETER USER_RECORD_LENGTH = 28 + FLONG*16 + PARAMETER USER_FMT = '(A12,<4+FLONG*4>A4)' + PARAMETER USER_HEADER_KEY = ' ' + + COMMON /HEADER_INFO/ TEMP_USER,BBOARD_BTIM,NEWEST_BTIM,USERPRIV + COMMON /HEADER_INFO/ SET_FLAG_DEF,BRIEF_FLAG_DEF + COMMON /HEADER_INFO/ NOTIFY_FLAG_DEF + CHARACTER TEMP_USER*12 + DIMENSION BBOARD_BTIM(2),NEWEST_BTIM(2),USERPRIV(FLONG) + DIMENSION SET_FLAG_DEF(FLONG),BRIEF_FLAG_DEF(FLONG) + DIMENSION NOTIFY_FLAG_DEF(FLONG) + + COMMON /BULL_USER/ USERNAME,LOGIN_BTIM,READ_BTIM, + & NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + CHARACTER*12 USERNAME + DIMENSION LOGIN_BTIM(2),READ_BTIM(2) + DIMENSION NEW_FLAG(FLONG) ! Bit set indicates new message in folder + DIMENSION SET_FLAG(FLONG) ! Bit set indicates READNEW set for folder + DIMENSION BRIEF_FLAG(FLONG) ! Bit set indicates READNEW/BRIEF set + DIMENSION NOTIFY_FLAG(FLONG)! Bit set indicates to broadcast + ! notification when new bulletin is added. + + CHARACTER*(USER_RECORD_LENGTH) USER_ENTRY,USER_HEADER + EQUIVALENCE (USER_ENTRY,USERNAME) + EQUIVALENCE (USER_HEADER,TEMP_USER) + + COMMON /FOLDER_TIMES/ LAST_READ_BTIM(2,0:FOLDER_MAX) + ! Last read times for each folder as stored in BULL_DIR:BULLINF.DAT + + COMMON /NEW_MESSAGES/ NEW_MSG + DIMENSION NEW_MSG(FLONG) ! Flag showing new messages detected diff --git a/decus/vax89a2/nieland/bulletin/allmacs.mar b/decus/vax89a2/nieland/bulletin/allmacs.mar index 4e65d4a20aced986b1c58134afc7b18f5e72a569..1b5fc53eea94fd27a7fd5393c6c50bffef117749 100755 GIT binary patch delta 1801 zcmbtV%}*0i5D&C$^+AEs(w3H%*AEd)sZh{Bi|DppN`Zd3ZHW>CSx6xmzAV-F6%K?m zi98RU^kO_1Lx>0Ci9f&)V>}w;0TW}4i5`t1#+fa)RB6Q6!|cw!nRzq6ncwu&z=mM- z5g(;dX)f)h2_eY`0`3Se5+Auk9SV4`ts@3AJi#a^Wx;4rnx~%AF51!4-HB$aLuG`u z*S4#3MyVxfI_)J)S4L%bZ&^Q_uax=s&ZDuUkbv_wVpD<#Sud}L^JR@eoAV!@naD_) zne>tubhfE!lcSug)b)Z+_kPZJz#kO)3;JMK*5x#37bc}ydJTd|6SKKEguN{{mlMKv z%ZGHidxY!h$*WnkkT050bl~|tg$uG-)AAsRG7NG=83nmjbq?gFE(p?Hffe7b2!ULy zx3KpW?eM1O!fJBL>6J4Sg(P8%TrYgz;D$l&a_Dnj)yk+s#crz1puJO>*i+RB`3*5L zna>`}SA-FYJCh3ktuqnn2JP&~cZPjC;)k$*wr2ULXJ2c69PI($C0JIPn-7NSY;Fx@ zzs`Y^eYq~AB(dQjo2%<)U+St3rh#7DgT_g1H`KPK#rb)y#Rgb)5s>q`QZzuDH}wKY zyS@wL1wB&bzJ5PdC>t@f!q*i8TE8^JK~f{qYte|E+A{i;#N+g`2ClyZm#pl0gBwhD zIWtq3kaxwL+BTWl0~2y;+k{sGr>cwE?qOFr9~^9Oe+#wVDAW|W0xq8$PlB)2VnC3* z7QRO2X#YZHPRhz_WZmM+?XkF&ft8v~XL5V&qs1)`MWYp{hX7k!AkeZEA$VoQA>Py& znYT$ZRv?BmmnH$7aWClaW_rsgx#SLf36S-Q9|GY>h?g{i5fban|Ye%5px zbKhw~>~xezWt1Y99#NdCV0ro&VVWlAxc zSSQg>TXKxc8oOzk9y# zeuvN1UshQcM8E3 z4hy~HWx<8{SuwW`2fOPs1mNJCfSKno@WsWw(pDu53=aNadOjKl9PNrrF~D+H>}Z{q zDX94{xB;IU+-{K&zzVGO_zKl#t>uIBkdf%Y+hX{ z5L_i%hr`2M-Lx=ODwpf~J59DjB^L?$IXLz0N_oG@aS2#KK#LsI zQLGm*E_Rh9tfFZ1_l?l|cjiOV*@iK&^XOQUKrYR-|>n@4JbD1R&ETWJm+v z)}=+DW^>?UUBCo=@Zv;R6g8(7V3BAZT9i_NH;2Y>OYh@3KGahVdLP&)Fre?pNryuQ z+QQePNW`A6XBZ#!c%`d=>He#J$|%y&56{>xSX)-bBMO>$v0Zo>W#AMmsf_+4ZHA?|KRFr_oCiRkhcdl`{~*U-d4$>-5Vo4fv^Z`W`LnXj4jleWH zo7OqlL_W_4V3>MMw6V3nU7-%NTd(dAI#$1RYp>GW1DHBmpNYpwyKK&z&0u`Y!lfIa z1~C?pr~>beMRjQavY^LfYZ6I%*p*n{XYJ^8=H(RM*^|#tY$UaOJeo^*SuSv_OEdvY zplX?7Vs(S&i)pHKK0FOD3HY&VvRmAhN3Miir41}Bq4SBUSJ@=L1ov5tRuGnN8FfV` zpuz2wYsBD`n+ivwzV4o*1w$O7^(OO#j+%5Vpw z)PGJOE&~{$BPtB!i1?d3qGLe+AYgFZA~SMGb=)IQ6L;0|X*bOrJ2m}n1hEnQ_*6~# E8x~LJ)Bpeg diff --git a/decus/vax89a2/nieland/bulletin/bulldir.inc b/decus/vax89a2/nieland/bulletin/bulldir.inc new file mode 100644 index 0000000..8e5dee2 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulldir.inc @@ -0,0 +1,33 @@ + PARAMETER DIR_RECORD_LENGTH = ((97+3)/4)*4 + + COMMON /BULL_DIR/ MSG_BTIM,MSG_NUM,DESCRIP,FROM,LENGTH,EX_BTIM + & ,SYSTEM,BLOCK,HEADER_BTIM,HEADER_NUM,NEWEST_EXBTIM,NEWEST_MSGBTIM + & ,NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_BTIM,NEMPTY + & ,DATE,TIME,EXDATE,EXTIME,NEWEST_EXDATE,NEWEST_EXTIME + & ,NEWEST_DATE,NEWEST_TIME,SHUTDOWN_DATE,SHUTDOWN_TIME + CHARACTER*53 DESCRIP + CHARACTER*12 FROM + LOGICAL SYSTEM + + CHARACTER*11 DATE,EXDATE,NEWEST_EXDATE,NEWEST_DATE,SHUTDOWN_DATE + CHARACTER*11 TIME,EXTIME,NEWEST_EXTIME,NEWEST_TIME,SHUTDOWN_TIME + + INTEGER MSG_BTIM(2),EX_BTIM(2),HEADER_BTIM(2) + INTEGER NEWEST_EXBTIM(2),NEWEST_MSGBTIM(2),SHUTDOWN_BTIM(2) + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY + EQUIVALENCE (MSG_BTIM,BULLDIR_ENTRY) + + CHARACTER*52 BULLDIR_HEADER + EQUIVALENCE (HEADER_BTIM,BULLDIR_HEADER) + + DATA HEADER_BTIM/0,0/,HEADER_NUM/0/ + + CHARACTER MSG_KEY*8 + + EQUIVALENCE (MSG_BTIM,MSG_KEY) + + PARAMETER LINE_LENGTH=255 + + COMMON /INPUT_BUFFER/ INPUT + CHARACTER INPUT*(LINE_LENGTH) diff --git a/decus/vax89a2/nieland/bulletin/bullet1.com b/decus/vax89a2/nieland/bulletin/bullet1.com new file mode 100644 index 0000000..1fc3e88 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bullet1.com @@ -0,0 +1,782 @@ +$set nover +$copy sys$input AAAREADME.TXT +$deck +The following are instructions for creating and installing the BULLETIN +utility. None of the command procedures included here are sophisticated, so it +is likely that several modifications will have to be made by the installer. +The installer should enable all privileges before installation. + +One of the main uses of BULLETIN, besides storage of messages that are manually +entered by users, is storage of messages from network mailing lists. This is +done by using the BBOARD feature, which is enabled using the SET BBOARD command +inside BULLETIN. The alternative method is for mail messages to be written +directly by a mailing program by calling internal BULLETIN routines. Such a +a program has been written for the popular mail utility PMDF. If you wish to +do so for another utility, read the text file WRITEMSG.TXT. I would be glad to +include any such programs with my distribution if you think such a program +would be of use to other users. + +1) CREATE.COM + This will compile and link the BULLETIN sources. Also, there are several + INCLUDE files for the fortran sources (.INC files). BULLETIN will create it's + data files in the directory pointed to by the logical name BULL_DIR. If you + elect not to use this definition, BULLFILES.INC should be modified. + Note that after this procedure compiles the sources, it puts the objects + into an object library, and then deletes all the OBJ files in the directory. + + NOTE 1: If you elect to have folders with the BBOARD feature that receives + messages from outside networks, you may have to modify the subroutine + which executes the RESPOND command. That command sends messages to either + the originator of the message or the mailing list associated with the + folder. These routines assume that one can simply use the VMS MAIL + utility to do so. + + NOTE 2: The maximum number of folders for this distribution is 96 folders. + If you wish to increase this, modify BULLUSER.INC and recompile the sources. + When the new executable is run, it will create a new BULLUSER.DAT data file + and rename the old one to BULLUSER.OLD. You cannot reduce the number of + folders. + + BULLETIN will work for both V4 & V5. However, you will have to reassemble + ALLMACS.MAR if you are upgrading from V5, i.e. + $ MAC ALLMACS + $ LIB BULL ALLMACS + $ DELETE ALLMACS.OBJ; + $ @BULLETIN.LNK + $ COPY BULLETIN.EXE BULL_DIR: + $ RUN SYS$SYSTEM:INSTALL + BULL_DIR:BULLETIN/REPLACE + +2) INSTALL.COM + The following procedure copies the executable image to SYS$SYSTEM and + installs it with certain privileges. It also installs the necessary + help files in SYS$HELP. (BULLETIN help file is installed into the + system help library HELPLIB.HLB. If you don't wish this done, delete + or modify the appropriate line in the procedure. Also, the help + library for the BULLETIN program, BULL.HLB, can be moved to a different + directory other than SYS$HELP. If this is done, the system logical name + BULL_HELP should be defined to be the directory where the library is + to be found.) + +3) LOGIN.COM + This contains the commands that should be executed at login time + by SYS$MANAGER:SYLOGIN.COM. It defines the BULLETIN commands. + It also executes the command BULLETIN/LOGIN in order to notify + the user of new messages. NOTE: If you wish the utility to be a + different name than BULLETIN, you should modify this procedure. + The prompt which the utility uses is named after image executable. + If you want messages displayed upon logging in starting from + oldest to newest (rather than newest to oldest), add /REVERSE to + the BULLETIN/LOGIN command. Note that users with the DISMAIL + flag setting in the authorization file will not be notified of + new messages. See help on the SET LOGIN command within the BULLETIN + utility for more information on this. Also, please note that when + a brand new user to the system logins, to avoid overwhelming the new + user with lots of messages, only PERMANENT SYSTEM messages are displayed. + + If you want SYSTEM messages, i.e. messages which are displayed in full + when logging in, to be continually displayed for a period of time rather + than just once, you should add the /SYSTEM= qualifier. This is documented + in BULLETIN.HLP, although there it is referred to only with respect to + a user wanting to review system messages. It can be added with /LOGIN. + +4) BULLSTART.COM + This procedure contains the commands that should be executed after + a system startup. It should be executed by SYS$MANAGER:SYSTARTUP.COM. + It installs the BULLETIN utility with correct privileges. It also + includes the command BULLETIN/STARTUP. This starts up a detached process + with the name BULLCP. It periodically check for expire messages, cleanup + empty space in files, and converts BBOARD mail to messages. It also allows + other DECNET nodes to share it's folders. If you don't want this feature + and don't plan on having multiple folders or make use of BBOARD, you could + eliminate this command if you like. However, it is highly recommended that + you create this process to avoid extra overhead when users login. NOTE: + BULLCP normally is created so it is owned by the DECNET account. If that + account does not exist, BULLCP will be owned by the account that issues + the BULLETIN/START command. In that case, access via other DECNET nodes + will not be available. + + If you are installing BULLETIN on a cluster and plan to have the bulletin + files be shared between all of the cluster nodes, you only need to have + this process running on one node. On all other nodes, the system logical + name BULL_BULLCP should be defined (to anything you want) so as to notify + BULLETIN that BULLCP is running. (On the local node where BULLCP is running, + this logical name is automatically defined.) WARNING: This scheme will + only work if the same SYSUAF files are shared by all nodes. If a different + SYSUAF file is used on a node or nodes, those nodes must have their own + bulletin files and BULLCP. However, they can still share the other nodes' + folder files by using the remote folder feature. + + The use of the MARK command to mark messages require that a file be + created for each user which saves the marked info. That file file is + stored in the directory pointed to by the logical name BULL_MARK. You can + either let users who want to use this command define it themselves, or + you can define it for them, i.e. DEFINE/SYSTEM BULL_MARK SYS$LOGIN. + +5) INSTRUCT.COM + This procedure adds 2 permanent messages which give a very brief + description about the BULLETIN utility, and how to turn off optional + prompting of non-system messages (via SET NOREADNEW). + +6) BOARD_SPECIAL.COM + This command procedure describes and illustrates how to use the + SET BBOARD/SPECIAL feature. This feature allows the use of BBOARD + where the input does not come from VMS MAIL. For example, this could + be used in the case where mail from a non-DEC network is not stored + in the VMS MAIL. Another example is BOARD_DIGEST.COM. This file + takes mail messages from "digest" type mailing lists and splits them + into separate BULLETIN messages for easier reading. + + To use this feature, place the special command procedure into the + bulletin file directory using the name BOARD_SPECIAL.COM. If you want + to have several different special procedure, you should name the command + procedure after the username specified by the SET BBOARD command. + +7) INSTALL_REMOTE.COM + This procedure, in conjunction with REMOTE.COM and DCLREMOTE.COM allows + a user to install new versions of BULLETIN on several DECNET nodes from + a single node, rather than having to login to each node. This is + especially useful when a new version modifies the format of one of the + data file. Older versions of BULLETIN will not run with newer formats + and will either issue error statements when run, or may cause major + problems by attempting to change the files back to the old format. + (NOTE: Don't attempt to use this if different nodes are running + different versions of VMS, i.e. V4 and V5, as they require different + linked executables.) + +8) MASTER.COM + If you are using PMDF, and want to use the BBOARD option, a set of + routines are included which will allow PMDF to write message directly + into folders, which is a much more effecient way of doing it than + the normal BBOARD method of using VMS MAIL. Read PMDF.TXT for how + to do this. + +9) BULLETIN.COM + If one wants BULLETIN to be able to send messages to other DECNET + node's GENERAL folder, but wants to avoid running the process created + by BULLETIN/STARTUP on this node, another method exists. This is the + "older" (and slower) method. BULLETIN.COM must be put in each node's + DECNET default user's directory (usually [DECNET]). Once this is done, + the /NODE qualifier for the ADD & DELETE commands can be used. + NOTE: Privileged functions such as /SYSTEM will work on other nodes + if you have an account on the other node with appropriate privileges. + You will be prompted for the password for the account on the remote node. +$eod +$copy sys$input BULLDIR.INC +$deck + PARAMETER DIR_RECORD_LENGTH = ((97+3)/4)*4 + + COMMON /BULL_DIR/ MSG_BTIM,MSG_NUM,DESCRIP,FROM,LENGTH,EX_BTIM + & ,SYSTEM,BLOCK,HEADER_BTIM,HEADER_NUM,NEWEST_EXBTIM,NEWEST_MSGBTIM + & ,NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_BTIM,NEMPTY + & ,DATE,TIME,EXDATE,EXTIME,NEWEST_EXDATE,NEWEST_EXTIME + & ,NEWEST_DATE,NEWEST_TIME,SHUTDOWN_DATE,SHUTDOWN_TIME + CHARACTER*53 DESCRIP + CHARACTER*12 FROM + LOGICAL SYSTEM + + CHARACTER*11 DATE,EXDATE,NEWEST_EXDATE,NEWEST_DATE,SHUTDOWN_DATE + CHARACTER*11 TIME,EXTIME,NEWEST_EXTIME,NEWEST_TIME,SHUTDOWN_TIME + + INTEGER MSG_BTIM(2),EX_BTIM(2),HEADER_BTIM(2) + INTEGER NEWEST_EXBTIM(2),NEWEST_MSGBTIM(2),SHUTDOWN_BTIM(2) + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY + EQUIVALENCE (MSG_BTIM,BULLDIR_ENTRY) + + CHARACTER*52 BULLDIR_HEADER + EQUIVALENCE (HEADER_BTIM,BULLDIR_HEADER) + + DATA HEADER_BTIM/0,0/,HEADER_NUM/0/ + + CHARACTER MSG_KEY*8 + + EQUIVALENCE (MSG_BTIM,MSG_KEY) + + PARAMETER LINE_LENGTH=255 + + COMMON /INPUT_BUFFER/ INPUT + CHARACTER INPUT*(LINE_LENGTH) +$eod +$copy sys$input BULLETIN.HLP +$deck +1 BULLETIN +Invokes the PFC BULLETIN Utility. This utility is used for reading, +adding and deleting message. Users are notified at login time that new +messages have been added and the topics of those messages are +displayed. Reading of those messages is optional. (Use the command SET +READNEW while in BULLETIN for setting automatic reading.) Privileged +users can add system bulletins that are displayed in full at login +time. These messages are also saved, and can be read by BULLETIN. +Messages are automatically deleted after a specified expiration date, +or they can manually be deleted by either the submitter of the message +or a privileged user. + + Format: + + BULLETIN + +BULLETIN has an interactive help available while using the utility. +Type HELP after invoking the BULLETIN command. +2 Description +The BULLETIN utility is a utility to display messages to users when +logging in. Users are notified of messages only once. They're not +forced into reading them every time they log in. Submitting and +reading messages is easy to do via a utility similar to the VMS MAIL +utility. Privileged users can create messages which are displayed in +full. (known as SYSTEM messages). Non-privileged users may be able to +create non-SYSTEM messages (unless your system manager has disabled the +feature), but only topics are displayed at login. + +Folders can be created so that messages pertaining to a single topic +can be placed together. Folders can be made private so that reading +and writing is limited to only users or groups who are granted access. +Alternatively, folders can be made semi-private in that everyone is +allowed to read them but write access is limited. + +When new non-system messages are displayed, an optional feature which a +user may enable will cause BULLETIN to ask whether the user wishes to +read the new bulletins. The user can then read the messages (with the +ability to write any of the messages to a file). A user can enable the +notification and prompting of new messages feature on a folder per +folder basis. However, the exception is messages submitted to the +default GENERAL folder. Users are always notified at login of new +bulletins in this folder, but can disable the prompting. This is to +give non-privileged users some ability to force a notification of an +important message. + +Messages have expiration dates and times, and are deleted automatically. +Expiration dates and times can be specified in absolute or delta +notation. Privileged users can specify "SHUTDOWN" messages, i.e. +messages that get deleted after a system shutdown has occurred. +"PERMANENT" messages can also be created which never expire. + +Privileged users can broadcast their message (to either all users or +all terminals). + +A user can select, on a folder per folder basis, to have a message +broadcast to their terminal immediately notifying them when a new +message has been added. + +An optional "Bulletin Board" feature allows messages to be created by +users of other systems connected via networks. A username can be +assigned to a folder, and any mail sent to that user is converted to +messages and stored in that folder. This feature originally was +designed to duplicate the message board feature that exists on some +Arpanet sites. However, with the addition of folders, another possible +use is to assign an Arpanet mailing list to a folder. For example, one +could have an INFOVAX folder associated with an INFOVAX username, and +have INFO-VAX mail sent to INFOVAX. Users could then read the mailing +list in that folder, rather than having INFO-VAX sent to each user. +Optionally, the input for the bulletin board can be directed to be taken +from any source other than VMS MAIL. This might be useful if incoming +mail is stored in a different place other than VMS MAIL. + +Messages can be either sent to a file, to a print queue, or mailed to +another user. +2 /EDIT +Specifies that all ADD or REPLACE commands within BULLETIN will select +the editor for inputting text. +2 /KEYPAD +Specifies that keypad mode is to be set on, such that the keypad keys +correspond to BULLETIN commands. +2 /PAGE + /[NO]PAGE + +Specifies whether BULLETIN will stop outputting when it displays a full +screen or not. /PAGE is the default. If /NOPAGE is specified, any +output will continue until it finishes. This is useful if you have a +terminal which can store several screenfuls of display in it's memory. +2 /STARTUP +Starts up a detached process which will periodically check for expired +messages, cleanup empty space in files, and convert BBOARD mail to +messages. This is recommended to avoid delays when invoking BULLETIN. +It will create a process with the name BULLCP. For clusters, this +need be done only on one node. On all other nodes, the system logical +name BULL_BULLCP should be defined (to anything) in order that BULLETIN +is aware that it is running on another node. (On the local node where +BULLCP is running, this logical name is automatically defined.) +2 /STOP +Stops the BULLCP process without restarting a new one. (See /STARTUP +for information on the BULLCP process.) +2 /SYSTEM + /SYSTEM=[days] + +Displays system messages that have been recently added. The default is +to show the messages that were added during the last 7 days. This can +be modified by specifying the number of days as the parameter. +This command is useful for easily redisplaying system messages that +might have been missed upon logging in (or were broadcasted but were +erased from the screen.) +$eod +$copy sys$input BULLETIN.LNK +$deck +$ LINK/NOTRACE BULL/LIB/INC=BULLETIN$MAIN,SYS$SYSTEM:SYS.STB/SEL/NOUSERLIB- + /EXE=BULLETIN,SYS$INPUT/OPT +ID="V1.68" +$eod +$copy sys$input BULLFILES.INC +$deck +C +C FOLDER_DIRECTORY IS THE DIRECTORY THAT FILES FOR FOLDERS THAT +C ARE CREATED ARE KEPT IN. IF YOU WISH TO PREVENT FOLDER CREATION, +C YOU SHOULD MODIFY BULLCOM.CLD TO MAKE THE CREATE COMMAND A PRIVILEGED +C COMMAND (OR SIMPLY REMOVE THE LINES WHICH DEFINE THE CREATE COMMAND). +C +C BBOARD_DIRECTORY IS THE SCRATCH AREA USED BY BBOARD WHEN EXTRACTING +C MAIL. IF IT IS UNDEFINED, BBOARD WILL NOT BE ABLE TO BE USED. +C NOTE THAT EITHER THE BBOARD ACCOUNTS MUST HAVE ACCESS TO THIS DIRECTORY, +C OR THE BBOARD ACCOUNTS MUST BE GIVEN SYSPRV PRIVILEGES TO BE ABLE +C TO WRITE INTO THIS DIRECTORY. ALSO, FOR BBOARD TO WORK, MAKE SURE +C THAT THE SUBPROCESS LIMIT FOR USERS IS AT LEAST 2. YOU WILL ALSO HAVE +C TO INCREASE THE FOLLOWING SYSTEM PARAMETERS WHICH AFFECT DETACHED PROCESES: +C PQL_DPGFLQUOTA = 10000, PQL_DWSQUOTA = 500, & PQL_DFILLM = 30. +C (NOTE: ACCESS CAN BE GIVEN TO THE DIRECTORY FOR THE BBOARD ACCOUNTS USING +C ACLS, I.E. " SET ACL/ACL=(ID=bboard,ACCESS=R+W)/OBJ=FILE directory.DIR") +C + COMMON /FILES/ BULLFOLDER_FILE,FOLDER_DIRECTORY,BBOARD_DIRECTORY + COMMON /FILES/ BULLUSER_FILE,BULLINF_FILE + CHARACTER*80 FOLDER_DIRECTORY /'BULL_DIR:'/ + CHARACTER*80 BBOARD_DIRECTORY /'BULL_DIR:'/ +C +C NOTE: THE FOLLOWING DEFINITIONS ASSUME THAT BULL_DIR IS USED. IF IT +C IS NOT, THEN THEY SHOULD ALSO BE CHANGED. +C + CHARACTER*80 BULLUSER_FILE /'BULL_DIR:BULLUSER.DAT'/ + CHARACTER*80 BULLFOLDER_FILE /'BULL_DIR:BULLFOLDER.DAT'/ + CHARACTER*80 BULLINF_FILE /'BULL_DIR:BULLINF.DAT'/ +$eod +$copy sys$input BULLFOLDER.INC +$deck +! +! The following 2 parameters can be modified if desired before compilation. +! + PARAMETER BBEXPIRE_LIMIT = 30 ! Maxmimum time limit in days that + ! BBOARDS can be set to. + PARAMETER BBOARD_UPDATE = 15 ! Number of minutes between checks + ! for new BBOARD mail. (Note: Check + ! only occurs via BULLETIN/LOGIN. + ! Check is forced via BULLETIN/BBOARD). + ! NOT APPLICABLE IF BULLCP IS RUNNING. + PARAMETER ADDID = .TRUE. ! Allows users who are not in the + ! rights data base to be added + ! according to uic number. + + PARAMETER FOLDER_FMT = '(A25,A4,A12,A80,A12,3A4,A8,7A4)' + PARAMETER FOLDER_RECORD = 184 ! Must be multiple of 4 + + COMMON /BULL_FOLDER/ FOLDER,FOLDER_NUMBER,FOLDER_OWNER, + & FOLDER_DESCRIP,FOLDER_BBOARD,FOLDER_BBEXPIRE, + & USERB,GROUPB,ACCOUNTB, + & F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,F_EXPIRE_LIMIT, + & F_NEWEST_NOSYS_BTIM,FILLER, + & FOLDER_FILE,FOLDER_SET + INTEGER F_NEWEST_BTIM(2) + INTEGER F_NEWEST_NOSYS_BTIM(2) + LOGICAL FOLDER_SET + DATA FOLDER_SET /.FALSE./, FOLDER/'GENERAL'/ + CHARACTER FOLDER_OWNER*12,FOLDER*25,ACCOUNTB*8 + CHARACTER FOLDER_FILE*80,FOLDER_DESCRIP*80,FOLDER_BBOARD*12 + + CHARACTER*(FOLDER_RECORD) FOLDER_COM + EQUIVALENCE (FOLDER,FOLDER_COM) + + COMMON /BULL_FOLDER1/ FOLDER1,FOLDER1_NUMBER,FOLDER1_OWNER, + & FOLDER1_DESCRIP,FOLDER1_BBOARD,FOLDER1_BBEXPIRE, + & USERB1,GROUPB1,ACCOUNTB1, + & F1_NBULL,F1_NEWEST_BTIM,FOLDER1_FLAG,F1_EXPIRE_LIMIT, + & F1_NEWEST_NOSYS_BTIM,FILLER1, + & FOLDER1_FILE + CHARACTER FOLDER1_OWNER*12,FOLDER1*25,ACCOUNTB1*8 + CHARACTER FOLDER1_FILE*80,FOLDER1_DESCRIP*80,FOLDER1_BBOARD*12 + INTEGER F1_NEWEST_BTIM(2) + INTEGER F1_NEWEST_NOSYS_BTIM(2) + + CHARACTER*(FOLDER_RECORD) FOLDER1_COM + EQUIVALENCE (FOLDER1,FOLDER1_COM) +$eod +$copy sys$input BULLUSER.INC +$deck +! +! The parameter FOLDER_MAX should be changed to increase the maximum number +! of folders available. Due to storage via longwords, the maximum number +! available is always a multiple of 32. Thus, it will probably make sense +! to specify a multiple of 32 for FOLDER_MAX, as that it what really will be +! the capacity. Note that the default general folder counts as a folder also, +! so that if you specify 64, you will be able to create 63 folders on your own. +! + PARAMETER FOLDER_MAX = 96 + PARAMETER FLONG = (FOLDER_MAX + 31)/ 32 + + PARAMETER USER_RECORD_LENGTH = 28 + FLONG*16 + PARAMETER USER_FMT = '(A12,<4+FLONG*4>A4)' + PARAMETER USER_HEADER_KEY = ' ' + + COMMON /HEADER_INFO/ TEMP_USER,BBOARD_BTIM,NEWEST_BTIM,USERPRIV + COMMON /HEADER_INFO/ SET_FLAG_DEF,BRIEF_FLAG_DEF + COMMON /HEADER_INFO/ NOTIFY_FLAG_DEF + CHARACTER TEMP_USER*12 + DIMENSION BBOARD_BTIM(2),NEWEST_BTIM(2),USERPRIV(FLONG) + DIMENSION SET_FLAG_DEF(FLONG),BRIEF_FLAG_DEF(FLONG) + DIMENSION NOTIFY_FLAG_DEF(FLONG) + + COMMON /BULL_USER/ USERNAME,LOGIN_BTIM,READ_BTIM, + & NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + CHARACTER*12 USERNAME + DIMENSION LOGIN_BTIM(2),READ_BTIM(2) + DIMENSION NEW_FLAG(FLONG) ! Bit set indicates new message in folder + DIMENSION SET_FLAG(FLONG) ! Bit set indicates READNEW set for folder + DIMENSION BRIEF_FLAG(FLONG) ! Bit set indicates READNEW/BRIEF set + DIMENSION NOTIFY_FLAG(FLONG)! Bit set indicates to broadcast + ! notification when new bulletin is added. + + CHARACTER*(USER_RECORD_LENGTH) USER_ENTRY,USER_HEADER + EQUIVALENCE (USER_ENTRY,USERNAME) + EQUIVALENCE (USER_HEADER,TEMP_USER) + + COMMON /FOLDER_TIMES/ LAST_READ_BTIM(2,0:FOLDER_MAX) + ! Last read times for each folder as stored in BULL_DIR:BULLINF.DAT + + COMMON /NEW_MESSAGES/ NEW_MSG + DIMENSION NEW_MSG(FLONG) ! Flag showing new messages detected +$eod +$copy sys$input HANDOUT.TXT +$deck + Introduction to BULLETIN on the Vax + 2/88 AW + +PUBLISHED BY THE DREW UNIVERSITY ACADEMIC COMPUTER CENTER. MAY BE +COPIED WITH WRITING CREDIT GIVEN TO DREW UNIVERSITY. + +BULLETIN was written for the Public Domain by Mark London at MIT. + + The BULLETIN utility permits a user to create messages for +reading by other users. Users may be notified upon logging on +that new messages have been added, and what the topic of the +messages are. Actual reading of the messages is optional. (See +the command SET READNEW for info on automatic reading.) Messages +are automatically deleted when their expiration data has passed. + The program runs like VAX mail. The different interest +groups or BULLETIN boards are implemented in the form of +'Folders', just like a filing cabinet. A Folder contain various +messages on the same general topic. A message is a piece of text +written by a user or staff person and added to a particular +folder. All users are not permitted to submit messages to all +folders. + + A message consists of an expiration date, a subject line +and the text of the message. BULLETIN will prompt the user for +these things when a message is being added. + + Several different folders are currently defined to +BULLETIN. The General Folders will be used by Computer Center +Staff to post messages of general interest concerning the VAX to +the user community. If something is of an important nature, it +will be posted in the General folder as a 'System' message. +This is a special message type. It will be displayed to each +user as they log in the first time after that message was +posted. This will be done automatically by BULLETIN on login. +Once a particular system message has been displayed, it will not +be displayed for that user on subsequent logins. + +Folders + + Different folders have been created to contain messages on +different topics. Folders may be public, semi-private, or +private. The majority of the folders will be public. However a +few will be semi-private, which will mean that all users may +read messages in the folder but not all will be able to post to +it. Currently, there are several folders defined: + +GENERAL -- system messages + +PUBLIC_ANNOUNCEMENTS -- Can be used by anyone to post messages +of interest to the public + +On Beta: +AIDE STATION -- Private folder for Computer Center Employees + +In addition on Alpha there are folders that receive electronic +magazines, such as: +NETMONTH -- The monthly magazine of BITNET information. +RISKS -- Identifying the risks involved in using computers. +INFOIBMPC -- Information about the IBM personal computers. +INFOVAX -- Information on the Digital VAX. +PROGRAMMING_JOURNALS-Includes MINIX, UNIX and C, Modula-2 and +Prolog journals +watch for new ones being added. + +Using BULLETIN + + BULLETIN is invoked by type the command 'BULLETIN' (or BULL, +for short) at the '$' prompt. BULLETIN will display its prompt +'BULLETIN>'. Help is available from DCL command level ($) or from +within the BULLETIN program itself by typing the word 'HELP'. To +leave the BULLETIN program, type 'EXIT'. + +To see what is there + + In order to see message and folders, on can use the +'Directory' command. Upon entering BULLETIN, the user is place +in the General folder. If the user wishes to see which folders +exist, the directory/folders command is used. for example: +typing: + + BULLETIN> directory/folders + +will make a display like: + + Folder Owner + *GENERAL SYSTEM + *PUBLIC_ANNOUNCEMENTS BBEYER + NETMONTH BITNET + *VAX_SIG BBEYER + +An asterisk (*) next to the folder name indicates you have unread +messages in that folder. + +The command 'DIRECTORY/FOLDERS/DESCRIBE' would list all available +folders, along with a brief description of each. + + To switch from one folder to another folder, the user may +execute the 'SELECT' command. For example, the following +command would show what a user would do to switch to the folder +called PUBLIC_ANNOUNCEMENTS: + +BULLETIN> SELECT PUBLIC_ANNOUNCEMENTS + +and BULLETIN would respond: + Folder has been set to PUBLIC_ANNOUNCEMENTS + + Now the user may get a list of the messages in this folder +by issuing the directory command with no qualifiers. +This command, for example: +BULLETIN> DIRECTORY +would have bulletin respond: + + # Description From Date + 1 CHRISTMAS PARTY oleksiak 26-JUN-88 + 2 Learning about BULLETIN oleksiak 26-JUN-87 + 3 VAX MAIL LLLOYD 01-Jan-87 + + The command 'DIR/NEW' will list just unread messages. + + +Reading messages + + In order to read messages in a folder, the user may type +the read command or he/she may simply type the number of the +message he wishes to read. The message numbers can be acquired +by doing the 'DIRECTORY' command. If the user hits a carriage +return with no input whatsoever, BULLETIN will type the first +message in the folder, or if there are new messages present, it +will type the first new message in the folder. + + If a folder contains the above messages (as seen by the +'Directory' command) then these messages can be read by: + +BULLETIN> READ +and BULLETIN would respond: + +Message number: 1 PUBLIC_ANNOUNCEMENTS +Description: CHRISTMAS PARTY +Date: 26-JUN-1988 8:08:40 Expires: 1-JAN-1989 08:08:40 + +...Body of message..... + + Should the user only wish to see message number 3, he can +enter the 'READ' command with the message number as a parameter. +for example: + +BULLETIN> READ 3 + + There are three other useful commands that can be used at +the 'BULLETIN>' prompt when reading messages. These are: + +BACK - Read the message preceding the message currently being +read. + +CURRENT - Start reading the current message at the top. This is +useful for someone who is reading a message and wishes to reread +it from the beginning. + +NEXT - Start reading from the beginning of the next message. +This is handy if the user is reading a very long message and +wants to skip to the next one. + +Saving the interesting stuff. + + If the user sees something which he/she wants a copy of, +the extract command can be use to write an ASCII copy of the +message into a file. This command works on the current message +being read. It requires the name of the file into which to save +the message. If the file name is not given, the user will be +prompted for it. For example: + +BULLETIN> Read 2 + +********** Message on Screen ******** + +A person could then type +BULLETIN> extract +file: FV.TXT +BULLETIN> + +BULLETIN has now saved the contents of message number 2 into the +file name 'FV.txt'. + If the file to which the user is writing already exists, +BULLETIN will append the message to the file. The user can +force BULLETIN to write a new file containing only the message +being saved by using the '/new' qualifier in the 'extract' +command. These messages can then be sent to other users, or +downloaded for use in Wordperfect. (See "Mail on the Vax", or +"Transferring a file between a PC and the VAX"). + +This command may be useful if you wish to transfer the message to +your PC, perhaps using a BITNET journal message as a reference in +a paper. Once the file is saved, you can transfer it to a PC by +following the instructions in the handout 'Transferring files +from the PC to the VAX of from the VAX to a PC". + +Adding messages + A user may add a message to a folder by selecting the +folder and then using the 'ADD' command. This is provided that +the user is adding the message to a public folder. The user has +the option of giving the 'ADD' command and typing a message using +the VAX editor or uploading a message from your PC (see +documentation), or add a message you have extracted from VAX +mail. BULLETIN will prompt for the expiration date and subject +line. It will then add the text of the file as the body of the +message. To add a message that is stored in a file (from MAIL or +from your PC, for example) type: + + ADD filename + +If the user does not specify a file name, he/she will be +prompted to enter the body of the message. The user may also +use the EDT text editor by issuing the command with the +'/EDIT'option. + +For example: +BULLETIN> sel PUBLIC_ANNOUNCEMENTS + folder has been set to PUBLIC_ANNOUNCEMENTS +BULLETIN> ADD MESS.TXT + +IT IS 10-JUL-1988 12:41:06.15. SPECIFY WHEN THE MESSAGE SHOULD +EXPIRE: ENTER ABsolute TIME: + +The above session adds the text in the file 'mess.txt' as the +next message in the PUBLIC_ANNOUNCEMENTS Folder. The message +will be deleted automatically on the 20th of July as requested +by the user adding the message. + +Asking BULLETIN to notify you of new messages upon logging in. + + If the user wishes to get notification on login when new +messages are in a folder, he should use the 'READNEW' option. +This command does not force the reader to reading new messages, +only gives notification. To do this, 'SELECT' each folder you +are interested in and do a 'SET READNEW' command while set to +that folder. + +Example: + +BULLETIN> Select PUBLIC_ANNOUNCEMENTS +folder has been set to PUBLIC_ANNOUNCEMENTS +BULLETIN> SET READNEW + +Alternately, you may type SET SHOWNEW. This will just display a +message notifying you that there are new messages. + +Mailing a BULLETIN message + + A user may directly mail another user a message found in the +BULLETIN. While reading the message that he/she desires to send, +at the 'BULLETIN>' type 'MAIL'. The Vax will then ask to whom +you wish to send the information too. + +Check the BULLETIN DISCUSSION folder on ALPHA for new additions. +If you have comments or questions about BULLETIN, leave them +there. +$eod +$copy sys$input INSTRUCT.TXT +$deck +This message is being displayed by the BULLETIN facility. This is a non-DEC +facility, so it is not described in the manuals. Messages can be submitted by +using the BULLETIN command. System messages, such as this one, are displayed +in full, but can only be entered by privileged users. Non-system messages can +be entered by anyone, but only their topics will be displayed at login time, +and will be prompted to optionally read them. (This prompting feature can be +disabled). All bulletins can be reread at any time unless they are deleted or +expire. For more information, see the on-line help (via HELP BULLETIN). +$eod +$copy sys$input NONSYSTEM.TXT +$deck +Non-system bulletins (such as this) can be submitted by any user. Users are +alerted at login time that new non-system bulletins have been added, but only +their topics are listed. Optionally, users can be prompted at login time to +see if they wish to read the bulletins. When reading the bulletins in this +manner, the bulletins can optionally be written to a file. If you have the +subdirectory [.BULL] created, BULLETIN will use that directory as the default +directory to write the file into. + +A user can disable this prompting featuring by using BULLETIN as follows: + +$ BULLETIN +BULLETIN> SET NOREADNEW +BULLETIN> EXIT + +Afterwords, the user will only be alerted of the bulletins, and will have to +use the BULLETIN utility in order to read the messages. +$eod +$copy sys$input WRITEMSG.TXT +$deck +BULLETIN contains subroutines for writing a message directly to a folder. This +would be useful for someone who is using the BBOARD feature, but wants to avoid +the extra overhead of having the message sent to an account as MAIL, and then +have BULLCP read the mail. It is better if the network mail could be written +directly to the folder bypassing VMS MAIL, as it reduces a lot of cpu overhead. + +Call INIT_MESSAGE_ADD to initiate a message addition. +Call WRITE_MESSAGE_LINE to write individual message lines. +Call FINISH_MESSAGE_ADD to complete a message addition. + +Calling formats: + + CALL INIT_MESSAGE_ADD(IN_FOLDER,IN_FROM,IN_DESCRIP,IER) +C +C INPUTS: +C IN_FOLDER - Character string containing folder name +C IN_FROM - Character string containing name of owner of message. +C If empty, the default is the owner of the process. +C IN_DESCRIP - Character string containing subject of message. +C If empty, the message is searched for a line +C which starts with "Subj:" or "Subject:". +C OUTPUTS: +C IER - Error status. True if properly connected to folder. +C False if folder not found. +C + + CALL WRITE_MESSAGE_LINE(BUFFER) +C +C INPUTS: +C BUFFER - Character string containing line to be put into message. +C + + CALL FINISH_MESSAGE_ADD +C +C NOTE: Only should be run if INIT_MESSAGE_ADD was successful. +C +$eod diff --git a/decus/vax89a2/nieland/bulletin/bullet2.com b/decus/vax89a2/nieland/bulletin/bullet2.com new file mode 100644 index 0000000..6a4a6f5 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bullet2.com @@ -0,0 +1,1067 @@ +$set nover +$copy sys$input BOARD_DIGEST.COM +$deck +$! +$! BOARD_DIGEST.COM +$! +$! Command file invoked by folder associated with a BBOARD which is +$! is specified with /SPECIAL. It will convert "digest" mail and +$! split it into separate messages. This type of mail is used in +$! certain Arpanet mailing lists, such as TEXHAX and INFO-MAC. +$! +$ FF[0,8] = 12 ! Define a form feed character +$ SET PROTECT=(W:RWED)/DEFAULT +$ SET PROC/PRIV=SYSPRV +$ USER := 'F$GETJPI("","USERNAME") +$ EXTRACT_FILE = "BULL_DIR:" + "''USER'" + ".TXT" +$ DEFINE/USER EXTRACT_FILE BULL_DIR:'USER' +$ MAIL +READ +EXTRACT EXTRACT_FILE +DELETE +$ OPEN/READ INPUT 'EXTRACT_FILE' +$ OPEN/WRITE OUTPUT 'EXTRACT_FILE' +$ READ INPUT FROM_USER +$AGAIN: +$ READ/END=ERROR INPUT BUFFER +$ IF F$EXTRACT(0,3,BUFFER) .NES. "To:" THEN GOTO SKIP +$ USER = F$EXTRACT(4,F$LEN(BUFFER),BUFFER) +$ GOTO AGAIN1 +$SKIP: +$ IF F$EXTRACT(0,15,BUFFER) .NES. "---------------" THEN GOTO AGAIN +$AGAIN1: +$ READ/END=ERROR INPUT BUFFER +$ IF F$EXTRACT(0,15,BUFFER) .NES. "---------------" THEN GOTO AGAIN1 +$ FROM = " " +$ SUBJ = " " +$NEXT: +$ READ/END=EXIT INPUT BUFFER +$FROM: +$ IF F$EXTRACT(0,5,BUFFER) .NES. "From:" THEN GOTO SUBJECT +$ FROM = BUFFER +$ GOTO NEXT +$SUBJECT: +$ IF F$EXTRACT(0,8,BUFFER) .NES. "Subject:" THEN GOTO NEXT +$ SUBJ = BUFFER - "Subject:" +$F2: +$ IF F$LENGTH(SUBJ) .EQ. 0 THEN GOTO WRITE +$ IF F$EXTRACT(0,1,SUBJ) .NES. " " THEN GOTO WRITE +$ SUBJ = F$EXTRACT(1,F$LENGTH(SUBJ),SUBJ) +$ GOTO F2 +$WRITE: +$ WRITE OUTPUT FROM_USER + ! Write From: + TAB + USERNAME +$ WRITE OUTPUT "To: " + USER + ! Write To: + TAB + BBOARDUSERNAME +$ WRITE OUTPUT "Subj: " + SUBJ + ! Write Subject: + TAB + mail subject +$ WRITE OUTPUT "" ! Write one blank line +$ IF FROM .NES. " " THEN WRITE OUTPUT FROM +$READ: +$ READ/END=EXIT/ERR=EXIT INPUT BUFFER +$ IF F$EXTRACT(0,15,BUFFER) .EQS. "---------------" THEN GOTO READ1 +$ WRITE OUTPUT BUFFER +$ GOTO READ +$READ1: +$ READ/END=EXIT/ERR=EXIT INPUT BUFFER +$ IF F$LOCATE(":",BUFFER) .EQ. F$LENGTH(BUFFER) THEN GOTO READ1 +$ WRITE OUTPUT FF +$ FROM = " " +$ SUBJ = " " +$ GOTO FROM +$EXIT: +$ CLOSE INPUT +$ CLOSE OUTPUT +$ PUR 'EXTRACT_FILE' +$ EXIT +$ERROR: +$ CLOSE INPUT +$ CLOSE OUTPUT +$ DELETE 'EXTRACT_FILE'; +$eod +$copy sys$input BOARD_SPECIAL.COM +$deck +$! +$! BOARD_SPECIAL.COM +$! +$! Command file invoked by folder associated with a BBOARD which is +$! is specified with /SPECIAL. This can be used to convert data to +$! a message via a different means than the VMS mail. This is done by +$! converting the data to look like output created by the MAIL utility, +$! which appears as follows: +$! +$! First line is 0 length line. +$! Second line is "From:" followed by TAB followed by incoming username +$! Third line is "To:" followed by TAB followed by BBOARD username +$! Fourth line is "Subj:" followed by TAB followed by subject +$! The message text then follows. +$! Message is ended by a line containing a FORM FEED. +$! +$! This command file should be put in the BBOARD_DIRECTORY as specified +$! in BULLFILES.INC. You can also have several different types of special +$! procedures. To accomplish this, rename the file to the BBOARD username. +$! i.e. if you specify SET BBOARD FOO/SPECIAL, you could name the file +$! FOO.COM and it will execute that rather than BOARD_SPECIAL.COM. +$! +$! The following routine is the one we use to convert mail from a non-DEC +$! mail network. The output from this mail is written into a file which +$! is slightly different from the type outputted by MAIL. +$! +$! (NOTE: A username in the SET BBOARD command need only be specified if +$! the process which reads the mail requires that the process be owned by +$! a specific user, which is the case for this sample, and for that matter +$! when reading VMS MAIL. If this is not required, you do not have to +$! specify a username.) +$! +$ USERNAME := 'F$GETJPI("","USERNAME")' ! This trims trailing spaces +$ IF F$SEARCH("MFE_TELL_FILES:"+USERNAME+".MAI") .EQS. "" THEN EXIT +$ SET DEFAULT BULL_DIR: ! BULLETIN looks for text in BBOARD directory +$ SET PROTECT=(W:RWED)/DEFAULT +$ IF F$SEARCH("MFEMSG.MAI") .NES. "" THEN - + DELETE MFEMSG.MAI;* ! Delete any leftover output files. +$ MSG := $MFE_TELL: MESSAGE +$ DEFINE/USER SYS$COMMAND SYS$INPUT +$ MSG ! Read MFENET mail +copy * MFEMSG +delete * +exit +$ FF[0,8] = 12 ! Define a form feed character +$ OPEN/READ/ERROR=EXIT INPUT MFEMSG.MAI +$ OUTNAME = USERNAME+".TXT" ! Output file will be 'USERNAME'.TXT +$ OPEN/WRITE OUTPUT 'OUTNAME' +$ READ/END=END INPUT DATA ! Skip first line in MSG output +$HEADER: +$ FROM = "" +$ SUBJ = "" +$ MFEMAIL = "T" +$NEXTHEADER: +$ IF (FROM.NES."") .AND. (SUBJ.NES."") THEN GOTO SKIPHEADER +$ READ/END=END INPUT DATA ! Read header line in MSG output +$ IF DATA .EQS. "" THEN GOTO SKIPHEADER ! Missing From or Subj ?? +$ IF FROM .NES. "" THEN GOTO SKIPFROM +$ IF F$LOCATE("From: ",DATA) .NES. 0 THEN GOTO 10$ +$ MFEMAIL = "F" +$ FROM= F$EXTRACT(6,F$LENGTH(DATA),DATA) +$ GOTO NEXTHEADER +$10$: +$ IF F$LOCATE("Reply-to: ",DATA) .NES. 0 THEN GOTO 20$ +$ MFEMAIL = "F" +$ FROM= F$EXTRACT(10,F$LENGTH(DATA),DATA) +$ GOTO NEXTHEADER +$20$: +$ IF F$LOCATE("From ",DATA) .NES. 0 THEN GOTO SKIPFROM +$ FROM= F$EXTRACT(5,F$LENGTH(DATA),DATA) +$ GOTO NEXTHEADER +$SKIPFROM: +$ IF SUBJ .NES. "" THEN GOTO SKIPSUBJ +$ IF F$LOCATE("Subject",DATA) .NES. 0 THEN GOTO SKIPSUBJ +$ SUBJ= F$EXTRACT(F$LOCATE(": ",DATA)+2,F$LENGTH(DATA),DATA) +$ GOTO NEXTHEADER +$SKIPSUBJ: +$ GOTO NEXTHEADER +$SKIPHEADER: +$ WRITE OUTPUT "From: " + FROM + ! Write From: + TAB + USERNAME +$ WRITE OUTPUT "To: " + USERNAME + ! Write To: + TAB + BBOARDUSERNAME +$ WRITE OUTPUT "Subj: " + SUBJ + ! Write Subject: + TAB + mail subject +$ WRITE OUTPUT "" ! Write one blank line +$ IF (DATA.EQS."") .OR. MFEMAIL THEN GOTO SKIPBLANKS +$50$: +$ READ/END=END INPUT DATA ! Skip rest of main header +$ IF DATA .NES. "" THEN GOTO 50$ +$60$: +$ READ/END=END INPUT DATA ! Skip all of secondary header +$ IF DATA .NES. "" THEN GOTO 60$ +$SKIPBLANKS: +$ READ/END=END INPUT DATA ! Skip all blanks +$ IF DATA .EQS. "" THEN GOTO SKIPBLANKS +$NEXT: ! Read and write message text +$ WRITE OUTPUT DATA +$ IF DATA .EQS. FF THEN GOTO HEADER + ! Multiple messages are seperated by form feeds +$ READ/END=END INPUT DATA +$ GOTO NEXT +$END: +$ CLOSE INPUT +$ CLOSE OUTPUT +$ DELETE MFEMSG.MAI; +$EXIT: +$ EXIT +$eod +$copy sys$input BULLCOM.CLD +$deck +! +! BULLCOM.CLD +! +! VERSION 5/26/89 +! + MODULE BULLETIN_SUBCOMMANDS + + DEFINE VERB ADD + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER ALL, NONNEGATABLE + QUALIFIER BELL, NONNEGATABLE + QUALIFIER BROADCAST, NONNEGATABLE + DISALLOW NOT BROADCAST AND ALL + DISALLOW NOT BROADCAST AND BELL + QUALIFIER CLUSTER, DEFAULT + QUALIFIER EDIT, NEGATABLE + QUALIFIER EXPIRATION, NONNEGATABLE, VALUE + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER NODES, LABEL=NODES, VALUE(REQUIRED,LIST) + NONNEGATABLE + QUALIFIER LOCAL, NONNEGATABLE + DISALLOW LOCAL AND NOT BROADCAST + DISALLOW NODES AND SELECT_FOLDER + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT TEXT + QUALIFIER PERMANENT, NONNEGATABLE + QUALIFIER SHUTDOWN, NONNEGATABLE + DISALLOW PERMANENT AND SHUTDOWN + QUALIFIER SUBJECT, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER SYSTEM, NONNEGATABLE + QUALIFIER TEXT, NONNEGATABLE + DISALLOW TEXT AND NOT EDIT + DISALLOW TEXT AND FILESPEC + QUALIFIER USERNAME, LABEL=USERNAME, VALUE(REQUIRED) + NONNEGATABLE + DEFINE VERB BACK + DEFINE VERB CHANGE + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER EDIT, NEGATABLE + QUALIFIER EXPIRATION, NONNEGATABLE, VALUE + QUALIFIER GENERAL, NONNEGATABLE + QUALIFIER HEADER, NONNEGATABLE + QUALIFIER SUBJECT, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER NEW,NONNEGATABLE + QUALIFIER NUMBER, VALUE(TYPE=$NUMBER,REQUIRED) + QUALIFIER PERMANENT, NONNEGATABLE + QUALIFIER SHUTDOWN, NONNEGATABLE + QUALIFIER SYSTEM,NONNEGATABLE + QUALIFIER TEXT, NONNEGATABLE + DISALLOW NEW AND NOT EDIT + DISALLOW SYSTEM AND GENERAL + DISALLOW PERMANENT AND SHUTDOWN + DISALLOW PERMANENT AND EXPIRATION + DISALLOW SHUTDOWN AND EXPIRATION + DISALLOW SUBJECT AND HEADER + DEFINE VERB COPY + PARAMETER P1, LABEL=FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER MERGE + QUALIFIER ORIGINAL + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB CREATE + QUALIFIER BRIEF, NONNEGATABLE + QUALIFIER DESCRIPTION, NONNEGATABLE, VALUE(REQUIRED) +! +! Make the following qualifier DEFAULT if you want CREATE to be +! a privileged command. NOTE: Make sure that BULL_DIR:BULLUSER.DAT +! has the following protection: (RWED,RWED,,) +! + QUALIFIER NEEDPRIV, NONNEGATABLE + QUALIFIER NODE, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER NOTIFY, NONNEGATABLE + QUALIFIER OWNER, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER PRIVATE, NONNEGATABLE + QUALIFIER READNEW, NONNEGATABLE + QUALIFIER REMOTENAME, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER SEMIPRIVATE, NONNEGATABLE + QUALIFIER SHOWNEW, NONNEGATABLE + QUALIFIER SYSTEM, NONNEGATABLE + PARAMETER P1, LABEL=CREATE_FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + DISALLOW PRIVATE AND SEMIPRIVATE + DISALLOW BRIEF AND READNEW + DISALLOW SHOWNEW AND READNEW + DISALLOW BRIEF AND SHOWNEW + DISALLOW NODE AND (NOTIFY OR PRIVATE OR SEMIPRIVATE) + DEFINE VERB CURRENT + QUALIFIER EDIT + DEFINE VERB DELETE + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER IMMEDIATE,NONNEGATABLE + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER NODES, LABEL=NODES, VALUE(REQUIRED,LIST) + QUALIFIER USERNAME, LABEL=USERNAME, VALUE(REQUIRED) + QUALIFIER SUBJECT, VALUE(REQUIRED) + DISALLOW NOT SUBJECT AND (NODES OR SELECT_FOLDER) + DISALLOW NODES AND SELECT_FOLDER + DEFINE VERB DIRECTORY + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER FOLDER, SYNTAX=DIRECTORY_FOLDER, NONNEGATABLE + QUALIFIER NEW + QUALIFIER START, VALUE(REQUIRED,TYPE=$NUMBER), NONNEGATABLE + QUALIFIER SINCE,VALUE(DEFAULT="TODAY",TYPE=$DATETIME) + QUALIFIER MARKED, NONNEGATABLE + DISALLOW (NEW AND SINCE) OR (START AND NEW) OR (START AND SINCE) + DEFINE SYNTAX DIRECTORY_FOLDER + QUALIFIER DESCRIBE + QUALIFIER FOLDER, DEFAULT + DEFINE VERB E ! EXIT command. + DEFINE VERB EX ! EXIT command. + DEFINE VERB EXIT ! EXIT command. + DEFINE VERB EXTRACT + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE,REQUIRED), + PROMPT="File" + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER HEADER, DEFAULT + QUALIFIER NEW, NONNEGATABLE + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB FILE + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE,REQUIRED), + PROMPT="File" + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER HEADER, DEFAULT + QUALIFIER NEW, NONNEGATABLE + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB HELP + PARAMETER P1, LABEL=HELP_FOLDER, VALUE(TYPE=$REST_OF_LINE) + DEFINE VERB INDEX + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER MARKED + QUALIFIER FOLDER, SYNTAX=DIRECTORY_FOLDER, NONNEGATABLE + QUALIFIER NEW + QUALIFIER RESTART + QUALIFIER START, VALUE(REQUIRED,TYPE=$NUMBER), NONNEGATABLE + QUALIFIER SINCE,VALUE(DEFAULT="TODAY",TYPE=$DATETIME) + DISALLOW (NEW AND SINCE) OR (START AND NEW) OR (START AND SINCE) + DEFINE VERB LAST + DEFINE VERB MAIL + PARAMETER P1, LABEL=RECIPIENTS, PROMPT="Recipients" + VALUE(REQUIRED,IMPCAT,LIST) + QUALIFIER HEADER, DEFAULT + QUALIFIER SUBJECT, VALUE(REQUIRED) + DEFINE VERB MODIFY + QUALIFIER DESCRIPTION + QUALIFIER NAME, VALUE(REQUIRED) + QUALIFIER OWNER, VALUE(REQUIRED) + DEFINE VERB MOVE + PARAMETER P1, LABEL=FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER MERGE + QUALIFIER NODES + QUALIFIER ORIGINAL + QUALIFIER IMMEDIATE,NONNEGATABLE,DEFAULT + DISALLOW ALL AND BULLETIN_NUMBER + DISALLOW FOLDER AND NODES + DEFINE VERB NEXT + DEFINE VERB POST + QUALIFIER CC, VALUE(LIST,REQUIRED) + QUALIFIER LIST, DEFAULT + QUALIFIER SUBJECT, VALUE(REQUIRED) + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT TEXT + QUALIFIER TEXT + QUALIFIER EDIT + DISALLOW TEXT AND NOT EDIT + DEFINE VERB PRINT + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER HEADER, DEFAULT + QUALIFIER NOTIFY, DEFAULT + QUALIFIER QUEUE, VALUE(DEFAULT=SYS$PRINT), NONNEGATABLE + QUALIFIER FORM, VALUE, NONNEGATABLE + QUALIFIER ALL + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB QUIT + DEFINE VERB READ + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$NUMBER) + QUALIFIER EDIT + QUALIFIER MARKED, NONNEGATABLE + QUALIFIER NEW + QUALIFIER PAGE, DEFAULT + QUALIFIER SINCE,VALUE(DEFAULT="TODAY",TYPE=$DATETIME) + DISALLOW NEW AND SINCE + DEFINE VERB REPLY + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER ALL, NONNEGATABLE + QUALIFIER BELL, NONNEGATABLE + QUALIFIER BROADCAST, NONNEGATABLE + DISALLOW NOT BROADCAST AND ALL + DISALLOW NOT BROADCAST AND BELL + QUALIFIER CLUSTER, DEFAULT + QUALIFIER EDIT, NEGATABLE + QUALIFIER EXPIRATION, NONNEGATABLE, VALUE + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER NODES, LABEL=NODES, VALUE(REQUIRED,LIST) + NONNEGATABLE + QUALIFIER LOCAL + DISALLOW LOCAL AND NOT BROADCAST + DISALLOW NODES AND SELECT_FOLDER + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT TEXT + QUALIFIER PERMANENT, NONNEGATABLE + QUALIFIER SHUTDOWN, NONNEGATABLE + DISALLOW PERMANENT AND SHUTDOWN + QUALIFIER SUBJECT, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER SYSTEM, NONNEGATABLE + QUALIFIER TEXT, NONNEGATABLE + DISALLOW TEXT AND NOT EDIT + DISALLOW TEXT AND FILESPEC + QUALIFIER USERNAME, LABEL=USERNAME, VALUE(REQUIRED) + NONNEGATABLE + DEFINE VERB REMOVE + PARAMETER P1, LABEL=REMOVE_FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + DEFINE VERB RESPOND + QUALIFIER CC, VALUE(LIST,REQUIRED) + QUALIFIER LIST + QUALIFIER SUBJECT, VALUE(REQUIRED) + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT TEXT + QUALIFIER TEXT + QUALIFIER EDIT + DISALLOW TEXT AND NOT EDIT + DEFINE VERB SEARCH + PARAMETER P1, LABEL=SEARCH_STRING + QUALIFIER START, VALUE(TYPE=$NUMBER,REQUIRED) + QUALIFIER SUBJECT + DEFINE VERB SELECT + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER MARKED, NONNEGATABLE + DEFINE VERB SET + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + QUALIFIER ID + DEFINE TYPE SET_OPTIONS + KEYWORD NODE, SYNTAX=SET_NODE + KEYWORD NONODE, SYNTAX = SET_NONODE + KEYWORD EXPIRE_LIMIT, SYNTAX=SET_EXPIRE + KEYWORD NOEXPIRE_LIMIT + KEYWORD GENERIC, SYNTAX=SET_GENERIC + KEYWORD NOGENERIC, SYNTAX=SET_GENERIC + KEYWORD LOGIN, SYNTAX=SET_LOGIN + KEYWORD NOLOGIN, SYNTAX=SET_LOGIN + KEYWORD NOBBOARD + KEYWORD BBOARD, SYNTAX=SET_BBOARD + KEYWORD NOBRIEF, SYNTAX=SET_NOFLAGS + KEYWORD BRIEF, SYNTAX=SET_FLAGS + KEYWORD NOSHOWNEW, SYNTAX=SET_NOFLAGS + KEYWORD SHOWNEW, SYNTAX=SET_FLAGS + KEYWORD NOREADNEW, SYNTAX=SET_NOFLAGS + KEYWORD READNEW, SYNTAX=SET_FLAGS + KEYWORD ACCESS, SYNTAX=SET_ACCESS + KEYWORD NOACCESS, SYNTAX=SET_NOACCESS + KEYWORD FOLDER, SYNTAX=SET_FOLDER + KEYWORD NOTIFY, SYNTAX=SET_FLAGS + KEYWORD NONOTIFY, SYNTAX=SET_NOFLAGS + KEYWORD PRIVILEGES, SYNTAX=SET_PRIVILEGES + KEYWORD DUMP + KEYWORD NODUMP + KEYWORD PAGE + KEYWORD NOPAGE + KEYWORD SYSTEM + KEYWORD NOSYSTEM + KEYWORD KEYPAD + KEYWORD NOKEYPAD + KEYWORD PROMPT_EXPIRE + KEYWORD NOPROMPT_EXPIRE + KEYWORD DEFAULT_EXPIRE, SYNTAX=SET_DEFAULT_EXPIRE + KEYWORD STRIP + KEYWORD NOSTRIP + KEYWORD DIGEST + KEYWORD NODIGEST + DEFINE SYNTAX SET_NODE + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=NODENAME, VALUE(REQUIRED) + PARAMETER P3, LABEL=REMOTENAME + QUALIFIER FOLDER, VALUE(REQUIRED) + DEFINE SYNTAX SET_NONODE + QUALIFIER FOLDER, VALUE(REQUIRED) + DEFINE SYNTAX SET_EXPIRE + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=EXPIRATION, VALUE(TYPE=$NUMBER,REQUIRED) + DEFINE SYNTAX SET_GENERIC + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=USERNAME, VALUE(REQUIRED) + QUALIFIER DAYS,VALUE(TYPE=$NUMBER,DEFAULT="7"),DEFAULT + DEFINE SYNTAX SET_LOGIN + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=USERNAME, VALUE(REQUIRED) + DEFINE SYNTAX SET_FLAGS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + QUALIFIER DEFAULT, NONNEGATABLE + QUALIFIER ALL, NONNEGATABLE + QUALIFIER CLUSTER, DEFAULT + QUALIFIER FOLDER, VALUE(REQUIRED) + DISALLOW NOT ALL AND NOT DEFAULT AND CLUSTER + DISALLOW ALL AND DEFAULT + DEFINE SYNTAX SET_NOFLAGS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + QUALIFIER DEFAULT, NONNEGATABLE + QUALIFIER ALL, NONNEGATABLE + QUALIFIER FOLDER, VALUE(REQUIRED) + DISALLOW ALL AND DEFAULT + DEFINE SYNTAX SET_BBOARD + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=BB_USERNAME + QUALIFIER EXPIRATION, VALUE(TYPE=$NUMBER) + LABEL=EXPIRATION, DEFAULT + QUALIFIER SPECIAL, NONNEGATABLE + QUALIFIER VMSMAIL, NONNEGATABLE + DISALLOW VMSMAIL AND NOT SPECIAL + DISALLOW VMSMAIL AND NOT BB_USERNAME + DEFINE SYNTAX SET_FOLDER + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=SELECT_FOLDER + QUALIFIER MARKED, NONNEGATABLE + DEFINE SYNTAX SET_NOACCESS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=ACCESS_ID, VALUE(LIST) + PARAMETER P3, LABEL=ACCESS_FOLDER + QUALIFIER ALL, NONNEGATABLE + QUALIFIER READONLY, NONNEGATABLE + DISALLOW NOT ALL AND NOT ACCESS_ID + DISALLOW ALL AND NOT READONLY + DEFINE SYNTAX SET_ACCESS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=ACCESS_ID, VALUE(LIST) + PARAMETER P3, LABEL=ACCESS_FOLDER + QUALIFIER READONLY, NONNEGATABLE + QUALIFIER ALL, NONNEGATABLE + DISALLOW NOT ALL AND NOT ACCESS_ID + DEFINE SYNTAX SET_PRIVILEGES + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=PRIVILEGES, PROMPT="Privileges" + VALUE (REQUIRED,LIST) + DEFINE SYNTAX SET_DEFAULT_EXPIRE + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=DEFAULT_EXPIRE, VALUE(TYPE=$NUMBER,REQUIRED) + DEFINE VERB SHOW + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) +! +! The following are defined to allow qualifiers to be specified +! directly after the SHOW command, i.e. SHOW/FULL FOLDER. +! Otherwise, the CLI routines will reject the command, because it +! first attempts to process the qualifier before process the parameter, +! so it has no information the qualifiers are valid. +! + QUALIFIER FULL, SYNTAX=SHOW_FOLDER_FULL, NONNEGATABLE + QUALIFIER ALL, SYNTAX=SHOW_USER + QUALIFIER LOGIN, SYNTAX=SHOW_USER + QUALIFIER NOLOGIN, SYNTAX=SHOW_USER + QUALIFIER PRINT, SYNTAX=SHOW_KEYPAD_PRINT + DEFINE TYPE SHOW_OPTIONS + KEYWORD FOLDER, SYNTAX=SHOW_FOLDER + KEYWORD NEW, SYNTAX=SHOW_FLAGS + KEYWORD PRIVILEGES, SYNTAX=SHOW_FLAGS + KEYWORD FLAGS, SYNTAX=SHOW_FLAGS + KEYWORD KEYPAD, SYNTAX=SHOW_KEYPAD + KEYWORD USER, SYNTAX=SHOW_USER + KEYWORD VERSION + DEFINE SYNTAX SHOW_FLAGS + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + DEFINE SYNTAX SHOW_KEYPAD + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + QUALIFIER PRINT + DEFINE SYNTAX SHOW_KEYPAD_PRINT + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + QUALIFIER PRINT,DEFAULT + DEFINE SYNTAX SHOW_FOLDER + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + PARAMETER P2, LABEL=SHOW_FOLDER + DEFINE SYNTAX SHOW_USER + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + PARAMETER P2, LABEL=USERNAME + QUALIFIER ALL + QUALIFIER LOGIN + QUALIFIER NOLOGIN + DISALLOW (NOLOGIN OR LOGIN OR ALL) AND USERNAME + DISALLOW (LOGIN AND NOLOGIN) + DEFINE SYNTAX SHOW_FOLDER_FULL + QUALIFIER FULL, DEFAULT + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + PARAMETER P2, LABEL=SHOW_FOLDER + DEFINE VERB MARK + PARAMETER P1, LABEL=NUMBER, VALUE(LIST,TYPE=$NUMBER) + DEFINE VERB SPAWN + PARAMETER P1, LABEL=COMMAND, VALUE(TYPE=$REST_OF_LINE) + DEFINE VERB UNMARK + PARAMETER P1, LABEL=NUMBER, VALUE(LIST,TYPE=$NUMBER) + DEFINE VERB UNDELETE + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) +$eod +$copy sys$input BULLETIN.CLD +$deck +! +! This file is the CLD file used to define a command to execute +! BULLETIN by using CDU, which adds the command to the command table. +! The alternative is to define a symbol to execute BULLETIN. +! Either way will work, and it is up to the user's to decide which +! method to work. (If you don't know which, you probably should use +! the default symbol method.) +! + +Define Verb BULLETIN + Image BULL_DIR:BULLETIN + Parameter P1, Label = SELECT_FOLDER + Qualifier BBOARD + Qualifier BULLCP + Qualifier CLEANUP, Value (Required) + Qualifier EDIT + Qualifier KEYPAD + Qualifier LOGIN + Qualifier MARKED + Qualifier PAGE, Default + Qualifier PROMPT, Value (Default = "BULLETIN"), Default + Qualifier READNEW + Qualifier REVERSE + ! + ! The following line causes a line to be outputted separating system notices. + ! The line consists of a line of all "-"s, i.e.: + !-------------------------------------------------------------------------- + ! If you want a different character to be used, simply put in the desired one + ! in the following line. If you want to disable the feature, remove the + ! Default at the end of the line. (Don't remove the whole line!) + ! + Qualifier SEPARATE, Value (Default = "-"), Default + Qualifier STARTUP + Qualifier STOP + Qualifier SYSTEM, Value (Type = $NUMBER, Default = "7") +$eod +$copy sys$input BULLETIN.COM +$deck +$ DEFINE SYS$INPUT SYS$NET +$ BULLETIN +$eod +$copy sys$input BULLMAIN.CLD +$deck + MODULE BULLETIN_MAINCOMMANDS + DEFINE VERB BULLETIN + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER BBOARD + QUALIFIER BULLCP + QUALIFIER CLEANUP, LABEL=CLEANUP, VALUE(REQUIRED) + QUALIFIER EDIT + QUALIFIER KEYPAD + QUALIFIER LOGIN + QUALIFIER MARKED + QUALIFIER PAGE, DEFAULT + QUALIFIER READNEW + QUALIFIER REVERSE +! +! The following line causes a line to be outputted separating system notices. +! The line consists of a line of all "-"s, i.e.: +!-------------------------------------------------------------------------- +! If you want a different character to be used, simply put in the desired one +! in the following line. If you want to disable the feature, remove the +! DEFAULT at the end of the line. (Don't remove the whole line!) +! + QUALIFIER SEPARATE, VALUE(DEFAULT="-"), DEFAULT + QUALIFIER STARTUP + QUALIFIER STOP + QUALIFIER SYSTEM, VALUE(TYPE=$NUMBER,DEFAULT="7") +$eod +$copy sys$input BULLSTART.COM +$deck +$ RUN SYS$SYSTEM:INSTALL +BULL_DIR:BULLETIN/SHAR/OPEN/HEAD/- +PRIV=(OPER,SYSPRV,CMKRNL,WORLD,DETACH,PRMMBX,SYSNAM) +/EXIT +$ BULL*ETIN :== $BULL_DIR:BULLETIN +$ BULLETIN/STARTUP +$eod +$copy sys$input CREATE.COM +$deck +$ FORTRAN/EXTEND BULLETIN +$ FORTRAN/EXTEND BULLETIN0 +$ FORTRAN/EXTEND BULLETIN1 +$ FORTRAN/EXTEND BULLETIN2 +$ FORTRAN/EXTEND BULLETIN3 +$ FORTRAN/EXTEND BULLETIN4 +$ FORTRAN/EXTEND BULLETIN5 +$ FORTRAN/EXTEND BULLETIN6 +$ FORTRAN/EXTEND BULLETIN7 +$ FORTRAN/EXTEND BULLETIN8 +$ FORTRAN/EXTEND BULLETIN9 +$ MAC ALLMACS +$ SET COMMAND/OBJ BULLCOM +$ SET COMMAND/OBJ BULLMAIN +$ IF F$SEARCH("BULL.OLB") .NES. "" THEN DELETE BULL.OLB; +$ IF F$SEARCH("BULL.OLB") .EQS. "" THEN LIB/CREATE BULL +$ LIB BULL *.OBJ; +$ DELETE *.OBJ;* +$ @BULLETIN.LNK +$eod +$copy sys$input DCLREMOTE.COM +$deck +$! DCL procedure to execute DCL commands passed over Decnet on a remote system. +$! Commands sent by the command procedure REMOTE.COM on the local system are +$! are received by this procedure on the remote node. +$! This procedure is usually a DECNET OBJECT with task name DCLREMOTE and +$! normally resides in the default DECNET account. To install as an object, +$! enter NCP, and then use the command: +$! NCP> SET OBJECT DCLREMOTE FILE file-spec NUM 0 +$! where file-spec includes the disk, directory, and file name of the file. +$! If DCLREMOTE is not installed as an object, the logical name DCLREMOTE can +$! be defined to point at it. +$! +$! Alternativley, DCLREMOTE.COM could be placed in the directory of the user's +$! proxy login on the remote system. +$! +$! WARNING: An EXIT command must not be passed as a command to execute at this +$! procedure level or the link will hang. +$! +$ SET NOON +$ N = 0 +$AGAIN: +$ N = N + 1 +$ IF N .GE. 5 THEN GOTO DONE +$ OPEN/WRITE/READ/ERR=AGAIN NET SYS$NET +$ DEFINE /NOLOG SYS$OUTPUT NET +$ DEFINE /NOLOG SYS$ERROR NET +$NEXT_CMD: +$ READ /ERR=DONE NET COMMAND +$ 'COMMAND' +$ WRITE/ERR=DONE SYS$OUTPUT "COMMAND$DONE ''$STATUS'" +$ GOTO NEXT_CMD +$DONE: +$ CLOSE NET +$eod +$copy sys$input INSTALL.COM +$deck +$ COPY BULLETIN.EXE BULL_DIR: +$ RUN SYS$SYSTEM:INSTALL +BULL_DIR:BULLETIN/DEL +BULL_DIR:BULLETIN/SHAR/OPEN/HEAD/- +PRIV=(OPER,SYSPRV,CMKRNL,WORLD,DETACH,PRMMBX,SYSNAM) +/EXIT +$! +$! NOTE: BULLETIN requires a separate help library. If you do not wish +$! the library to be placed in SYS$HELP, modify the following lines and +$! define the logical name BULL_HELP to be the help library directory, i.e. +$! $ DEFINE/SYSTEM BULL_HELP SYSD$:[NEWDIRECTORY] +$! The above line should be placed in BULLSTART.COM to be executed after +$! every system reboot. +$! +$ IF F$SEARCH("SYS$HELP:BULL.HLB") .NES. "" THEN LIB/DELETE=*/HELP SYS$HELP:BULL +$ IF F$SEARCH("SYS$HELP:BULL.HLB") .EQS. "" THEN LIB/CREATE/HELP SYS$HELP:BULL +$ LIB/HELP SYS$HELP:BULL BULLCOMS1,BULLCOMS2 +$ LIB/HELP SYS$HELP:HELPLIB BULLETIN +$eod +$copy sys$input INSTALL_REMOTE.COM +$deck +$! +$! INSTALL_REMOTE.COM +$! VERSION 5/25/88 +$! +$! DESCRIPTION: +$! Command procedure to easily install BULLETIN.EXE on several nodes. +$! +$! INPUTS: +$! The following parameters can be added to the command line. They +$! should be placed on the command line which executes this command +$! procedure, separated by spaces. I.e. @INSTALL_REMOTE.COM OLD COPY TEST +$! +$! OLD - Specifies that the present version of BULLETIN is 1.51 or earlier. +$! COPY - Specifies that the executable is to be copied to the nodes. +$! TEST - Specifies that all the nodes are to be checked to see if they +$! are up before beginning the intallation. +$! +$! NOTES: +$! ***PLEASE READ ALL COMMENTS BEFORE RUNNING THIS*** +$! This calls REMOTE.COM which is also included with the installation. +$! +$! DCLREMOTE.COM must be properly installed on all nodes. +$! See comments at the beginning of that file for instructions. +$! Also, you need to have a proxy login with privileges on those nodes. +$! This procedure assumes that the BULLETIN executable on each node is +$! located in the BULL_DIR directory. The new executable should be copied +$! to that directory before running this procedure, or the COPY option +$! should be used. +$! +$! If the present version of BULLETIN is 1.51 or earlier, it does not have +$! the ability of setting BULL_DISABLE to disable BULLETIN, so you should +$! use the OLD parameter when running this procedure. +$! +$! INSTRUCTIONS FOR SPECIFYING THE NODES AT YOUR SITE: +$! Place the nodes where bulletin is to be reinstalled in variable NODES. +$! Place the nodes where the executable is to be copied to in COPY_NODES. +$! Place nodes where BULLCP is running in BULLCP_NODES. +$! +$ NODES = "ALCVAX,NERUS,ANANSI,MOLVAX,LAURIE,CANDLE,KLYPSO,DOME" +- +",ARVON,LARAN,ORYANA,PALDAR,MOTHRA,TARNA,DARIUS" +$ COPY_NODES = "NERUS,LAURIE,ARVON" +$ BULLCP_NODES = "NERUS,LAURIE,ARVON" +$! +$ NODES = NODES + "," +$ COPY_NODES = COPY_NODES + "," +$ BULLCP_NODES = BULLCP_NODES + "," +$! +$! Check for any parameters passed to the command procedure. +$! +$ PARAMETER = P1 + P2 + P3 +$ OLD = 0 +$ IF F$LOCATE("OLD",PARAMETER) .NE. F$LENGTH(PARAMETER) THEN OLD = 1 +$ TEST = 0 +$ IF F$LOCATE("TEST",PARAMETER) .NE. F$LENGTH(PARAMETER) THEN TEST = 1 +$ COPYB = 0 +$ IF F$LOCATE("COPY",PARAMETER) .NE. F$LENGTH(PARAMETER) THEN COPYB = 1 +$! +$! If TEST requested, see if nodes are accessible. +$! +$ IF .NOT. TEST THEN GOTO END_TEST +$BEGIN_TEST: +$ NODES1 = NODES +$TEST: +$ IF F$LEN(NODES1) .EQ. 0 THEN GOTO END_TEST +$ NODE = F$EXTRACT(0,F$LOCATE(",",NODES1),NODES1) +$ NODES1 = NODES1 - NODE - "," +$ @REMOTE 'NODE' END +$ GOTO TEST +$END_TEST: +$! +$! If COPY requested, copy executable to nodes. +$! +$ IF .NOT. COPYB THEN GOTO END_COPY +$COPY: +$ IF F$LEN(COPY_NODES) .EQ. 0 THEN GOTO END_COPY +$ NODE = F$EXTRACT(0,F$LOCATE(",",COPY_NODES),COPY_NODES) +$ COPY_NODES = COPY_NODES - NODE - "," +$ COPY BULLETIN.EXE 'NODE'::BULL_DIR: +$ GOTO COPY +$END_COPY: +$! +$! The procedure now goes to each node and disables bulletin and kills +$! the BULLCP process if present. NOTE: If version is < 1.51, we assume +$! that BULLCP is running under SYSTEM account. This is not necessary +$! for older versions where the BULLETIN/STOP command can be used. +$! If BULLCP is not running under the SYSTEM account for version 1.51 +$! or less, you will have to kill them manually before running this! +$! +$BEGIN_DISABLE: +$ NODES1 = NODES +$DISABLE: +$ IF F$LEN(NODES1) .EQ. 0 THEN GOTO END_DISABLE +$ NODE = F$EXTRACT(0,F$LOCATE(",",NODES1),NODES1) +$ NODES1 = NODES1 - NODE - "," +$ @REMOTE 'NODE' CONTINUE SET PROC/PRIV=ALL +$ IF F$LOCATE(","+NODE+",",","+BULLCP_NODES) .EQ. - + F$LENGTH(","+BULLCP_NODES) THEN GOTO SKIP_STOP_BULLCP +$ IF OLD THEN @REMOTE 'NODE' CONTINUE SET UIC [SYSTEM] +$ IF OLD THEN @REMOTE 'NODE' CONTINUE STOP BULLCP +$ IF .NOT. OLD THEN @REMOTE 'NODE' CONTINUE BULLETIN := $BULL_DIR:BULLETIN +$ IF .NOT. OLD THEN @REMOTE 'NODE' CONTINUE BULLETIN/STOP +$SKIP_STOP_BULLCP: +$ @REMOTE 'NODE' CONTINUE INS := $SYS$SYSTEM:INSTALL +$ IF OLD THEN @REMOTE 'NODE' END INS BULL_DIR:BULLETIN/DELETE +$ IF .NOT. OLD THEN @REMOTE 'NODE' END DEF/SYSTEM BULL_DISABLE DISABLE +$ GOTO DISABLE +$END_DISABLE: +$! +$! The procedure now installs the new BULLETIN. +$! +$ NODES1 = NODES +$INSTALL: +$ IF F$LEN(NODES1) .EQ. 0 THEN EXIT +$ NODE = F$EXTRACT(0,F$LOCATE(",",NODES1),NODES1) +$ NODES1 = NODES1 - NODE - "," +$ @REMOTE 'NODE' CONTINUE SET PROC/PRIV=ALL +$ @REMOTE 'NODE' CONTINUE INS := $SYS$SYSTEM:INSTALL +$ @REMOTE 'NODE' CONTINUE BULLETIN := $BULL_DIR:BULLETIN +$ IF OLD THEN @REMOTE 'NODE' CONTINUE INS BULL_DIR:BULLETIN/SHAR- +/OPEN/HEAD/PRIV=(OPER,SYSPRV,CMKRNL,WORLD,DETACH,PRMMBX,SYSNAM) +$ IF .NOT. OLD THEN @REMOTE 'NODE' CONTINUE INS BULL_DIR:BULLETIN/REPLACE +$ IF .NOT. OLD THEN @REMOTE 'NODE' CONTINUE DEASS/SYSTEM BULL_DISABLE +$ IF F$LOCATE(","+NODE+",",","+BULLCP_NODES) .EQ. - + F$LENGTH(","+BULLCP_NODES) THEN GOTO SKIP_START_BULLCP +$ @REMOTE 'NODE' CONTINUE SET UIC [SYSTEM] +$ @REMOTE 'NODE' CONTINUE BULLETIN := $BULL_DIR:BULLETIN" +$ @REMOTE 'NODE' CONTINUE BULLETIN/START +$SKIP_START_BULLCP: +$ @REMOTE 'NODE' END CONTINUE +$ GOTO INSTALL +$eod +$copy sys$input INSTRUCT.COM +$deck +$ BULLETIN +ADD/PERMANENT/SYSTEM INSTRUCT.TXT +INFO ON HOW TO USE THE BULLETIN UTILITY. +ADD/PERMANENT NONSYSTEM.TXT +INFO ON BEING PROMPTED TO READ NON-SYSTEM BULLETINS. +EXIT +$eod +$copy sys$input LOGIN.COM +$deck +$! +$! The following line defines the BULLETIN command. +$! +$ BULL*ETIN :== $BULL_DIR:BULLETIN +$! +$! Note: The command prompt when executing the utility is named after +$! the executable image. Thus, as it is presently set up, the prompt +$! will be "BULLETIN>". DO NOT make the command that executes the +$! image different from the image name, or certain things will break. +$! +$! If you would rather define the BULLETIN command using CDU rather than +$! defining it using a symbol, use the BULLETIN.CLD file to do so. +$! +$! The following line causes new messages to be displayed upon logging in. +$! +$ BULLETIN/LOGIN/REVERSE +$! +$! If you wish bulletins to be displayed starting with +$! the newest rather the oldest, omit the /REVERSE qualifier. +$! Note that for totally new users, only permanent system messages and +$! the first non-system general message is displayed (which, if you ran +$! INSTURCT.COM, would describe what a non-system message is). +$! This is done so as to avoid overwhelming a new user with lots of +$! messages upon logging in for the first time. +$! +$eod +$copy sys$input MAKEFILE. +$deck +# Makefile for BULLETIN + +Bulletin : Bulletin.Exe Bull.Hlb + +Bulletin.Exe : Bull.Olb + Link /NoTrace Bull.Olb/Lib /Inc=Bulletin$Main,Sys$System:Sys.Stb/Sel - + /NoUserlib /Exe=Bulletin.Exe + +Bull.Olb : Bulletin.Obj Bulletin0.Obj Bulletin1.Obj Bulletin2.Obj \ + Bulletin3.Obj Bulletin4.Obj Bulletin5.Obj Bulletin6.Obj \ + Bulletin7.Obj Bulletin8.Obj Bulletin9.Obj \ + Bullcom.Obj Bullmain.Obj Allmacs.Obj + Library /Create Bull.Olb *.Obj + Purge /Log *.Obj,*.Exe + +Bulletin.Obj : Bulletin.For Bullfiles.Inc Bulldir.Inc Bullfolder.Inc \ + Bulluser.Inc + Fortran /Extend /NoList Bulletin.For + +Bulletin0.Obj : Bulletin0.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc + Fortran /Extend /NoList Bulletin0.For + +Bulletin1.Obj : Bulletin1.For Bulldir.Inc Bullfolder.Inc Bulluser.Inc \ + Bullfiles.Inc + Fortran /Extend /NoList Bulletin1.For + +Bulletin2.Obj : Bulletin2.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc + Fortran /Extend /NoList Bulletin2.For + +Bulletin3.Obj : Bulletin3.For Bulldir.Inc Bullfolder.Inc Bulluser.Inc \ + Bullfiles.Inc + Fortran /Extend /NoList Bulletin3.For + +Bulletin4.Obj : Bulletin4.For Bullfolder.Inc Bulluser.Inc Bullfiles.Inc \ + Bulldir.Inc + Fortran /Extend /NoList Bulletin4.For + +Bulletin5.Obj : Bulletin5.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc + Fortran /Extend /NoList Bulletin5.For + +Bulletin6.Obj : Bulletin6.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc + Fortran /Extend /NoList Bulletin6.For + +Bulletin7.Obj : Bulletin7.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc + Fortran /Extend /NoList Bulletin7.For + +Bulletin8.Obj : Bulletin8.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc + Fortran /Extend /NoList Bulletin8.For + +Bulletin9.Obj : Bulletin9.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc + Fortran /Extend /NoList Bulletin9.For + +Allmacs.Obj : Allmacs.mar + Macro /NoList Allmacs.Mar + +Bullcom.Obj : Bullcom.cld + Set Command /Obj Bullcom.Cld + +Bullmain.Obj : Bullmain.cld + Set Command /Obj Bullmain.Cld + +Bull.Hlb : Bullcoms1.Hlp Bullcoms2.Hlp + Library /Create /Help Bull.Hlb Bullcoms1.Hlp, Bullcoms2.Hlp + Purge Bull.Hlb +*.hlb : + lib/help/cre $* + +$eod +$copy sys$input REMOTE.COM +$deck +$! FILE: REMOTE.COM VERSION 1.3 EDIT 880513 - CAK +$! DCL procedure to execute DCL commands on a remote decnet node. +$! The remote DECNET object DCLREMOTE.COM must be defined as a known type 0 +$! object on the remote node or the file must be in the login directory +$! of the account used on the remote system. Or the logical name DCLREMOTE +$! can be defined to point at the object. +$! +$! Usage: REM*OTE :== @SYS$MANAGER:REMOTE [P1] [P2] ... +$! +$! P1 - Node name commands are to be executed on, including any access control. +$! If no access control is specified then a proxy login is attempted. +$! The you do not have an account on the remote system then the default +$! DECNET account is used. +$! P2 - DCL command to execute on the remote system. Optional. +$! P3-P8 Additional parameters passed to the command (so quotes aren't needed) +$ +$ ON WARNING THEN GOTO ERROR +$ ON CONTROL_Y THEN GOTO ERROR +$ COMMAND := 'P2' 'P3' 'P4' 'P5' 'P6' 'P7' 'P8' +$ IF P2 .EQS. "CONTINUE" THEN COMMAND = COMMAND - "CONTINUE" +$ IF P2 .EQS. "END" THEN COMMAND = COMMAND - "END" +$ NEXT_CMD = "NEXT_CMD" +$ IF P2 .NES. "" THEN NEXT_CMD = "DONE" +$ P1 = P1 - "::" +$ +$ IF F$LOG ("NET") .EQS. "" THEN GOTO OPEN_LINK +$ IF P2 .EQS. "CONTINUE" THEN GOTO NEXT_CMD +$ IF P2 .EQS. "END" THEN GOTO NEXT_CMD +$OPEN_LINK: +$ WRITE SYS$OUTPUT "Establishing DECNET link to node ''P1'..." +$ OPEN/WRITE/READ NET 'P1'::"TASK=DCLREMOTE" +$ +$NEXT_CMD: +$ IF P2 .EQS. "" THEN READ /ERR=ERROR/PROMPT="''P1'> " SYS$COMMAND COMMAND +$ IF F$EDIT(F$EXTR(0,1,COMMAND),"UPCASE") .EQS. "E" THEN GOTO DONE +$ WRITE NET COMMAND +$LOOP: +$ READ/ERR=ERROR/TIME_OUT=10 NET LINE +$ IF F$EXTR (0,12,LINE) .EQS. "COMMAND$DONE" THEN GOTO 'NEXT_CMD' +$ WRITE SYS$OUTPUT LINE +$ GOTO LOOP +$DONE: +$ IF P2 .EQS. "CONTINUE" THEN EXIT +$ IF F$LOG ("NET") .NES. "" THEN CLOSE NET +$ EXIT +$ERROR: +$ IF F$LOG ("NET") .NES. "" THEN CLOSE NET +$ STOP +$eod diff --git a/decus/vax89a2/nieland/bulletin/bulletin.com b/decus/vax89a2/nieland/bulletin/bulletin.com index 722453311b226491ede99efa98cb8e3b3b24cdc4..441d743927f146b3ae8e838a97810995b049bc63 100755 GIT binary patch literal 38 pcmY#UaB+3>^mA1Rjto}u^a}_L0kiyEL%38FoI-tkTthtlxB$GG38Vl3 delta 19 acmY$>V3J~(AkEF7qTm$j ' + IF (COMMAND_PROMPT.EQ.'RUN> ') COMMAND_PROMPT = 'BULLETIN> ' + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + + CALL CLI$GET_VALUE('SEPARATE',SEPARATE) + + IF (CLI$PRESENT('EDIT')) EDIT_DEFAULT = .TRUE. ! /EDIT switch test + + CALL FIND_BULLCP ! See if BULLCP is running + + IF (CLI$PRESENT('CLEANUP')) THEN ! Test for /CLEANUP switch + CALL CLI$GET_VALUE('CLEANUP',BULL_PARAMETER,LEN_P) ! Get folder # + READ (BULL_PARAMETER,'(I)') FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + CALL EXIT ! all done with cleanup + ELSE IF (CLI$PRESENT('BBOARD')) THEN ! Test for /BBOARD switch + CALL BBOARD ! look for BBOARD mail + CALL EXIT ! all done with BBOARD + ELSE IF (CLI$PRESENT('STARTUP').OR. ! BULLCP process control + & CLI$PRESENT('STOP')) THEN + CALL CREATE_BULLCP + ELSE IF (CLI$PRESENT('BULLCP')) THEN ! This is BULLCP, so start + CALL RUN_BULLCP ! doing what BULLCP does! + END IF + + CALL GETSTS(STS) ! Get process status word + + IF (SYSTEM_SWITCH.OR.LOGIN_SWITCH) THEN ! If BULLETIN/LOGIN or /SYSTEM + IF ((STS.AND.PCB$M_BATCH).GT.0) CALL EXIT ! If BATCH, exit + CALL CRELNM('SYS$INPUT','TT') ! Take input from terminal + END IF + + IF ((STS.AND.PCB$M_NETWRK).EQ.0) THEN + DECNET_PROC = .FALSE. + ERROR_UNIT = 6 + + CALL ASSIGN_TERMINAL ! Assign terminal + + INCMD = 'SELECT' ! Causes nearest folder name to be selected + CALL SELECT_FOLDER(.FALSE.,IER) ! Select GENERAL folder + IF (.NOT.IER) RETURN ! If can't access, exit + + IF (.NOT.TEST_BULLCP()) CALL DELETE_EXPIRED + ! Delete expired messages + +C +C Get page size for the terminal. +C + + CALL GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) + + IF (CLI$PRESENT('PAGE')) PAGING = .TRUE. + + IF (SYSTEM_SWITCH) THEN + IER = CLI$GET_VALUE('SYSTEM',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Days specified? + CALL SUBTIME(SYSTEM_LOGIN_BTIM,BULL_PARAMETER(:LEN_P),IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Invalid parameter in /SYSTEM.'')') + CALL EXIT + END IF + END IF + IF (.NOT.LOGIN_SWITCH) THEN + CALL MODIFY_SYSTEM_LIST(0) + CALL SHOW_SYSTEM + CALL EXIT + END IF + END IF + +C +C Get user info stored in SYS$LOGIN. Currently, this simply stores +C the time of the latest message read for each folder. +C + + CALL OPEN_USERINFO + +C +C If /LOGIN, display SYSTEM bulletins and subject of non-SYSTEM bulletins. +C + + IF (LOGIN_SWITCH.OR.SYSTEM_SWITCH) THEN ! Is /LOGIN present? + CALL LOGIN ! Display SYSTEM bulletins + IF (READIT.EQ.0) CALL EXIT ! If no READNEWs not set, exit + END IF + +C +C If new bulletins have been added since the last time bulletins have been +C read, position bulletin pointer so that next bulletin read is the first new +C bulletin, and alert user. If READNEW set and no new bulletins, just exit. +C + + CALL NEW_MESSAGE_NOTIFICATION + + CALL OPEN_OLD_TAG + + ELSE + IF (TEST_BULLCP()) CALL EXIT + DECNET_PROC = .TRUE. + ERROR_UNIT = 5 + END IF + +C +C The MAIN loop for processing bulletin commands. +C + + DIR_COUNT = 0 ! # directory entry to continue bulletin read from + READ_COUNT = 0 ! # block that bulletin READ is to continue from + FOLDER_COUNT = 0 ! # folder entry to continue SHOW/ALL folder from + INDEX_COUNT = 0 + + IER = LIB$SYS_TRNLOG('BULL_HELP',HLEN,HELP_DIRECTORY) + IF (IER.NE.1) THEN + HELP_DIRECTORY = 'SYS$HELP:' + HLEN = 9 + ELSE IF (HELP_DIRECTORY(HLEN:HLEN).NE.':'.AND. + & HELP_DIRECTORY(HLEN:HLEN).NE.']') THEN + HELP_DIRECTORY = HELP_DIRECTORY(:HLEN)//':' + HLEN = HLEN + 1 + END IF + + DO WHILE (1) + + CALL GET_INPUT_PROMPT(INCMD,IER, + & CHAR(10)//COMMAND_PROMPT(:TRIM(COMMAND_PROMPT)+1)) + + IF (IER.EQ.-2) THEN + IER = RMS$_EOF + ELSE IF (IER.LE.0) THEN + IER = %LOC(CLI$_NOCOMD) + ELSE + DO WHILE (IER.GT.0.AND.INCMD(:1).EQ.' ') + INCMD = INCMD(2:IER) + IER = IER - 1 + END DO + DO WHILE (IER.GT.0.AND. + & INCMD(IER:IER).GE.'0'.AND.INCMD(IER:IER).LE.'9') + IER = IER - 1 + END DO + IF (IER.EQ.0) INCMD = 'READ '//INCMD + IER=CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS,LIB$GET_INPUT) + END IF + + IF (IER.EQ.RMS$_EOF) THEN + GO TO 999 ! If no command, exit + ELSE IF (IER.EQ.%LOC(CLI$_NOCOMD)) THEN ! If just RETURN entered + LEN_P = 0 ! Indicate no parameter in command + IF (DIR_COUNT.GT.0) THEN ! If still more dir entries + CALL DIRECTORY(DIR_COUNT) ! continue outputting them + ELSE IF (INDEX_COUNT.GT.0) THEN + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (FOLDER_COUNT.GT.0) THEN ! If more folder entries + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! continue outputting them + ELSE ! Else try to read next bulletin + CALL READ(READ_COUNT,BULL_POINT+1) ! or finish old one + END IF + GO TO 100 ! Loop to read new command + ELSE IF (.NOT.IER) THEN ! If command has error + GO TO 100 ! ask for new command + END IF + + DIR_COUNT = 0 ! Reinit display pointers + READ_COUNT = 0 + FOLDER_COUNT = 0 + INDEX_COUNT = 0 + + IER = MAX(INDEX(INCMD(:TRIM(INCMD)),' '),INDEX(INCMD,'/')) + IF (IER.GT.0) INCMD = ' '//INCMD(IER:) ! Save qualifiers + CALL CLI$GET_VALUE('$VERB',INCMD(:4)) ! Get user's command. + IF (READ_ONLY.AND.(INCMD(:3).EQ.'ADD'.OR.INCMD(:3).EQ.'DEL' + & .OR.INCMD(:3).EQ.'CHA'.OR.INCMD(:3).EQ.'REP')) THEN + ! FOLDER can only be read? + WRITE (6,'('' ERROR: Access to folder limited to reading.'')') + ELSE IF (INCMD(:3).EQ.'ADD') THEN ! ADD? + CALL ADD + ELSE IF (INCMD(:4).EQ.'BACK') THEN ! BACK? + IF (BULL_POINT.LE.1) THEN + WRITE(6,1060) + ELSE + CALL READ(READ_COUNT,BULL_POINT-1) ! Try to read previous bull + END IF + ELSE IF (INCMD(:4).EQ.'CHAN') THEN ! CHANGE? + CALL REPLACE ! Replace old bulletin + ELSE IF (INCMD(:4).EQ.'COPY') THEN ! COPY? + CALL MOVE(.FALSE.) + ELSE IF (INCMD(:4).EQ.'CREA') THEN ! CREATE? + CALL CREATE_FOLDER ! Go create the folder + ELSE IF (INCMD(:4).EQ.'CURR') THEN ! CURRENT? + READ_COUNT = -1 ! Reread current message from beginning. + CALL READ(READ_COUNT,BULL_POINT) + ELSE IF (INCMD(:4).EQ.'DELE') THEN ! DELETE? + CALL DELETE ! Go delete bulletin + ELSE IF (INCMD(:4).EQ.'DIRE') THEN ! DIRECTORY? + IF (CLI$PRESENT('FOLDER')) THEN ! /FOLDER specified? + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! Show all folders + ELSE IF (CLI$PRESENT('SELECT_FOLDER')) THEN! Folder specified? + CALL SELECT_FOLDER(.TRUE.,IER) ! Try to select folder + IF (IER) THEN ! If successful + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE IF (INCMD(:4).EQ.'FILE'.OR. + & INCMD(:4).EQ.'EXTR') THEN ! FILE? + CALL FILE ! Copy bulletin to file + ELSE IF (INCMD(:1).EQ.'E'.OR. + & INCMD(:4).EQ.'QUIT') THEN ! EXIT? + GO TO 999 ! Exit from program + ELSE IF (INCMD(:4).EQ.'HELP') THEN ! HELP? + CALL HELP(HELP_DIRECTORY(:HLEN)//'BULL.HLB') ! Get help + ELSE IF (INCMD(:3).EQ.'IND') THEN ! INDEX? + INDEX_COUNT = 1 + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (INCMD(:4).EQ.'LAST') THEN ! LAST? + READ_COUNT = -1 + BULL_READ = 99999 + CALL READ(READ_COUNT,BULL_READ) + ELSE IF (INCMD(:4).EQ.'MARK') THEN ! MARK? + CALL TAG(.TRUE.) + ELSE IF (INCMD(:4).EQ.'MAIL') THEN ! MAIL? + CALL MAIL(MAIL_STATUS) + ELSE IF (INCMD(:3).EQ.'MOD') THEN ! MODIFY? + CALL MODIFY_FOLDER + ELSE IF (INCMD(:4).EQ.'MOVE') THEN ! MOVE? + CALL MOVE(.TRUE.) + ELSE IF (INCMD(:4).EQ.'NEXT') THEN ! NEXT? + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + ELSE IF (INCMD(:4).EQ.'POST') THEN ! POST? + CALL RESPOND(MAIL_STATUS) + ELSE IF (INCMD(:4).EQ.'PRIN') THEN ! PRINT? + CALL PRINT ! Printout bulletin + ELSE IF (INCMD(:4).EQ.'READ') THEN ! READ? + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Bulletin specified? + DECODE(LEN_P,'(I)',BULL_PARAMETER) BULL_READ ! Yes + READ_COUNT = -1 + CALL READ(READ_COUNT,BULL_READ) + ELSE + CALL READ(READ_COUNT,BULL_POINT+1) + END IF + ELSE IF (INCMD(:3).EQ.'REM') THEN ! REMOVE? + CALL REMOVE_FOLDER + ELSE IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + CALL REPLY + ELSE IF (INCMD(:3).EQ.'RES') THEN ! RESPOND? + CALL RESPOND(MAIL_STATUS) + ELSE IF (INCMD(:3).EQ.'SEA') THEN ! SEARCH? + CALL SEARCH(READ_COUNT) + ELSE IF (INCMD(:3).EQ.'SEL') THEN ! SELECT? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (INCMD(:3).EQ.'SET') THEN ! SET? + CALL CLI$GET_VALUE('SET_PARAM1',BULL_PARAMETER) + IF (BULL_PARAMETER(:1).EQ.'F') THEN ! SET FOLDER? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRI') THEN ! SET PRIVS? + CALL SET_PRIV + ELSE IF (BULL_PARAMETER(:2).EQ.'PA') THEN ! SET PAGE? + PAGING = .TRUE. + WRITE (6,'('' PAGE has been set.'')') + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SET KEYPAD? + CALL SET_KEYPAD + ELSE IF (BULL_PARAMETER(:3).EQ.'NOK') THEN ! SET NOKEYPAD? + CALL SET_NOKEYPAD + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPA') THEN ! SET NOPAGE? + PAGING = .FALSE. + WRITE (6,'('' NOPAGE has been set.'')') + ELSE IF (FOLDER_NUMBER.EQ.-1) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + ELSE IF (BULL_PARAMETER(:2).EQ.'SY') THEN ! SET SYSTEM? + CALL SET_SYSTEM(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOSY') THEN ! SET NOSYSTEM? + CALL SET_SYSTEM(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'BB') THEN ! SET BBOARD? + CALL SET_BBOARD(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBB') THEN ! SET NOBBOARD? + CALL SET_BBOARD(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'DU') THEN ! SET DUMP? + CALL SET_FOLDER_FLAG(.TRUE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODU') THEN ! SET NODUMP? + CALL SET_FOLDER_FLAG(.FALSE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:2).EQ.'ST') THEN ! SET STRIP? + CALL SET_FOLDER_FLAG(.TRUE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOST') THEN ! SET NOSTRIP? + CALL SET_FOLDER_FLAG(.FALSE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:2).EQ.'DI') THEN ! SET DIGEST? + CALL SET_FOLDER_FLAG(.TRUE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODI') THEN ! SET NODIGEST? + CALL SET_FOLDER_FLAG(.FALSE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOTI') THEN ! SET NOTIFY? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(1,-1,-1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(1,-2,-2) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(1,4) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'E') THEN ! SET EXPIRE? + IER = CLI$GET_VALUE('EXPIRATION',BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.3) THEN + READ (BULL_PARAMETER,'(I)') LIMIT + CALL SET_FOLDER_EXPIRE_LIMIT(LIMIT) + ELSE + WRITE (6,'('' ERROR: Invalid expiration specified.'')') + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NODE') THEN ! SET NODE? + CALL SET_NODE(.TRUE.) + ELSE IF (BULL_PARAMETER(:6).EQ.'NONODE') THEN ! SET NONODE? + CALL SET_NODE(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOE') THEN ! SET NOEXPIRE? + CALL SET_FOLDER_EXPIRE_LIMIT(0) + ELSE IF (BULL_PARAMETER(:5).EQ.'NONOT') THEN ! SET NONOTIFY? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(0,-1,-1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(0,-2,-2) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,4) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'S') THEN ! SET SHOWNEW? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET SHOWNEW not allowed for GENERAL folder.'')') + ELSE IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,1) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(1,3) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOS') THEN ! SET NOSHOWNEW? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET NOSHOWNEW not allowed for GENERAL folder.'')') + ELSE IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(0,3) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'R') THEN ! SET READNEW? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,1,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,1,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(1,2) + CALL CHANGE_FLAG(0,3) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOR') THEN ! SET NOREADNEW? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(0,3) + END IF + ELSE IF (BULL_PARAMETER(:2).EQ.'BR') THEN ! SET BRIEF? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET BRIEF not allowed for GENERAL folder.'')') + ELSE + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,1,1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,1,1) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(1,2) + CALL CHANGE_FLAG(1,3) + END IF + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBR') THEN ! SET NOBRIEF? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET NOBRIEF not allowed for GENERAL folder.'')') + ELSE + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(0,3) + END IF + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'A') THEN ! SET ACCESS? + CALL SET_ACCESS(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOA') THEN ! SET NOACCESS? + CALL SET_ACCESS(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'G') THEN ! SET GENERIC? + CALL SET_GENERIC(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOG') THEN ! SET NOGENERIC? + CALL SET_GENERIC(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'L') THEN ! SET LOGIN? + CALL SET_LOGIN(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOL') THEN ! SET NOLOGIN? + CALL SET_LOGIN(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRO') THEN ! SET PROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.FALSE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPR') THEN ! SET NOPROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.TRUE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:3).EQ.'DEF') THEN ! SET DEFAULT_EXPIRE? + CALL SET_DEFAULT_EXPIRE + END IF + ELSE IF (INCMD(:4).EQ.'SHOW') THEN ! SHOW? + CALL CLI$GET_VALUE('SHOW_PARAM1',BULL_PARAMETER,LEN_P) + IF (BULL_PARAMETER(:2).EQ.'FL') THEN ! SHOW FLAGS? + CALL SHOW_FLAGS + ELSE IF (BULL_PARAMETER(:2).EQ.'FO') THEN ! SHOW FOLDER? + CALL SHOW_FOLDER + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SHOW KEYPAD + CALL SHOW_KEYPAD(HELP_DIRECTORY(:HLEN)//'BULL.HLB') + ELSE IF (BULL_PARAMETER(:1).EQ.'N') THEN ! SHOW NEW? + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + SAVE_FOLDER = FOLDER + DO FOLDER_NUMBER = 0,FOLDER_MAX-1 + IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + CALL SELECT_FOLDER(.FALSE.,IER) + IF (NBULL.GT.0) THEN + DIFF = COMPARE_BTIM( + & LAST_READ_BTIM(1,FOLDER_NUMBER+1),F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN + WRITE (6,'('' There are new messages in folder '' + & ,A,''.'')') FOLDER(:TRIM(FOLDER)) + END IF + END IF + END IF + END DO + FOLDER1 = SAVE_FOLDER + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE IF (BULL_PARAMETER(:1).EQ.'P') THEN ! SHOW PRIVILEGES? + CALL SHOW_PRIV + ELSE IF (BULL_PARAMETER(:1).EQ.'U') THEN ! SHOW USER? + CALL SHOW_USER + ELSE IF (BULL_PARAMETER(:1).EQ.'V') THEN ! SHOW VERSION? + CALL SHOW_VERSION + END IF + ELSE IF (INCMD(:4).EQ.'SPAW') THEN ! SPAWN command? + CALL SPAWN_PROCESS + ELSE IF (INCMD(:4).EQ.'UNDE') THEN ! UNDELETE? + CALL UNDELETE + ELSE IF (INCMD(:3).EQ.'UNM') THEN ! UNMARK? + CALL TAG(.FALSE.) + END IF + +100 CONTINUE + + END DO + +999 CALL EXIT + +1010 FORMAT(Q,A) +1060 FORMAT(' ERROR: There are no more messages.') + + END + + + + + + SUBROUTINE ADD +C +C SUBROUTINE ADD +C +C FUNCTION: Adds bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER INEXDATE*11,INEXTIME*11 + CHARACTER*(LINE_LENGTH) INDESCRIP + + CHARACTER INLINE*80,OLD_FOLDER*25 + CHARACTER PASSWORD*31,DEFAULT_USER*12 + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + ALLOW = SETPRV_PRIV() + + OLD_FOLDER_NUMBER = FOLDER_NUMBER + OLD_FOLDER = FOLDER + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (.NOT.ALLOW) THEN ! If no SETPRV privileges, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD',READONLY, + & SHARED,ERR=920,FORM='FORMATTED') ! Try opening the file + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + ELSE IF (CLI$PRESENT('TEXT')) THEN + BULL_PARAMETER = 'SYS$LOGIN:BULL.SCR' + LEN_P = TRIM(BULL_PARAMETER) + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH, + & STATUS='NEW',CARRIAGECONTROL='LIST',FORM='FORMATTED') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + +90 CALL CLOSE_BULLFIL + END IF + + SELECT_FOLDERS = .FALSE. + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL GET_FOLDER_INFO(IER) + IF (.NOT.IER) GO TO 910 + SELECT_FOLDERS = .TRUE. + ELSE + NODE_NUM = 1 + NODES(1) = OLD_FOLDER + END IF + + IER = CLI$GET_VALUE('USERNAME',DEFAULT_USER) + IF (.NOT.IER) DEFAULT_USER = USERNAME + IF (DECNET_PROC) THEN ! Running via DECNET? + USERNAME = DEFAULT_USER + CALL CONFIRM_PRIV(USERNAME,ALLOW) + END IF + + IF (FOLDER_NUMBER.GT.0.AND. ! If folder set and + & CLI$PRESENT('NODES')) THEN ! Decnet nodes specified? + WRITE (6,'('' ERROR: /NODES cannot be used with folder set.'')') + GO TO 910 + END IF + + IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0.AND. + & (CLI$PRESENT('SYSTEM').OR. ! Is /SYSTEM switch present? + & CLI$PRESENT('BROADCAST').OR. ! Is /BROADCAST swtich present? + & CLI$PRESENT('SHUTDOWN'))) THEN ! Is /SHUTDOWN switch present? + WRITE (6,'('' ERROR: Folder is not a SYSTEM folder.'')') + GO TO 910 + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN ! Is /SYSTEM switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1070) ! Tell user + GO TO 910 ! and abort + END IF + SYSTEM = 1 ! Set system bit + ELSE + SYSTEM = 0 ! Clear system bit + END IF + + IF (CLI$PRESENT('BROADCAST')) THEN ! Is /BROADCAST switch present? + IF (.NOT.(ALLOW.OR.OPER_PRIV())) THEN ! If no privileges + WRITE(ERROR_UNIT,1080) ! Tell user + GO TO 910 ! and abort + END IF + END IF + + IF (CLI$PRESENT('PERMANENT')) THEN ! Is /PERMANENT switch present? + IF (.NOT.ALLOW.AND..NOT.FOLDER_SET) THEN ! If no privileges + WRITE(ERROR_UNIT,1081) ! Tell user + GO TO 910 ! and abort + ELSE IF (F_EXPIRE_LIMIT.GT.0.AND..NOT.ALLOW ! Expiration limit + & .AND.USERNAME.NE.FOLDER_OWNER) THEN ! is present + WRITE(ERROR_UNIT,1083) + GO TO 910 + ELSE + SYSTEM = SYSTEM.OR.2 ! Set permanent bit + INEXDATE = '5-NOV-2000' + INEXTIME = '00:00:00.00' + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN ! Is /SHUTDOWN switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1082) ! Tell user + GO TO 910 ! and abort + ELSE + SYSTEM = SYSTEM.OR.4 ! Set shutdown bit + INEXDATE = '5-NOV-2000' + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + WRITE (INEXTIME,'(I4)') NODE_NUMBER + WRITE (INEXTIME(7:),'(I4)') NODE_AREA + DO I=1,11 + IF (INEXTIME(I:I).EQ.' ') INEXTIME(I:I) = '0' + END DO + INEXTIME = INEXTIME(1:2)//':'//INEXTIME(3:4)//':'// + & INEXTIME(7:8)//'.'//INEXTIME(9:10) + END IF + END IF + + SELECT_NODES = .FALSE. + IF (CLI$PRESENT('NODES')) THEN + CALL GET_NODE_INFO + IF (NODE_ERROR) GO TO 940 + SELECT_NODES = .TRUE. + END IF + + IF (SYSTEM.LE.1) THEN ! Not permanent or shutdown + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + + IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + INDESCRIP = DESCRIP ! Use description with RE:, + LENDES = TRIM(INDESCRIP) ! filled in by main subroutine + ELSE IF (CLI$PRESENT('SUBJECT')) THEN ! /SUBJECT specified + CALL CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + ELSE + WRITE(6,1050) ! Request header for bulletin + CALL GET_LINE(INDESCRIP,LENDES) ! Get input line + IF (LENDES.LE.0) GO TO 910 + END IF + + LENDES = MIN(LEN(INDESCRIP)-6,LENDES) ! Make room for "Subj: " + +C +C If file specified in ADD command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + IF (LEN_P.EQ.0) THEN ! If no file param specified + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + LEN_P = 1 + ELSE + CLOSE (UNIT=3) + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + END IF + END IF + + ICOUNT = 0 ! Line count for bulletin + + IF (LEN_P.GT.0) THEN ! If file param in ADD command + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + ICOUNT = ICOUNT + 1 + MIN(ILEN,80) + IF (ILEN.EQ.0) ICOUNT = ICOUNT + 1! COPY_BULL writes line with + END DO ! 1 space for blank line + ELSE ! If no input file + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) ! Temp file to save message + WRITE (6,1000) ! Request input from terminal + ILEN = LINE_LENGTH + 1 ! Length of input line + ICOUNT = 0 ! Character count counter + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Input line too long + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput:'')') LINE_LENGTH + ELSE IF (ILEN.GE.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN ! Update counter + WRITE(3,2010) INPUT(:ILEN) ! Save line in scratch file + END IF + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + REWIND (UNIT=3) + + IF (SELECT_NODES.AND.NODE_NUM.GT.0) THEN + INLINE = 'ADD' + IF (CLI$PRESENT('SYSTEM')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SYSTEM' + IF (CLI$PRESENT('BROADCAST')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BROADCAST' + IF (CLI$PRESENT('PERMANENT')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/PERMANENT' + IF (CLI$PRESENT('SHUTDOWN')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SHUTDOWN' + IF (CLI$PRESENT('BELL')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BELL' + + LEN_INLINE = STR$POSITION(INLINE,' ') - 1 + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + INLINE = INLINE(:LEN_INLINE) + SEMI = INDEX(NODES(POINT_NODE),'::') ! Look for semicolons + ILEN = TRIM(NODES(POINT_NODE)) ! Length of node name + IF (SEMI.GT.0) THEN ! Are semicolon found? + IF (ILEN.GT.SEMI+1) THEN ! Is username found? + TEMP_USER = NODES(POINT_NODE)(SEMI+2:) ! Yes + ILEN = SEMI - 1 ! Remove semicolons + ELSE ! No username found... + TEMP_USER = DEFAULT_USER ! Set user to default + ILEN = SEMI - 1 ! Remove semicolons + SEMI = 0 ! Indicate no username + END IF + ELSE ! No semicolons present + TEMP_USER = DEFAULT_USER ! Set user to default + END IF + IER = 1 + DO WHILE ((INLINE.NE.'ADD'.OR.SEMI.GT.0.OR. + & CLI$PRESENT('USERNAME')).AND.IER.NE.0) + WRITE(6,'('' Enter password for node '',2A)') + & NODES(POINT_NODE),CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) GO TO 910 + OPEN (UNIT=10+NODE_NUM,NAME=NODES(POINT_NODE)(:ILEN)// + & '"'//TEMP_USER(:TRIM(TEMP_USER))//' '// + & PASSWORD(:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10+NODE_NUM) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + END IF + END DO + INLINE = INLINE(:STR$POSITION(INLINE,' ')-1) + & //'/USERNAME='//TEMP_USER + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + IF (SYSTEM.LE.1) ! If not permanent or shutdown specify date + & WRITE (POINT_NODE+9,'(A)',ERR=940) INEXDATE//' '//INEXTIME + WRITE (POINT_NODE+9,'(A)',ERR=940) INDESCRIP(:LENDES) + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + ILEN = MIN(ILEN,LINE_LENGTH) + IF (IER.EQ.0) THEN + WRITE (POINT_NODE+9,'(A)',ERR=940) INPUT(:ILEN) + END IF + END DO + WRITE (POINT_NODE+9,'(A)',ERR=940) CHAR(26) + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INPUT + IF (INPUT.EQ.'END') THEN + WRITE (6,'('' Message successfully sent to node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while sending message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INPUT(:80) + GO TO 940 + END IF + REWIND (UNIT=3) + END DO + END IF + + IF (SELECT_NODES.AND..NOT.LOCAL_NODE_FOUND) GO TO 95 + ! Exit if local node not specified. + + IF (.NOT.SELECT_FOLDERS) THEN + NODE_NUM = 1 ! No folders specified so just + NODES(1) = FOLDER ! add to select folder + END IF + + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + BRDCST = .FALSE. + + DO I = 1,NODE_NUM + + IF (FOLDER.NE.NODES(I)) THEN + FOLDER_NUMBER = -1 + FOLDER1 = NODES(I) + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE + IER = 1 + END IF + + IF (IER) THEN + CALL OPEN_BULLDIR ! Prepare to add dir entry + + DESCRIP=INDESCRIP(:LENDES) ! Description header + EXDATE=INEXDATE ! Expiration date + EXTIME=INEXTIME + FROM = USERNAME ! Username + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + REWIND (UNIT=3) + OBLOCK = NBLOCK+1 + IF (LENDES.GT.LEN(DESCRIP)) THEN + CALL STORE_BULL(LENDES+6, + & 'Subj: '//INDESCRIP(:LENDES),OBLOCK) + END IF + CALL COPY_BULL(3,1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) GO TO 930 ! Error in creating bulletin + LENGTH = OCOUNT - (NBLOCK+1) + 1 +C +C Broadcast the bulletin if requested. +C + IF (.NOT.BRDCST.AND.CLI$PRESENT('BROADCAST').AND. + & (.NOT.REMOTE_SET.OR.FOLDER_NUMBER.GT.0)) THEN + CALL GET_BROADCAST_MESSAGE(CLI$PRESENT('BELL')) + BRDCST = .TRUE. + IF (.NOT.CLI$PRESENT('LOCAL')) THEN + CALL BROADCAST_ALL_NODES(CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER')) + END IF + CALL BROADCAST( + & CLI$PRESENT('ALL'),CLI$PRESENT('CLUSTER')) + END IF + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CALL ADD_ENTRY ! Add the new directory entry + + IF (FOLDER_NUMBER.GE.0) THEN + CALL UPDATE_FOLDER ! Update info in folder file +C +C If user is adding message, update that user's last read time for +C folder, so user is not alerted of new message which is owned by user. +C + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + ELSE + WRITE (6,'('' ERROR: Unable to add message to '',A)') + & NODES(I) + END IF + END DO + +95 CLOSE (UNIT=3) ! Close the input file + IF (DECNET_PROC) WRITE(5,'(''END'')') ! DECNET operation worked + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + DO I=10,NODE_NUM+9 + CLOSE (UNIT=I) + END DO + + IF (FOLDER_NUMBER.NE.OLD_FOLDER_NUMBER) THEN + FOLDER_NUMBER = OLD_FOLDER_NUMBER + FOLDER1 = OLD_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + + IF (CLI$PRESENT('TEXT')) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + +910 WRITE(ERROR_UNIT,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(6,1020) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + GOTO 100 + +930 WRITE (ERROR_UNIT,1025) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + +940 WRITE (6,1015) NODES(POINT_NODE) + WRITE (6,1018) + CLOSE (UNIT=3) + GO TO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1010 FORMAT (' No message was added.') +1015 FORMAT (' ERROR: Unable to reach node ',A) +1018 FORMAT (' Try using /FOLDER instead of /NODE.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1025 FORMAT (' ERROR: Unable to add message to file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1070 FORMAT (' ERROR: SETPRV privileges are needed for system + & messages.') +1080 FORMAT (' ERROR: SETPRV privileges are needed to broadcast + & messages.') +1081 FORMAT (' ERROR: SETPRV privileges are needed to permanent + & messages.') +1082 FORMAT (' ERROR: SETPRV privileges are needed to shutdown + & messages.') +1083 FORMAT (' ERROR: Folder has expiration limit.') +2010 FORMAT(A) +2020 FORMAT(1X,A) + + END + + + SUBROUTINE SUBTIME(BTIM,DAYS_BEFORE_TODAY,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER DAYS_BEFORE_TODAY*(*),TODAY_DATE*23 + + INTEGER BTIM(2),TODAY_BTIM(2) + + IER = SYS$BINTIM(DAYS_BEFORE_TODAY,BTIM) + IF (.NOT.IER) RETURN + + BTIM(1) = -BTIM(1) ! Convert to negative delta time + BTIM(2) = -BTIM(2)-1 + + IER = SYS$ASCTIM(TLEN,TODAY_DATE,,) + CALL SYS$BINTIM(TODAY_DATE(:TLEN),TODAY_BTIM) + + CALL LIB$SUBX(TODAY_BTIM,BTIM,BTIM) + + RETURN + END + + + + SUBROUTINE BROADCAST_ALL_NODES(ALL,CLUSTER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + COMMON /BROAD_MESSAGE/ BMESSAGE,BLENGTH + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*8 LOCALNODE + + IF (.NOT.TEST_BULLCP().OR.REMOTE_SET) RETURN + + CALL OPEN_BULLUSER_SHARED + + REMOTE_FOUND = .FALSE. + TEMP_USER = ':' + + DO WHILE (.NOT.REMOTE_FOUND) + DO WHILE (REC_LOCK(IER)) + READ (4,KEYGT=TEMP_USER,IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM,NEW_FLAG + END DO + IF (TEMP_USER(:1).NE.':') THEN + CALL CLOSE(4) + RETURN + END IF + REMOTE_FOUND = TEST2(NEW_FLAG,FOLDER_NUMBER) + END DO + + CALL CLOSE (4) + + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=NODENAME(:TRIM(NODENAME))//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IER = 0 + I = 1 + DO WHILE (IER.EQ.0.AND.I.LT.BLENGTH) + WRITE (17,'(4A)',IOSTAT=IER) + & 15,-1,I,BMESSAGE(I:MIN(BLENGTH,I+127)) + I = I + 128 + END DO + IF (IER.EQ.0) WRITE (17,'(7A)',IOSTAT=IER) + & 15,BLENGTH,I,ALL,CLUSTER,FOLDER_NUMBER,FOLDER + END IF + + CLOSE (UNIT=17) + + RETURN + END + + + + INTEGER FUNCTION ERROR_TRAP + + ERROR_TRAP = 1 + + RETURN + END + + + + SUBROUTINE REPLY + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLDIR.INC' + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + WRITE (6,'('' Adding REPLY message with the subject:'')') + CALL STR$UPCASE(BULL_PARAMETER,DESCRIP) + IF (BULL_PARAMETER(:3).NE.'RE:') THEN + DESCRIP = 'RE: '//DESCRIP + ELSE + DESCRIP = 'RE:'//DESCRIP(4:) + END IF + WRITE (6,'(1X,A)') DESCRIP + CALL ADD + + RETURN + END + + + + + SUBROUTINE CRELNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PSLDEF)' + + INCLUDE '($LNMDEF)' + + CHARACTER*(*) INPUT,OUTPUT + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT)) + CALL END_ITMLST(CRELNM_ITMLST) + + IER = SYS$CRELNM(,'LNM$PROCESS',INPUT,PSL$C_USER, + & %VAL(CRELNM_ITMLST)) + + RETURN + END + + + + SUBROUTINE GETPRIV +C +C SUBROUTINE GETPRIV +C +C FUNCTION: +C To get process privileges. +C OUTPUTS: +C PROCPRIV - Returned privileges +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /REALPROC/ REALPROCPRIV(2) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(8,JPI$_PROCPRIV,%LOC(PROCPRIV)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + REALPROCPRIV(1) = PROCPRIV(1) + REALPROCPRIV(2) = PROCPRIV(2) + + RETURN + END + + + + + LOGICAL FUNCTION SETPRV_PRIV + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + DATA NEEDPRIV/0,0/ + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (NEEDPRIV(1).EQ.0.AND.NEEDPRIV(2).EQ.0) THEN + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + CALL CLOSE_BULLUSER + NEEDPRIV(1) = USERPRIV(1) + NEEDPRIV(2) = USERPRIV(2) + END IF + + IF ((PROCPRIV(1).AND.NEEDPRIV(1)).GT.0.OR. + & (PROCPRIV(2).AND.NEEDPRIV(2)).GT.0) THEN + SETPRV_PRIV = .TRUE. + ELSE + SETPRV_PRIV = .FALSE. + END IF + + RETURN + END + + + + LOGICAL FUNCTION OPER_PRIV + IMPLICIT INTEGER (A-Z) + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + INCLUDE '($PRVDEF)' + OPER_PRIV = BTEST(PROCPRIV(1),PRV$V_OPER) + RETURN + END + + + + SUBROUTINE GETUSER(USERNAME) +C +C SUBROUTINE GETUSER +C +C FUNCTION: +C To get username of present process. +C OUTPUTS: +C USERNAME - Username owner of present process. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + CHARACTER*(*) USERNAME ! Limit is 12 characters + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + CALL CHECK_BULLETIN_PRIV(USERNAME) + + RETURN + END + + + SUBROUTINE SPAWN_PROCESS + + IMPLICIT INTEGER (A - Z) + + CHARACTER*255 COMMAND + + CALL DISABLE_PRIVS + IF (CLI$PRESENT('COMMAND')) THEN + CALL CLI$GET_VALUE('COMMAND',COMMAND,CLEN) + CALL LIB$SPAWN('$'//COMMAND(:CLEN)) + ELSE + CALL LIB$SPAWN() + END IF + CALL ENABLE_PRIVS + + RETURN + END diff --git a/decus/vax89a2/nieland/bulletin/bulletin0.for b/decus/vax89a2/nieland/bulletin/bulletin0.for new file mode 100644 index 0000000..67f04fe --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin0.for @@ -0,0 +1,1418 @@ +C +C BULLETIN0.FOR, Version 5/16/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE GET_BROADCAST_MESSAGE(RING_BELL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($BRKDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + +C +C The largest message that can be broadcasted is dependent on system +C and user quotas. The following limit is 12 lines of ( 80 characters + +C CR/LF ) + 2 bells. This should be more than enough room, as broadcasts +C shouldn't be too large anyway. +C + + PARAMETER CR=CHAR(13),LF=CHAR(10),BELL=CHAR(7) + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BROAD + + COMMON /BROAD_MESSAGE/ BROAD,BLENGTH + + IF (RING_BELL) THEN ! Include BELL in message? + BROAD(:36) = ! Say who the bulletin is from + & BELL//BELL//CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 37 ! Start adding next line here + ELSE + BROAD(:34) = ! Say who the bulletin is from + & CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 35 ! Start adding next line here + END IF + + IF (REMOTE_SET) REWIND (UNIT=3) + + END = 0 + ILEN = LINE_LENGTH + 1 + I = I + 1 + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (REMOTE_SET) THEN + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0) RETURN + ELSE + CALL GET_BULL_LINE(NBLOCK+1,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0) I = I + 1 + IF (ILEN.GT.0.AND.(I.GT.2.OR.(INPUT(:6).NE.'From: '.AND. + & INPUT(:6).NE.'Subj: '))) THEN + END = BLENGTH + ILEN - 1 + 2 ! Check how long string will be + IF (END.GT.BRDCST_LIMIT) RETURN ! String too long? + BROAD(BLENGTH:END) = CR//LF//INPUT(:ILEN)! Else add new input + BLENGTH = END + 1 ! Reset pointer + END IF + END DO + + RETURN + + ENTRY BROADCAST(ALL,CLUSTER) + + IF (ALL) THEN ! Should we broadcast to ALL? + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,,,,,) + END IF + ELSE ! Else just broadcast to users. + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,,,,,) + END IF + END IF + + RETURN + END + + + SUBROUTINE GET_FOLDER_INFO(IER) +C +C SUBROUTINE GET_FOLDER_INFO +C +C FUNCTION: Obtains & verifies folder names from command line. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + CHARACTER NODE_TEMP*256 + + NODE_NUM = 0 ! Initialize number of nodes + DO WHILE (CLI$GET_VALUE('SELECT_FOLDER',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(:COMMA-1) + NODE_TEMP = NODE_TEMP(COMMA+1:) + ELSE + NODES(NODE_NUM) = NODE_TEMP + NODE_TEMP = ' ' + END IF + NLEN = TRIM(NODES(NODE_NUM)) + IF (NODES(NODE_NUM)(NLEN-1:NLEN).EQ.'::') THEN + NODES(NODE_NUM) = NODES(NODE_NUM)(:NLEN)//'GENERAL' + END IF + FOLDER_NUMBER = -1 + FOLDER1 = NODES(NODE_NUM) + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' Unable to access folder '',A)') + & NODES(NODE_NUM) + RETURN + ELSE IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No write access for folder '',A)') + & NODES(NODE_NUM) + IER = 0 + RETURN + END IF + END DO + END DO + + IER = 1 + + RETURN + END + + + + + + + SUBROUTINE DELETE +C +C SUBROUTINE DELETE +C +C FUNCTION: Deletes a bulletin entry from the bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER ANSWER*1,REMOTE_USER*12,SUBJECT*53 + + INTEGER NOW(2) + + IMMEDIATE = 0 + IF (CLI$PRESENT('IMMEDIATE')) IMMEDIATE = 1 + + IF (CLI$PRESENT('NODES')) THEN ! Delete messages on DECNET node? + CALL DELETE_NODE ! Yes... + RETURN + ELSE IF (DECNET_PROC) THEN ! Is this from remote node? + IER = CLI$GET_VALUE('USERNAME',REMOTE_USER) + IER = CLI$GET_VALUE('SUBJECT',SUBJECT,SLEN) + CALL STR$UPCASE(SUBJECT,SUBJECT) + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + DEL_BULL = 0 + IER = 1 + DO WHILE (DEL_BULL+1.EQ.IER) + DEL_BULL = DEL_BULL + 1 + CALL READDIR(DEL_BULL,IER) + CALL STR$UPCASE(DESCRIP,DESCRIP) + IF (DEL_BULL+1.EQ.IER.AND.REMOTE_USER.EQ.FROM + & .AND.INDEX(DESCRIP,SUBJECT(:SLEN)).GT.0) THEN + CALL REMOVE_ENTRY(DEL_BULL,DEL_BULL,DEL_BULL,IMMEDIATE) + CALL CLOSE_BULLDIR + WRITE (5,'(''END'')') ! Tell DECNET that delete went ok. + RETURN + END IF + END DO + CALL CLOSE_BULLDIR ! Specified message not found, + WRITE(ERROR_UNIT,1030) ! so error out. + RETURN + END IF + +C +C Get the bulletin number to be deleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT ! Delete the file we are reading + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1020) + RETURN + ELSE IF (EBULL.GT.F_NBULL.AND..NOT.REMOTE_SET.AND. + & SBULL.NE.EBULL) THEN + WRITE (6,'('' Last message specified > number in folder.'')') + WRITE (6,'('' Do you want to delete to end of folder? '',$)') + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') THEN + WRITE (6,'('' Deletion aborted.'')') + RETURN + ELSE + EBULL = F_NBULL + END IF + END IF + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + IF (REMOTE_SET) THEN + IF (SBULL.NE.EBULL) THEN + WRITE (6,1025) + RETURN + END IF + IF (SBULL.NE.BULL_POINT) CALL READDIR(SBULL,IER) + WRITE(REMOTE_UNIT,'(4A)',IOSTAT=IER) + & 4,SBULL,IMMEDIATE,DESCRIP + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,INPUT,F1_NEWEST_BTIM,) + NEWEST_EXDATE = INPUT(1:11) + NEWEST_EXTIME = INPUT(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + RETURN + END IF + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + DO BULL_DELETE = SBULL,EBULL + CALL READDIR(BULL_DELETE,IER) ! Get info for bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges? + & (.NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER + & .AND.FOLDER_SET)) THEN + WRITE(6,1040) ! No, then error out. + CALL CLOSE_BULLDIR + RETURN + ELSE IF (SBULL.EQ.EBULL) THEN + CALL CLOSE_BULLDIR + WRITE (6,1050) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') RETURN + CALL OPEN_BULLDIR + CALL READDIR(BULL_DELETE,IER) + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + END IF + +C +C Delete the bulletin directory entry. +C + CALL REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + END DO + + CALL CLOSE_BULLDIR + RETURN + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1025 FORMAT(' ERROR: Cannot delete multiple messages in remote folder.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not deleted. Not owned by you.') +1050 FORMAT(' Message is not owned by you.', + & ' Are you sure you want to delete it? ',$) + + END + + + + SUBROUTINE REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + INTEGER NOW(2) + + IF (IMMEDIATE.EQ.1) THEN ! Delete it immediately + + CALL DELETE_ENTRY(BULL_DELETE) ! Delete the directory entry + + IF ((SYSTEM.AND.4).EQ.4) THEN ! Was entry shutdown bulletin? + SHUTDOWN = SHUTDOWN - 1 ! Decrement shutdown count + END IF + ELSE ! Delete it eventually +C +C Change year of expiration date of message to 100 years less, +C to indicate that message is to be deleted. Then, set expiration date +C in header of folder to 15 minutes from now. Thus, the folder will be +C checked in 15 minutes (or more), and will delete the messages then. +C +C NOTE: If some comic set their expiration date to > 1999, then +C the deleted date will be set to 1899 since can't specify date <1859. +C + + IF (SYSTEM.LE.1) THEN ! General or System message + EXDATE = EXDATE(1:7)//'18'//EXDATE(10:) + IF (EXDATE(10:10).LT.'6') EXDATE(10:11) = '99' + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(1:6)//'19'//EXDATE(9:) + ELSE + EXDATE = EXDATE(1:7)//'19'//EXDATE(10:) + END IF + END IF + + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + + IER = SYS$BINTIM('0 0:15',EX_BTIM) ! Get time 15 minutes from now + IER = SYS$GETTIM(NOW) + IER = LIB$SUBX(NOW,EX_BTIM,EX_BTIM) + IER = SYS$ASCTIM(,INPUT,EX_BTIM,) + + END IF + + IF (IMMEDIATE.NE.1.AND.BULL_DELETE.EQ.EBULL) THEN + CALL READDIR(0,IER) ! Get header + + NEWEST_EXDATE = INPUT(1:11) ! and store new expiration date + NEWEST_EXTIME = INPUT(13:) + + CALL WRITEDIR(0,IER) + ELSE IF (BULL_DELETE.EQ.EBULL) THEN + CALL CLEANUP_DIRFILE(SBULL) ! Reorder directory file + + CALL UPDATE_ALWAYS ! Somewhat a kludgey way of updating latest + ! bulletin and expired dates. + + IF (SBULL.LE.BULL_POINT) THEN + IF (BULL_POINT.GT.EBULL) THEN + BULL_POINT = BULL_POINT - (EBULL - SBULL + 1) + ELSE + BULL_POINT = SBULL + END IF + END IF ! Readjust where which bulletin to read next + ! if deletion causes messages to be moved. + END IF + + RETURN + END + + + + + + SUBROUTINE GET_2_VALS(INPUT,ILEN,SVAL,EVAL,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT + + DELIM = MAX(INDEX(INPUT,':'),INDEX(INPUT,'-')) + + IF (DELIM.EQ.0) THEN + DECODE(ILEN,'(I)',INPUT,IOSTAT=IER) SVAL + EVAL = SVAL + ELSE + DECODE(DELIM-1,'(I)',INPUT,IOSTAT=IER) SVAL + IF (IER.EQ.0) THEN + ILEN = ILEN - DELIM + DECODE(ILEN,'(I)',INPUT(DELIM+1:),IOSTAT=IER) EVAL + END IF + IF (EVAL.LT.SVAL) IER = 2 + END IF + + RETURN + END + + + + SUBROUTINE DIRECTORY(DIR_COUNT) +C +C SUBROUTINE DIRECTORY +C +C FUNCTION: Display directory of messages. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + DATA SCRATCH_D1/0/ + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED,CLI$_PRESENT + + CHARACTER START_PARAMETER*16,DATETIME*23 + + INTEGER TODAY(2) + + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + IF (INCMD(:3).EQ.'DIR'.AND..NOT.READ_TAG) THEN + IF (.NOT.CLI$PRESENT('SELECT_FOLDER').AND. + & CLI$PRESENT('MARKED')) THEN + IF (FOLDER_NUMBER.GE.0) THEN + READ_TAG = .TRUE. + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + ELSE + WRITE (6,'('' ERROR: Cannot use /MARKED with'', + & '' remote folder.'')') + RETURN + END IF + END IF + END IF + +C +C Directory listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C directory file, and to avoid the possibility of the user holding the screen, +C and thus causing the directory file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + CALL INIT_QUEUE(SCRATCH_D1,BULLDIR_ENTRY) + SCRATCH_D = SCRATCH_D1 + + CALL OPEN_BULLDIR_SHARED ! Get directory file + + CALL READDIR(0,IER) ! Does directory header exist? + IF (IER.EQ.1.AND.NBULL.GT.0) THEN ! And are there messages? + IF (DIR_COUNT.EQ.0) THEN + IF (CLI$PRESENT('START')) THEN ! Start number specified? + IER = CLI$GET_VALUE('START',START_PARAMETER,ILEN) + DECODE(ILEN,'(I)',START_PARAMETER) DIR_COUNT + IF (DIR_COUNT.GT.NBULL) THEN + DIR_COUNT = NBULL + ELSE IF (DIR_COUNT.LT.1) THEN + WRITE (6,'('' ERROR: Invalid starting message.'')') + CALL CLOSE_BULLDIR + DIR_COUNT = 0 + RETURN + END IF + ELSE IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + IF (CLI$PRESENT('SINCE')) THEN ! Was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present in'', + & '' folder '',A,''.'')') FOLDER(:TRIM(FOLDER)) + CALL CLOSE_BULLDIR + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + END IF + + CALL READDIR_KEYGE(IER) + + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + CALL CLOSE_BULLDIR + RETURN + ELSE + DIR_COUNT = IER + END IF + ELSE + DIR_COUNT = BULL_POINT + IF (DIR_COUNT.EQ.0) DIR_COUNT = 1 + END IF + + IF (READ_TAG) THEN + IF (.NOT.(CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW') + & .OR.CLI$PRESENT('START'))) THEN + DIR_COUNT = 1 + END IF + CALL READDIR(DIR_COUNT,IER1) + IF (IER1.EQ.DIR_COUNT+1) IER1 = 0 + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + END IF + + IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + ELSE IF (NBULL-DIR_COUNT+1.LE.PAGE_LENGTH-5) THEN + EBULL = NBULL + SBULL = NBULL - (PAGE_LENGTH-5) + 1 + IF (SBULL.LT.1) SBULL = 1 + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + END IF + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + END IF + IF (.NOT.PAGING) THEN + EBULL = NBULL + END IF + IF (.NOT.REMOTE_SET.AND..NOT.READ_TAG) THEN + DO I=SBULL,EBULL ! Copy messages from file + CALL READDIR(I,IER) ! Into the queue + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + END DO + ELSE IF (READ_TAG) THEN + I = SBULL + DO WHILE (I.LE.EBULL.AND.IER1.EQ.0) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,DIR_COUNT) + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + I = I + 1 + END DO + EBULL = I - 1 + IF (IER1.NE.0) EBULL = EBULL - 1 + ELSE + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,SBULL,EBULL + IF (IER.EQ.0) THEN + I = SBULL + DO WHILE (IER.EQ.0.AND.I.LE.EBULL) + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + I = I + 1 + END DO + END IF + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + RETURN + END IF + END IF + ELSE + NBULL = 0 + END IF + + CALL CLOSE_BULLDIR ! We don't need file anymore + + IF (NBULL.EQ.0) THEN + WRITE (6,'('' There are no messages present.'')') + RETURN + END IF + +C +C Directory entries are now in queue. Output queue entries to screen. +C + + FLEN = TRIM(FOLDER) + WRITE(6,'(X,A)') FOLDER(:FLEN) + WRITE(6,1000) ! Write header + N = 3 + + IF (BULL_TAG.AND..NOT.READ_TAG) THEN + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + + DO I=SBULL,EBULL + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + CALL CONVERT_ENTRY_FROMBIN + IF (MSG_NUM.GT.999) N = 4 + IF (MSG_NUM.GT.9999) N = 5 + IF (READ_TAG.OR.(BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG)) THEN + WRITE (6,'('' *'',$)') + ELSE + WRITE (6,'('' '',$)') + END IF + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM,'(DELETED)' + ELSE + WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM, + & DATE(1:7)//DATE(10:11) + END IF + IF (BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG) THEN + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + END DO + + DIR_COUNT = MSG_NUM + 1 ! Update directory counter + + IF (DIR_COUNT.GT.NBULL.OR.(READ_TAG.AND.IER1.NE.0)) THEN + ! Outputted all entries? + DIR_COUNT = 0 ! Yes. Set counter to 0. + ELSE + WRITE(6,1010) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(' #',1X,'Description',43X,'From',9X,'Date',/) +1010 FORMAT(1X,/,' Press RETURN for more...',/) + +2010 FORMAT('+',I,1X,A<55-N>,1X,A12,1X,A9) + + END + + + SUBROUTINE GET_MSGKEY(BTIM,MSG_KEY) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*8 MSG_KEY,INPUT + + CALL LIB$MOVC3(8,BTIM(1),%REF(INPUT)) + + DO I=1,8 + MSG_KEY(I:I) = INPUT(9-I:9-I) + END DO + + RETURN + END + + + + SUBROUTINE FILE +C +C SUBROUTINE FILE +C +C FUNCTION: Copies a bulletin to a file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN ! If no file name was specified + WRITE(6,1020) ! Write error + RETURN ! And return + END IF + + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + + IF (CLI$PRESENT('NEW')) THEN + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH, + & STATUS='UNKNOWN',CARRIAGECONTROL='LIST',ACCESS='APPEND') + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + DO FBULL = SBULL,EBULL + CALL READDIR(FBULL,IER) ! Get info for specified bulletin + + IF (IER.NE.FBULL+1) THEN ! Was bulletin found? + WRITE(6,1030) FBULL + IF (FBULL.GT.SBULL) GO TO 100 + CLOSE (UNIT=3,STATUS='DELETE') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + RETURN + END IF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + END DO + +100 CLOSE (UNIT=3) ! Bulletin copy completed + + WRITE(6,1040) BULL_PARAMETER(1:LEN_P) + ! Show name of file created. + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + + RETURN + +900 WRITE(6,1000) + CALL ENABLE_PRIVS ! Reset BYPASS privileges + RETURN + +1000 FORMAT(' ERROR: Error in opening file.') +1010 FORMAT(' ERROR: You have not read any bulletin.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1020 FORMAT(' ERROR: No file name was specified.') +1030 FORMAT(' ERROR: Following bulletin was not found: ',I) +1040 FORMAT(' Message(s) written to ',A) +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,/,'Date: ',A) + + END + + + + + SUBROUTINE LOGIN +C +C SUBROUTINE LOGIN +C +C FUNCTION: Alerts user of new messages upon logging in. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /READIT/ READIT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /POINT/ BULL_POINT + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY*23,INREAD*1 + + LOGICAL*1 CTRL_G/7/ + + DATA GEN_DIR1/0/ ! General directory link list header + DATA SYS_DIR1/0/ ! System directory link list header + DATA SYS_NUM1/0/ ! System message number link list header + DATA SYS_BUL1/0/ ! System bulletin link list header + DATA ALL_DIR1/0/ ! Full directory link list header (for remote) + + DATA PAGE/0/ + + DATA FIRST_WRITE/.TRUE./ + LOGICAL FIRST_WRITE + + DIMENSION NOLOGIN_BTIM(2),LOGIN_BTIM_SAVE(2),TODAY_BTIM(2) + DIMENSION NEW_BTIM(2),PASSCHANGE(2),BULLCP_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + CALL SYS_BINTIM('5-NOV-1956 11:05:56',NEW_BTIM) + +C +C Find user entry in BULLUSER.DAT to update information and +C to get the last date that messages were read. +C + + CALL OPEN_BULLUSER_SHARED + + CALL MODIFY_SYSTEM_LIST(1) + + CALL READ_USER_FILE_HEADER(IER) ! Get the header + + IF (IER.EQ.0) THEN ! Header is present. + UNLOCK 4 + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + ! Find if there is an entry + IF (NEW_FLAG(1).LT.143.OR.NEW_FLAG(1).GT.143) THEN + NEW_FLAG(2)=0 ! If old version clear GENERIC value + NEW_FLAG(1)=143 ! Set new version number + END IF + IF (IER1.EQ.0) THEN ! There is a user entry + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) RETURN + ! DISMAIL set + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_ENTRY + IF (SYSTEM_FLAG(1).NE.0.AND.SYSTEM_FLAG(1).NE.1) READIT = 1 + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0.OR.BRIEF_FLAG(I).NE.0.OR. + & (I.GT.1.AND.SYSTEM_FLAG(I).NE.0)) READIT = 1 + END DO + ELSE + CALL CLEANUP_LOGIN ! Good time to delete dead users + READ_BTIM(1) = NEW_BTIM(1) ! Make new entry + READ_BTIM(2) = NEW_BTIM(2) + DO I = 1,FLONG + SET_FLAG(I) = SET_FLAG_DEF(I) + BRIEF_FLAG(I) = BRIEF_FLAG_DEF(I) + NOTIFY_FLAG(I) = NOTIFY_FLAG_DEF(I) + END DO + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) + IF (DISMAIL.EQ.1) THEN + LOGIN_BTIM(1) = NOLOGIN_BTIM(1) + LOGIN_BTIM(2) = NOLOGIN_BTIM(2) + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + ELSE + LOGIN_BTIM_SAVE(1) = NEW_BTIM(1) + LOGIN_BTIM_SAVE(2) = NEW_BTIM(2) + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0) READIT = 1 + END DO + IF (COMPARE_BTIM(PASSCHANGE,NEWEST_BTIM).LT.0) IER1 = 0 + ! Old password change indicates user is new to BULLETIN + ! but not to system, so don't limit message viewing. + END IF + CALL WRITE_USER_FILE(IER) + IF (IER.NE.0) THEN ! Error in writing to user file + WRITE (6,1070) ! Tell user of the error + CALL CLOSE_BULLUSER ! Close the user file + CALL EXIT ! Go away... + END IF + IF (DISMAIL.EQ.1) RETURN ! Go away if DISMAIL set + DIFF = -1 ! Force us to look at messages + CALL OPEN_BULLINF_SHARED + DO I=1,FOLDER_MAX + LAST_READ_BTIM(1,I) = READ_BTIM(1) + LAST_READ_BTIM(2,I) = READ_BTIM(2) + END DO + WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(I,J),I=1,2),J=1,FOLDER_MAX) + CALL CLOSE_BULLINF + END IF + LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) + LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) + CALL READ_USER_FILE_HEADER(IER2) ! Reset read back to header + END IF + + IF (IER.EQ.0.AND.MINUTE_DIFF(TODAY_BTIM,BBOARD_BTIM) + & .GT.BBOARD_UPDATE) THEN ! Update BBOARD mail? + BBOARD_BTIM(1) = TODAY_BTIM(1) + BBOARD_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_HEADER ! Rewrite header + CALL CLOSE_BULLUSER + IF (.NOT.TEST_BULLCP()) CALL CREATE_BBOARD_PROCESS + ELSE + CALL CLOSE_BULLUSER + IF (IER.NE.0) CALL EXIT ! If no header, no messages + END IF + + IF (IER1.EQ.0) THEN ! Skip date comparison if new entry +C +C Compare and see if messages have been added since the last time +C that the user has logged in or used the BULLETIN facility. +C + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,READ_BTIM) + IF (DIFF1.LT.0) THEN ! If read messages since last login, + LOGIN_BTIM(1) = READ_BTIM(1) ! then use the read date to compare + LOGIN_BTIM(2) = READ_BTIM(2) ! with the latest bulletin date + END IF ! to see if should alert user. + + IF (SYSTEM_SWITCH) THEN + DIFF1 = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,NEWEST_BTIM) + ELSE + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,NEWEST_BTIM) + END IF + END IF + + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) ! These are destroyed in UPDATE_READ + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + + IF (NEW_FLAG(2).NE.0) THEN + CALL LIB$MOVC3(4,NEW_FLAG(2),%REF(BULL_PARAMETER)) + CALL SUBTIME(LOGIN_BTIM,BULL_PARAMETER(1:4),IER) + ELSE IF (DIFF1.GT.0) THEN + BULL_POINT = -1 + RETURN + END IF + +C +C If there are new messages, look for them in BULLDIR.DAT +C Save all new entries in the GEN_DIR file BULLCHECK.SCR so +C that we can close BULLDIR.DAT as soon as possible. +C + + ENTRY LOGIN_FOLDER + + IF (NEW_FLAG(2).EQ.0.OR.FOLDER_SET) THEN + LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) + LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) + END IF + + IF (REMOTE_SET) THEN ! If system remote folder, use remote + DIFF1 = COMPARE_BTIM(LOGIN_BTIM, ! info, not local login time + & LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF1.LT.0) THEN + LOGIN_BTIM(1) = LAST_READ_BTIM(1,FOLDER_NUMBER+1) + LOGIN_BTIM(2) = LAST_READ_BTIM(2,FOLDER_NUMBER+1) + ELSE + DIFF = MINUTE_DIFF(LOGIN_BTIM,F_NEWEST_BTIM) + IF (DIFF.GE.0.AND.DIFF.LE.15) THEN ! BULLCP updates every 15 min + IER = SYS$BINTIM('0 00:15',BULLCP_BTIM) + BULLCP_BTIM(1) = -BULLCP_BTIM(1) ! Convert to -delta time + BULLCP_BTIM(2) = -BULLCP_BTIM(2)-1 + CALL LIB$SUBX(LOGIN_BTIM,BULLCP_BTIM,LOGIN_BTIM) + END IF + END IF + END IF + + ENTRY SHOW_SYSTEM + + JUST_SYSTEM = (.NOT.LOGIN_SWITCH.AND.SYSTEM_SWITCH).OR. + & (FOLDER_NUMBER.GT.0.AND.BTEST(FOLDER_FLAG,2) + & .AND..NOT.TEST2(SET_FLAG,FOLDER_NUMBER) + & .AND..NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) + + NGEN = 0 ! Number of general messages + NSYS = 0 ! Number of system messages + BULL_POINT = -1 + + IF (IER1.NE.0.AND.FOLDER_NUMBER.GT.0) RETURN + ! Don't overwhelm new user with lots of non-general msgs + + IF (BTEST(FOLDER_FLAG,2).AND.SYSTEM_SWITCH) THEN + ! Can folder have SYSTEM messages and /SYSTEM specified? + LOGIN_BTIM(1) = SYSTEM_LOGIN_BTIM(1) ! Use specified login time + LOGIN_BTIM(2) = SYSTEM_LOGIN_BTIM(2) ! for system messages. + END IF + + CALL OPEN_BULLDIR_SHARED ! Get bulletin directory + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(0,IER) ! Get header info + ELSE + NBULL = F_NBULL + END IF + + CALL INIT_QUEUE(GEN_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_NUM1,%DESCR(ICOUNT)) + GEN_DIR = GEN_DIR1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + START = 1 + REVERSE = 0 + IF (REVERSE_SWITCH.AND.(.NOT.TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & .NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER))) THEN + REVERSE = 1 + IF (IER1.EQ.0) THEN + CALL GET_NEWEST_MSG(LOGIN_BTIM,START) + IF (START.EQ.-1) START = NBULL + 1 + END IF + END IF + + IF (REMOTE_SET) THEN + CALL INIT_QUEUE(ALL_DIR1,BULLDIR_ENTRY) + IF (REVERSE) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,START,NBULL + ELSE + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,NBULL,START + END IF + IF (IER.EQ.0) THEN + ALL_DIR = ALL_DIR1 + I = START + DO WHILE (IER.EQ.0.AND.I.LE.NBULL) + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY + CALL WRITE_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + I = I + 1 + END DO + END IF + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + RETURN + END IF + ALL_DIR = ALL_DIR1 + END IF + + DO ICOUNT1 = NBULL,START,-1 + IF (REVERSE) THEN + ICOUNT = NBULL + START - ICOUNT1 + ELSE + ICOUNT = ICOUNT1 + END IF + IF (REMOTE_SET) THEN + CALL READ_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + IER = ICOUNT + 1 + ELSE + CALL READDIR(ICOUNT,IER) + END IF + IF (IER1.EQ.0.AND.IER.EQ.ICOUNT+1) THEN ! Is this a totally new user? + ! No. Is bulletin system or from same user? + IF (.NOT.REVERSE) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM,MSG_BTIM) ! No, so compare date + IF (DIFF.GT.0) GO TO 100 + END IF + IF (.NOT.BTEST(FOLDER_FLAG,2)) SYSTEM = SYSTEM.AND.(.NOT.1) + ! Show system msg in non-system folder as general msg + IF (USERNAME.NE.FROM.OR.SYSTEM) THEN + IF (SYSTEM) THEN ! Is it system bulletin? + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (.NOT.JUST_SYSTEM) THEN + IF (SYSTEM_SWITCH) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,MSG_BTIM) + ELSE + DIFF = -1 + END IF + IF (DIFF.LT.0) THEN + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + SYSTEM = ICOUNT + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END IF + ELSE IF (IER.EQ.ICOUNT+1) THEN + ! Totally new user, save only permanent system msgs + IF (SYSTEM.EQ.3) THEN + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (NGEN.EQ.0) THEN ! And save only the first non-system msg + SYSTEM = ICOUNT ! Save bulletin number for display + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END DO +100 CALL CLOSE_BULLDIR +C +C Review new directory entries. If there are system messages, +C copy the system bulletin into GEN_DIR file BULLSYS.SCR for outputting +C to the terminal. If there are simple messages, just output the +C header information. +C + IF (NGEN.EQ.0.AND.NSYS.EQ.0) RETURN + + IF (NSYS.GT.0) THEN ! Are there any system messages? + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + LENF = TRIM(FOLDER) + S1 = (PAGE_WIDTH-(LENF+16))/2 + S2 = PAGE_WIDTH - S1 - (LENF + 16) + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE (6,1026) FOLDER(:LENF) ! Yep... + PAGE = PAGE + 1 + CTRL_G = 0 ! Don't ring bell for non-system bulls + CALL OPEN_BULLFIL_SHARED + CALL INIT_QUEUE(SYS_BUL1,INPUT) + SYS_BUL = SYS_BUL1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + NSYS_LINE = 0 + DO J=1,NSYS + CALL READ_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + IF (REMOTE_SET) THEN + CALL READ_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,ICOUNT + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER) + END IF + IF (IER.GT.0) THEN + CALL CLOSE_BULLFIL + RETURN + END IF + END IF + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin to SYS_BUL link list + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + IF (ILEN.LT.0) THEN + CALL CLOSE_BULLFIL + RETURN + END IF + IF (J.LT.NSYS.AND.SEPARATE.NE.' ') THEN + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + DO I=1,PAGE_WIDTH + INPUT(I:I) = SEPARATE + END DO + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 2 + END IF + END DO + CALL CLOSE_BULLFIL + SYS_BUL = SYS_BUL1 + ILEN = 0 + I = 1 + DO WHILE (I.LE.NSYS_LINE.OR.ILEN.GT.0) ! Write out system messages + IF (ILEN.EQ.0) THEN + CALL READ_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + ILEN = TRIM(INPUT) + I = I + 1 + END IF + IF (SYS_BUL.NE.0) THEN + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN + ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD,! Get terminal input + & 'HIT any key for next page....') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) '+'//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) '+'//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + ELSE + PAGE = PAGE + 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) ' '//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) ' '//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + END IF + END IF + END DO + IF (NGEN.EQ.0) THEN + WRITE(6,'(A)') ! Write delimiting blank line + END IF + PAGE = PAGE + 1 + END IF + + ENTRY REDISPLAY_DIRECTORY + + GEN_DIR = GEN_DIR1 + IF (NGEN.GT.0) THEN ! Are there new non-system messages? + LENF = TRIM(FOLDER) + S1 = (PAGE_WIDTH-13-LENF)/2 + S2 = PAGE_WIDTH-S1-13-LENF + IF (PAGE+5+NGEN.GT.PAGE_LENGTH.AND.PAGE.GT.0) THEN + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, ! Get terminal input + & 'HIT any key for next page....') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1028) 'New '//FOLDER(1:LENF)//' messages' + PAGE = 1 + ELSE + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1027) 'New '//FOLDER(1:LENF)//' messages' + PAGE = PAGE + 1 + END IF + WRITE(6,1020) + WRITE(6,1025) + PAGE = PAGE + 2 + I = 0 + DO WHILE (I.LT.NGEN) + I = I + 1 + CALL READ_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + CALL CONVERT_ENTRY_FROMBIN + IF (SYSTEM.GT.9999) THEN ! # Digits in message number + N = 5 + ELSE IF (SYSTEM.GT.999) THEN + N = 4 + ELSE + N = 3 + END IF + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, + & 'HIT Q(Quit listing) or any other key for next page....') + CALL STR$UPCASE(INREAD,INREAD) + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (INREAD.EQ.'Q') THEN + I = NGEN ! Quit directory listing + WRITE(6,'(''+Quitting directory listing.'')') + ELSE + WRITE(6,1040) '+'//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM + END IF + ! Bulletin number is stored in SYSTEM + ELSE + PAGE = PAGE + 1 + WRITE(6,1040) ' '//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM + END IF + END DO + IF ((.NOT.FOLDER_SET.AND.BTEST(SET_FLAG(1),0).AND.DIFF1.LE.0) + & .OR.(FOLDER_SET.AND.TEST2(SET_FLAG,FOLDER_NUMBER))) THEN + PAGE = 0 ! Don't reset page counter if READNEW not set, + END IF ! as no prompt to read is generated. + END IF +C +C Instruct users how to read displayed messages if READNEW not selected. +C + IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE(6,1030) + ELSE IF (NGEN.EQ.0) THEN + ILEN = 57 + INDEX(COMMAND_PROMPT,'>') - 1 + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-57)// + & '/SYSTEM command can be used to reread these messages.' + ELSE + FLEN = TRIM(FOLDER) + IF (FOLDER_NUMBER.EQ.0) FLEN = -1 + ILEN = 49 + INDEX(COMMAND_PROMPT,'>') - 1 + FLEN + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-48)// + & ' command can be used to read these messages.' + ELSE + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-49-FLEN) + & //' '//FOLDER(:FLEN)// + & ' command can be used to read these messages.' + END IF + END IF + + RETURN + +1020 FORMAT(' Description',43X,'From',9X,'Date',3X,'Number') +1025 FORMAT(' -----------',43X,'----',9X,'----',3X,'------') +1026 FORMAT(' ',('*'),A,' System Messages',('*')) +1027 FORMAT(/,' ',('*'),A,('*')) +1028 FORMAT('+',('*'),A,('*')) +1030 FORMAT(' ',('*')) +1035 FORMAT(' ',('*'),A,('*')) +1040 FORMAT(A<57-N>,1X,A12,1X,A6,<6-N>X,I) +1060 FORMAT(A) +1070 FORMAT(' ERROR: Cannot add new entry to user file.') +1080 FORMAT(' ',/) + + END diff --git a/decus/vax89a2/nieland/bulletin/bulletin1.for b/decus/vax89a2/nieland/bulletin/bulletin1.for new file mode 100644 index 0000000..69cf466 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin1.for @@ -0,0 +1,1543 @@ +C +C BULLETIN1.FOR, Version 5/11/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE MAIL(STATUS) +C +C SUBROUTINE MAIL +C +C FUNCTION: Sends message which you have read to user via DEC mail. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*64 MAIL_SUBJECT + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + MAIL_SUBJECT = DESCRIP + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',MAIL_SUBJECT,LEN_D) + IF (LEN_D.GT.LEN(MAIL_SUBJECT)-2) THEN + WRITE(6,'('' ERROR: Subject limit is 64 characters.'')') + RETURN + END IF + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Error in opening scratch file.'')') + RETURN + END IF + + IF (CLI$PRESENT('HEADER')) THEN ! Printout header? + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + WRITE (3,'(A)') INPUT(:TRIM(INPUT)) + END IF + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Message copy completed + + CALL CLOSE_BULLFIL + + LEN_D = TRIM(MAIL_SUBJECT) + IF (LEN_D.EQ.0) THEN + MAIL_SUBJECT = 'BULLETIN message.' + LEN_D = TRIM(MAIL_SUBJECT) + END IF + + I = 1 + DO WHILE (I.LE.LEN_D) + IF (MAIL_SUBJECT(I:I).EQ.'"') THEN + IF (LEN_D.EQ.64) THEN + MAIL_SUBJECT(I:I) = '`' + ELSE + MAIL_SUBJECT = MAIL_SUBJECT(:I)//'"'//MAIL_SUBJECT(I+1:) + I = I + 1 + LEN_D = LEN_D + 1 + END IF + END IF + I = I + 1 + END DO + + IER = CLI$GET_VALUE('RECIPIENTS',BULL_PARAMETER,LEN_P) + + CALL DISABLE_PRIVS + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR '//BULL_PARAMETER(:LEN_P) + & //'/SUBJECT="'//MAIL_SUBJECT(:LEN_D)//'"',,,,,,STATUS) + CALL ENABLE_PRIVS + + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR') + + RETURN + +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A) + + END + + + + SUBROUTINE MODIFY_FOLDER +C +C SUBROUTINE MODIFY_FOLDER +C +C FUNCTION: Modifies a folder's information. +C + IMPLICIT INTEGER (A - Z) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER PASSWORD*31,DEFAULT_USER*12 + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + RETURN + ELSE IF (FOLDER_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: No privileges to modify folder.'')') + RETURN + END IF + + IF (CLI$PRESENT('NAME')) THEN + IF (REMOTE_SET) THEN + WRITE (6,'('' ERROR: Cannot change name of'', + & '' remote folder.'')') + RETURN + ELSE + CALL CLI$GET_VALUE('NAME',FOLDER1,LEN_P) + IF (LEN_P.GT.25) THEN + WRITE (6,'('' ERROR: Folder name cannot be larger + & than 25 characters.'')') + RETURN + END IF + END IF + ELSE + FOLDER1 = FOLDER + END IF + + IF (CLI$PRESENT('DESCRIPTION')) THEN + WRITE (6,'('' Enter one line description of folder.'')') + LEN_P = 81 + DO WHILE (LEN_P.GT.80) + CALL GET_LINE(FOLDER1_DESCRIP,LEN_P) ! Get input line + IF (LEN_P.LE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + RETURN + ELSE IF (LEN_P.GT.80) THEN ! If too many characters + WRITE (6,'('' ERROR: Description must be < 80 characters.'')') + ELSE + FOLDER1_DESCRIP = FOLDER1_DESCRIP(:LEN_P) ! End fill with spaces + END IF + END DO + ELSE + FOLDER1_DESCRIP = FOLDER_DESCRIP + END IF + + IF (CLI$PRESENT('OWNER')) THEN + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner name is not valid username.'')') + RETURN + ELSE IF (LEN_P.GT.LEN(FOLDER1_OWNER)) THEN + WRITE (6,'('' ERROR: Folder owner name too long.'')') + RETURN + ELSE IF (.NOT.SETPRV_PRIV()) THEN + WRITE(6,'('' Enter password of new owner: '',A)') CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) THEN + WRITE (6,'('' ERROR: No password entered.'')') + RETURN + END IF + WRITE (6,'('' Attempting to verify password name...'')') + OPEN (UNIT=10,NAME='SYS$NODE"'// + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + & //' '//PASSWORD(:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + RETURN + ELSE + WRITE (6,'('' Password was verified.'')') + END IF + ELSE + FOLDER1_OWNER = FOLDER1_OWNER(:LEN_P) + END IF + ELSE + FOLDER1_OWNER = FOLDER_OWNER + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + + IF (CLI$PRESENT('NAME')) THEN + READ (7,IOSTAT=IER,KEY=FOLDER1,KEYID=0) + ! See if folder exists + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder name already exists.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + END IF + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (IER.EQ.0.AND.CLI$PRESENT('NAME')) THEN + LEN_F = TRIM(FOLDER_DIRECTORY) + IER = LIB$RENAME_FILE(FOLDER_DIRECTORY(:LEN_F)// + & FOLDER(:TRIM(FOLDER))//'.*',FOLDER_DIRECTORY(:LEN_F)// + & FOLDER1(:TRIM(FOLDER1))//'.*') + IF (IER) THEN + IER = 0 + FOLDER_FILE = FOLDER_DIRECTORY(:LEN_F)//FOLDER1 + END IF + END IF + + IF (IER.EQ.0) THEN + IF (CLI$PRESENT('OWNER')) THEN + CALL CHKACL + & (FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + CALL DEL_ACL(FOLDER_OWNER,'R+W+C',IER) + END IF + END IF + FOLDER = FOLDER1 + FOLDER_OWNER = FOLDER1_OWNER + FOLDER_DESCRIP = FOLDER1_DESCRIP + DELETE (7) + CALL WRITE_FOLDER_FILE(IER) + IF (IER.EQ.0) WRITE (6,'('' Folder successfully modified.'')') + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + SUBROUTINE MOVE(DELETE_ORIGINAL) +C +C SUBROUTINE MOVE +C +C FUNCTION: Moves message from one folder to another. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + EXTERNAL CLI$_ABSENT + + LOGICAL DELETE_ORIGINAL + + CHARACTER SAVE_FOLDER*25 + + IF (CLI$PRESENT('ORIGINAL').AND..NOT.SETPRV_PRIV()) THEN + WRITE (6, + & '('' ERROR: You have no privileges to keep original owner.'')') + END IF + + ALL = CLI$PRESENT('ALL') + + MERGE = CLI$PRESENT('MERGE') + + SAVE_BULL_POINT = BULL_POINT + + IER1 = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER1.EQ.%LOC(CLI$_ABSENT).AND..NOT.ALL) THEN + IF (BULL_POINT.EQ.0) THEN ! If no message has been read + WRITE(6,'('' ERROR: You are not reading any message.'')') + RETURN ! and return + END IF + + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) ! Get message directory entry + IF (IER.NE.BULL_POINT+1) THEN ! Was message found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + NUM_COPY = 1 + ELSE + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) ! Get message directory entry + IF (NBULL.EQ.0) THEN ! Were messages found? + WRITE(6,'('' ERROR: No messages were found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (IER1.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER1) + IF (SBULL.LE.0.OR.IER1.NE.0) THEN + WRITE (6,'(A)') + & ' ERROR: Specified message number has incorrect format.' + CALL CLOSE_BULLDIR + RETURN + ELSE + NUM_COPY = EBULL - SBULL + 1 + BULL_POINT = SBULL + END IF + ALL = .TRUE. + ELSE IF (CLI$PRESENT('ALL')) THEN + NUM_COPY = NBULL + BULL_POINT = 1 + END IF + END IF + + FROM_REMOTE = REMOTE_SET + + IF (REMOTE_SET) THEN + OPEN (UNIT=12,FILE='REMOTE.BULLDIR', + & STATUS='SCRATCH',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.0) THEN + OPEN (UNIT=11,FILE='REMOTE.BULLFIL', + & STATUS='SCRATCH',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END IF + IF (IER.EQ.0) THEN + CALL OPEN_BULLFIL + I = BULL_POINT - 1 + CALL READDIR(I,IER) + IF (IER.EQ.I+1) THEN + IF (I.EQ.0) THEN + WRITE (12,IOSTAT=IER1) BULLDIR_HEADER + ELSE + WRITE (12,IOSTAT=IER1) BULLDIR_ENTRY + END IF + END IF + NBLOCK = 1 + DO WHILE (I.LT.BULL_POINT+NUM_COPY-1.AND.IER.EQ.I+1) + I = I + 1 + CALL READDIR(I,IER) + IF (IER.EQ.I+1) THEN + BLOCK = NBLOCK + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (12,IOSTAT=IER1) BULLDIR_ENTRY + IF (IER1.EQ.0) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER1) 5,I + IF (IER1.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER1) + END IF + END IF + IF (IER1.EQ.0) THEN + SCRATCH_R = SCRATCH_R1 + DO J=1,LENGTH + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT(:128)) + WRITE (11'NBLOCK,IOSTAT=IER1) INPUT(:128) + NBLOCK = NBLOCK + 1 + END DO + END IF + IF (IER1.NE.0) I = IER + END IF + END DO + NUM_COPY = I - BULL_POINT + 1 + END IF + CALL CLOSE_BULLFIL + IF (IER1.NE.0) THEN + WRITE(6,'('' ERROR: Copy aborted. Remote folder problem.'')') + CLOSE (UNIT=11) + CLOSE (UNIT=12) + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + + CALL CLOSE_BULLDIR + + SAVE_FOLDER = FOLDER + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + CALL CLI$GET_VALUE('FOLDER',FOLDER1) + + FOLDER_NUMBER = -1 ! Use FOLDER as key rather than FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Cannot access specified folder.'')') + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER = SAVE_FOLDER + BULL_POINT = SAVE_BULL_POINT + CLOSE (UNIT=11) + CLOSE (UNIT=12) + RETURN + END IF + + IF (READ_ONLY.OR.(MERGE.AND.REMOTE_SET)) THEN + IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No access to write into folder.'')') + ELSE + WRITE (6,'('' ERROR: /MERGE invalid into remote folder.'')') + END IF + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + BULL_POINT = SAVE_BULL_POINT + CLOSE (UNIT=11) + CLOSE (UNIT=12) + RETURN + END IF + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + CALL OPEN_BULLDIR ! Prepare to add dir entry + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //SAVE_FOLDER + + IF (.NOT.FROM_REMOTE) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=12,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER.EQ.0) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=11,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END DO + END IF + ELSE + IER= 0 + END IF + + IF (MERGE) CALL INITIALIZE_MERGE(IER) + + START_BULL_POINT = BULL_POINT + + IF (IER.EQ.0) READ (12,KEYID=0,KEY=BULL_POINT-1,IOSTAT=IER) + + DO WHILE (NUM_COPY.GT.0.AND.IER.EQ.0) + READ (12,IOSTAT=IER) BULLDIR_ENTRY + NUM_COPY = NUM_COPY - 1 + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + + IF (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV()) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,0) ! Remove system bit + END IF + + IF (BTEST(SYSTEM,2).AND. ! Shutdown message? + & (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV())) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,2) ! Remove shutdown bit + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + EXTIME = '00:00:00.00' + ELSE IF (BTEST(SYSTEM,1).AND.FOLDER_NUMBER.EQ.0.AND. + & .NOT.SETPRV_PRIV().AND..NOT.ALL) THEN ! Permanent? + WRITE (6,'('' ERROR: No privileges to add'', + & '' permanent message.'')') + WRITE (6,'('' Expiration will be '',I,'' days.'')') + & FOLDER_BBEXPIRE + SYSTEM = IBCLR(SYSTEM,1) + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + EXTIME = '00:00:00.00' + END IF + + IF (.NOT.CLI$PRESENT('ORIGINAL')) THEN ! If not /ORIGINAL + FROM = USERNAME ! Specify owner + END IF + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + IF (IER.NE.0) CALL ERROR_AND_EXIT + END IF + + IF (MERGE) CALL ADD_MERGE_TO(IER) + + IF (IER.EQ.0) THEN + NBLOCK = NBLOCK + 1 + + DO I=BLOCK,BLOCK+LENGTH-1 + READ (11'I,IOSTAT=IER) INPUT(:128) + IF (IER.EQ.0) THEN + CALL WRITE_BULL_FILE(NBLOCK,INPUT(:128)) + END IF + NBLOCK = NBLOCK + 1 + END DO + END IF + + IF (IER.EQ.0) THEN + IF (MERGE) THEN + CALL ADD_MERGE_FROM(IER) + ELSE + CALL ADD_ENTRY ! Add the new directory entry + END IF + BULL_POINT = BULL_POINT + 1 + END IF + END DO + + IF (MERGE) CALL ADD_MERGE_REST(IER) + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CLOSE (UNIT=11) + + CLOSE (UNIT=12) + + IF (FOLDER_NUMBER.GE.0.AND.IER.EQ.0) THEN + CALL UPDATE_FOLDER ! Update folder info +C +C If user is adding message, update that user's last read time for +C folder, so user is not alerted of new message which is owned by user. +C + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + + IF (IER.EQ.0) THEN + WRITE (6,'('' Successful copy to folder '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + IF (MERGE) THEN + CALL LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END IF + ELSE IF (MERGE) THEN + WRITE (6,'('' ERROR: Copy aborted. No files copied.'')') + ELSE + WRITE (6,'('' ERROR: Copy aborted. '',I,'' files copied.'')') + & BULL_POINT - START_BULL_POINT + END IF + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + + BULL_POINT = SAVE_BULL_POINT + + IF (DELETE_ORIGINAL.AND.IER.EQ.0) THEN + IF (FROM_REMOTE.AND.ALL) THEN + WRITE (6,'('' WARNING: Original messages not deleted.'')') + WRITE (6,'('' Multiple deletions not possible for '', + & ''remote folders.'')') + ELSE + CALL DELETE + END IF + END IF + + RETURN + + END + + + + + + SUBROUTINE PRINT +C +C SUBROUTINE PRINT +C +C FUNCTION: Print header to queue. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SJCDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + CHARACTER*32 QUEUE + + INTEGER*2 FILE_ID(14) + INTEGER*2 IOSB(4) + EQUIVALENCE (IOSB(1),JBC_ERROR) + + CHARACTER*31 FORM_NAME + + PARAMETER FF = CHAR(12) + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.LIS',ERR=900,IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + CALL ENABLE_PRIVS + + CALL OPEN_BULLDIR_SHARED + + CALL OPEN_BULLFIL_SHARED + + HEAD = CLI$PRESENT('HEADER') + + DO I=SBULL,EBULL + CALL READDIR(I,IER) ! Get info for specified message + + IF (IER.NE.I+1) THEN ! Was message found? + IF (I.EQ.SBULL) THEN ! No, were any messages found? + WRITE(6,1030) ! If not, then error out + CLOSE (UNIT=3,STATUS='DELETE') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + RETURN + END IF + ELSE ! Yes, message found. + IF (I.GT.SBULL) WRITE(3,'(A)') FF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + END IF + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(18,SJC$_FILE_SPECIFICATION, + & %LOC('SYS$LOGIN:BULL.LIS')) + + IER = CLI$GET_VALUE('QUEUE',QUEUE,ILEN) ! Get queue name + IF (ILEN.EQ.0) THEN + QUEUE = 'SYS$PRINT' + ILEN = 9 + END IF + + CALL ADD_2_ITMLST(ILEN,SJC$_QUEUE,%LOC(QUEUE)) + CALL ADD_2_ITMLST(0,SJC$_DELETE_FILE,0) + + IF (CLI$PRESENT('NOTIFY')) THEN + CALL ADD_2_ITMLST(0,SJC$_NOTIFY,0) + END IF + + IF (CLI$PRESENT('FORM')) THEN + IER = CLI$GET_VALUE('FORM',FORM_NAME,FORM_NAME_LEN) + CALL ADD_2_ITMLST(FORM_NAME_LEN,SJC$_FORM_NAME,%LOC(FORM_NAME)) + END IF + + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + + CALL END_ITMLST(SJC_ITMLST) + + IER=SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SJC_ITMLST),IOSB,,) + IF (IER.AND.(.NOT.JBC_ERROR)) THEN + CALL SYS_GETMSG(JBC_ERROR) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + ELSE IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + RETURN + +900 CALL ERRSNS(IDUMMY,IER) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + WRITE(6,1000) + CALL SYS_GETMSG(IER) + RETURN + +1000 FORMAT(' ERROR: Unable to open temporary file + & SYS$LOGIN:BULL.LIS for printing.') +1010 FORMAT(' ERROR: You have not read any message.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Specified message was not found.') +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A,/,'Date: ',A) + + END + + + + + SUBROUTINE READ(READ_COUNT,BULL_READ) +C +C SUBROUTINE READ +C +C FUNCTION: Reads a specified bulletin. +C +C PARAMETER: +C READ_COUNT - Variable to store the record in the message file +C that READ will read from. Must be set to 0 to indicate +C that it is the first read of the message. If -1, +C READ will search for the last message in the message file +C and read that one. If -2, just display header information. +C BULL_READ - Message number to be read. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /TAGS/ BULL_TAG,READ_TAG + + DATA SCRATCH_B1/0/ + + CHARACTER TODAY*11,DATETIME*23,BUFFER*(LINE_LENGTH) + CHARACTER SAVE_MSG_KEY*8 + + LOGICAL SINCE,PAGE + + CALL LIB$ERASE_PAGE(1,1) ! Clear screen + END = 0 ! Nothing outputted on screen + + IF (READ_COUNT.GT.0) GO TO 100 ! Skip init steps if this is + ! not first page of bulletin + + SINCE = .FALSE. + PAGE = .TRUE. + + IF (.NOT.PAGING) PAGE = .FALSE. + IF (INCMD(:4).EQ.'READ') THEN ! If READ command... + IF (CLI$PRESENT('MARKED')) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No marked messages found.'')') + RETURN + ELSE + READ_TAG = .TRUE. + END IF + END IF + + IF (.NOT.CLI$PRESENT('PAGE')) PAGE = .FALSE. + IF (CLI$PRESENT('SINCE')) THEN ! was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present.'')') + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + END IF + IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + CALL OPEN_BULLDIR_SHARED + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + RETURN + ELSE + BULL_READ = IER + IER = IER + 1 + END IF + SINCE = .TRUE. + END IF + END IF + + IF (READ_TAG) THEN + NEXT = .FALSE. + IF (INCMD(:4).EQ.'NEXT'.OR.INCMD.EQ.' ') THEN + NEXT = .TRUE. + ELSE IF (INCMD(:4).EQ.'READ') THEN + IF (.NOT.CLI$PRESENT('BULLETIN_NUMBER')) NEXT = .TRUE. + END IF + IF (INCMD(:4).EQ.'BACK') THEN + SAVE_MSG_KEY = MSG_KEY + MSG_KEY = BULLDIR_HEADER + I = 0 + IER = 0 + DO WHILE (IER.EQ.0.AND.MSG_KEY.NE.SAVE_MSG_KEY) + I = I + 1 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END DO + IF (IER.EQ.0) THEN + MSG_KEY = BULLDIR_HEADER + DO J=1,I-1 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END DO + IER = BULL_READ + 1 + ELSE + IER = 0 + END IF + ELSE IF (NEXT) THEN + IF (SINCE) THEN + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + ELSE + IF (BULL_POINT.GT.0) THEN + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) + CALL CLOSE_BULLDIR + ELSE + MSG_KEY = BULLDIR_HEADER + END IF + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END IF + IF (IER.EQ.0) THEN + IER = BULL_READ + 1 + ELSE + IER = 0 + END IF + END IF + END IF + + IF (.NOT.SINCE.AND. + & (.NOT.READ_TAG.OR.(.NOT.NEXT.AND.INCMD(:4).NE.'BACK'))) THEN + IF (BULL_READ.GT.0) THEN ! Valid bulletin number? + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_READ,IER) ! Get bulletin directory entry + IF (READ_COUNT.EQ.-1.AND.IER.NE.BULL_READ+1) THEN + READ_COUNT = 0 + CALL READDIR(0,IER) + IF (NBULL.GT.0) THEN + BULL_READ = NBULL + CALL READDIR(BULL_READ,IER) + ELSE + IER = 0 + END IF + END IF + CALL CLOSE_BULLDIR + ELSE + IER = 0 + END IF + END IF + + IF (IER.NE.BULL_READ+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + RETURN + END IF + + DIFF = COMPARE_BTIM(MSG_BTIM,LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF.GT.0) THEN + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = MSG_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = MSG_BTIM(2) + END IF + + BULL_POINT = BULL_READ ! Update bulletin counter + + IF (INCMD(:4).EQ.'READ'.OR.INCMD(:4).EQ.'CURR') THEN + IF (CLI$PRESENT('EDIT')) THEN + CALL READ_EDIT + RETURN + END IF + END IF + + FLEN = TRIM(FOLDER) + IF (BULL_POINT.GT.F_NBULL) F_NBULL = BULL_POINT + WRITE (INPUT,'(1X,I5,'' of '',I5)') BULL_POINT,F_NBULL + DO WHILE (INDEX(INPUT,' ').LT.TRIM(INPUT)) + I = INDEX(INPUT,' ') + INPUT(I:) = INPUT(I+1:) + END DO + I = TRIM(INPUT) + INPUT = ' #'//INPUT(2:TRIM(INPUT)) + INPUT(PAGE_WIDTH-LEN(FOLDER):) = FOLDER(:FLEN) + IF (READIT.GT.0) THEN + WRITE(6,'(A)') '+'//INPUT(:TRIM(INPUT)) + ELSE + WRITE(6,'(1X,A)') INPUT(:TRIM(INPUT)) + END IF + + END = 1 ! Outputted 1 line to screen + + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + WRITE (6,'(1X,A)') INPUT(:TRIM(INPUT)) + + END = END + 1 + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + LINE_OFFSET = 0 + CHAR_OFFSET = 0 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INPUT = 'From: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + WRITE(6,'(1X,A)') INPUT(:I) + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = 1 + ELSE + WRITE(6,'('' From: '',A)') FROM + END = END + 1 + END IF + IF (INPUT(:6).NE.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + INPUT = 'Subj: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + WRITE(6,'(1X,A)') INPUT(:I) + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = LINE_OFFSET + 1 + ELSE + IF (LINE_OFFSET.EQ.1) THEN + CHAR_OFFSET = 1 - PAGE_WIDTH + LINE_OFFSET = 2 + END IF + WRITE(6,'('' Subj: '',A)') DESCRIP + END = END + 1 + END IF + IF (LINE_OFFSET.EQ.0) ILEN = LINE_LENGTH + 1 + CALL CLOSE_BULLFIL ! End of bulletin file read + + WRITE(6,'(1X)') + IF (READIT.GT.0) WRITE(6,'(1X)') + END = END + 1 +C +C Each page of the bulletin is buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C bulletin file, and to avoid the possibility of the user holding the screen, +C and thus causing the bulletin file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_B1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + IF (SCRATCH_B1.NE.0) THEN ! Is queue empty? + SCRATCH_B = SCRATCH_B1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_B,INPUT) + SCRATCH_B1 = SCRATCH_B ! Init header pointer + END IF + + READ_ALREADY = 0 ! Number of lines already read + ! from record. + IF (READ_COUNT.EQ.-2) THEN ! Just output header first read + READ_COUNT = BLOCK + RETURN + ELSE + READ_COUNT = BLOCK ! Init bulletin record counter + END IF + + GO TO 200 + +100 IF (READIT.EQ.0) THEN ! If not 1st page of READ + WRITE (BUFFER,'(1X,I5,'' of '',I5)') BULL_POINT,F_NBULL + DO WHILE (INDEX(BUFFER,' ').LT.TRIM(BUFFER)) + I = INDEX(BUFFER,' ') + BUFFER(I:) = BUFFER(I+1:) + END DO + BUFFER = ' #'//BUFFER(2:TRIM(BUFFER)) + BUFFER(PAGE_WIDTH-LEN(FOLDER):) = FOLDER(:FLEN) + WRITE(6,'(1X,A,/)') BUFFER(:TRIM(BUFFER)) ! Output header info + END = END + 2 ! Increase display counter + END IF + +200 SCRATCH_B = SCRATCH_B1 ! Init queue pointer to header + IF (READIT.GT.0) END = END - 2 ! /READ can output 2 more lines + DISPLAY = 0 + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + MORE_LINES = .TRUE. + DO WHILE (ILEN.GT.0.AND.MORE_LINES) + IF (CHAR_OFFSET.EQ.0) THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + LINE_OFFSET = LINE_OFFSET + 1 + END IF + IF (ILEN.LT.0) THEN ! Error, couldn't read record + ILEN = 0 ! Fake end of reading file + MORE_LINES = .FALSE. + ELSE IF (ILEN.GT.0) THEN + IF (CHAR_OFFSET.EQ.0) THEN + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (LEN_TEMP.GT.PAGE_WIDTH) THEN + CHAR_OFFSET = 1 + BUFFER = INPUT(:PAGE_WIDTH) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + ELSE + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,INPUT) + END IF + ELSE + CHAR_OFFSET = CHAR_OFFSET + PAGE_WIDTH + IF (LEN_TEMP.LE.CHAR_OFFSET+PAGE_WIDTH-1) THEN + BUFFER = INPUT(CHAR_OFFSET:LEN_TEMP) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + CHAR_OFFSET = 0 + ELSE + BUFFER = INPUT(CHAR_OFFSET:CHAR_OFFSET+PAGE_WIDTH-1) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + END IF + END IF + DISPLAY = DISPLAY + 1 + IF ((DISPLAY.EQ.PAGE_LENGTH-END-4).AND.PAGE) THEN + MORE_LINES = .FALSE. + END IF + END IF + END DO + + CALL CLOSE_BULLFIL ! End of bulletin file read + +C +C Bulletin page is now in temporary memory, so output to terminal. +C Note that if this is a /READ, the first line will have problems with +C the usual FORMAT statement. It will cause a blank line to be outputted +C at the top of the screen. This is because of the input QIO at the +C end of the previous page. The output gets confused and thinks it must +C end the previous line. To prevent that, the first line of a new page +C in a /READ must use a different FORMAT statement to surpress the CR/LF. +C + + SCRATCH_B = SCRATCH_B1 ! Reinit queue pointer to head + DO I=1,DISPLAY ! Output page to terminal + CALL READ_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) ! Get queue record + IF (I.EQ.1.AND.READIT.GT.0) THEN + WRITE(6,'(A)') '+'//BUFFER(:TRIM(BUFFER)) ! (See above comments) + ELSE + WRITE(6,'(1X,A)') BUFFER(:TRIM(BUFFER)) + END IF + END DO + + IF (ILEN.EQ.0) THEN ! End of message? + READ_COUNT = 0 ! init bulletin record counter + ELSE ! Possibly end of message since end of page could be last line + CALL TEST_MORE_RECORDS(BLOCK,LENGTH,IREC) + IF (IREC.EQ.0) THEN ! Last record? + CALL TEST_MORE_LINES(ILEN) ! More lines to read? + IF (ILEN.GT.0) THEN ! Yes, there are still more + IF (READIT.EQ.0) WRITE(6,1070) ! say there is more of bulletin + ELSE ! Yes, last line anyway + READ_COUNT = 0 ! init bulletin record counter + END IF + ELSE IF (READIT.EQ.0) THEN ! Not last record so + WRITE(6,1070) ! say there is more of bulletin + END IF + END IF + + RETURN + +1030 FORMAT(' ERROR: Specified message was not found.') +1070 FORMAT(1X,/,' Press RETURN for more...',/) + +2000 FORMAT(A) + + END + + + + + + SUBROUTINE READ_EDIT + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + WRITE(3,1050) INPUT(7:ILEN) + ELSE + WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + CALL CLOSE_BULLFIL + + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A,' Date: ',A) + + RETURN + END + + + SUBROUTINE READNEW(REDO) +C +C SUBROUTINE READNEW +C +C FUNCTION: Displays new non-system bulletins with prompts between bulletins. +C + + IMPLICIT INTEGER (A-Z) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /POINT/ BULL_POINT + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + CHARACTER INREAD*1,FILE_DEF*80,NUMREAD*5 + + DATA LEN_FILE_DEF /0/, INREAD/0/ + + LOGICAL SLOW,SLOW_TERMINAL + + FIRST_MESSAGE = BULL_POINT + + IF (ICHAR(INREAD).EQ.0) THEN ! If calling READNEW for first time + SLOW = SLOW_TERMINAL() ! Check baud rate of terminal + END IF ! to avoid gobs of output + + LEN_P = 0 ! Tells read subroutine there is + ! no bulletin parameter + +1 WRITE(6,1000) ! Ask if want to read new bulletins + + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0) THEN + INREAD = NUMREAD(:1) + IF (INREAD.EQ.'N'.OR.INREAD.EQ.'Q'.OR.INREAD.EQ.'E') THEN + IF (INREAD.EQ.'Q') THEN + WRITE (6,'(''+uit'',$)') + ELSE IF (INREAD.EQ.'E') THEN + WRITE (6,'(''+xit'',$)') + DO I=1,FLONG ! Just show SYSTEM folders + NEW_MSG(I) = NEW_MSG(I).AND.SYSTEM_FLAG(I) + END DO + DO I=1,FLONG ! Test for new messages in SYSTEM folders + IF (NEW_MSG(I).NE.0) RETURN + END DO + CALL EXIT + ELSE + WRITE (6,'(''+o'',$)') + END IF + RETURN ! If NO, exit + ! Include QUIT to be consistent with next question + ELSE + CALL LIB$ERASE_PAGE(1,1) + END IF + END IF + +3 IF (TEMP_READ.GT.0) THEN + IF (TEMP_READ.LT.FIRST_MESSAGE+1.OR.TEMP_READ.GT.NBULL) THEN + WRITE (6,'('' ERROR: Specified new message not found.'')') + GO TO 1 + ELSE + BULL_POINT = TEMP_READ - 1 + END IF + END IF + + READ_COUNT = 0 ! Initialize display pointer + +5 CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + FILE_POINT = BULL_POINT + IF (READ_COUNT.EQ.0) THEN ! Is full bulletin displayed? + CALL OPEN_BULLDIR_SHARED ! If so, see if more new bulls +10 CALL READDIR(BULL_POINT+1,IER_POINT) + IF ((IER_POINT.EQ.BULL_POINT+2).AND. ! If system bulletin (and system + & (SYSTEM.AND.BTEST(FOLDER_FLAG,2))) THEN ! folder) then skip it. + BULL_POINT = BULL_POINT + 1 + GO TO 10 + END IF + CALL CLOSE_BULLDIR + END IF + +12 IF (READ_COUNT.EQ.0) THEN ! Prompt user in between + WRITE(6,1020) ! full screens or end of bull. + ELSE + WRITE(6,1030) + END IF + + CALL GET_INPUT_NOECHO(INREAD) + CALL STR$UPCASE(INREAD,INREAD) ! Convert input to upper case + + IF (INREAD.EQ.'Q') THEN ! If Q , then QUIT + WRITE (6,'(''+Quit'',$)') + RETURN + ELSE IF (INREAD.EQ.'D') THEN ! If D , then redisplay directory + WRITE (6,'(''+Dir'',$)') + REDO = .TRUE. + RETURN + ELSE IF (INREAD.EQ.'F') THEN ! If F then copy bulletin to file + WRITE (6,'(''+ '')') ! Move cursor from end of prompt line + ! to beginning of next line. + IF (LEN_FILE_DEF.EQ.0) THEN + CALL LIB$SYS_TRNLOG('SYS$LOGIN',ILEN,FILE_DEF) + IER = LIB$FIND_FILE(FILE_DEF//'BULL.DIR', + & BULL_PARAMETER,CONTEXT) + IF (IER) THEN + FILE_DEF = BULL_PARAMETER(:ILEN-1)//'.BULL]' + LEN_FILE_DEF = ILEN + 5 + ELSE + FILE_DEF = 'SYS$LOGIN:' + LEN_FILE_DEF = 10 + END IF + END IF + + LEN_FOLDER = TRIM(FOLDER) + CALL GET_INPUT_PROMPT(BULL_PARAMETER,LEN_P, + & 'Name of file? (Default='//FILE_DEF(:LEN_FILE_DEF)// + & FOLDER(:LEN_FOLDER)//'.LIS) ') + + IF (LEN_P.EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)//FOLDER(:LEN_FOLDER) + & //'.LIS' + LEN_P = LEN_FILE_DEF + LEN_FOLDER + 4 + ELSE + IER = LIB$SYS_TRNLOG(BULL_PARAMETER(:LEN_P),ILEN,INPUT) + IF (IER.NE.1.AND.INDEX(BULL_PARAMETER(:LEN_P),':').EQ.0 + & .AND.INDEX(BULL_PARAMETER(:LEN_P),'[').EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)// + & BULL_PARAMETER(:LEN_P) + LEN_P = LEN_P + LEN_FILE_DEF + END IF + END IF + + BLOCK_SAVE = BLOCK + LENGTH_SAVE = LENGTH + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + CALL READDIR(FILE_POINT,IER) + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH,ERR=18,STATUS='UNKNOWN', + & CARRIAGECONTROL='LIST',ACCESS='APPEND') + WRITE(3,1050) DESCRIP ! Output bulletin header info + WRITE(3,1060) FROM,DATE//' '//TIME(:5) + ILEN = LINE_LENGTH + 1 + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE(3,'(A)') INPUT(:TRIM(INPUT)) + END DO + IF (ILEN.EQ.0) WRITE(6,1040) BULL_PARAMETER(:LEN_P) + ! Show name of file created. +18 IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + END IF + CLOSE (UNIT=3) ! Bulletin copy completed + IF (READ_COUNT.GT.0) THEN ! Reposition GET_BULL routine + ILEN = LINE_LENGTH + 1 ! in case read in progress + DO I=1,LINE_OFFSET ! and partial block was read. + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + END IF + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + LENGTH = LENGTH_SAVE + BLOCK = BLOCK_SAVE + CALL ENABLE_PRIVS ! Reset BYPASS privileges + GO TO 12 + ELSE IF (INREAD.EQ.'N'.AND.READ_COUNT.GT.0) THEN + ! If NEXT and last bulletins not finished + READ_COUNT = 0 ! Reset read bulletin counter + CALL OPEN_BULLDIR_SHARED ! Look for NEXT bulletin +20 CALL READDIR(BULL_POINT+1,IER) + IF (IER.NE.BULL_POINT+2) THEN ! If no NEXT bulletin + CALL CLOSE_BULLDIR ! Exit + WRITE(6,1010) + RETURN + ELSE IF (SYSTEM.AND.BTEST(FOLDER_FLAG,2)) THEN + BULL_POINT = BULL_POINT + 1 ! If SYSTEM bulletin, skip it + GO TO 20 ! Look for more bulletins + END IF + CALL CLOSE_BULLDIR + ELSE IF (INREAD.EQ.'R') THEN + WRITE (6,'(''+Read'')') + WRITE (6,'('' Enter message number: '',$)') + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0.OR.TEMP_READ.LE.0) THEN + WRITE (6,'('' ERROR: Invalid message number specified.'')') + GO TO 12 + ELSE + GO TO 3 + END IF + ELSE IF (IER_POINT.NE.BULL_POINT+2.AND.READ_COUNT.EQ.0) THEN + WRITE(6,1010) + RETURN + END IF + IF (READ_COUNT.EQ.0.AND.SLOW) READ_COUNT = -2 + GO TO 5 + +1000 FORMAT(' Read messages? Type N(No),E(Exit),message + & number, or any other key for yes: ',$) +1010 FORMAT(' No more messages.') +1020 FORMAT(1X,('-'),/,' Type Q(Quit), + & F(File it), D(Dir), R(Read msg #) or other for next message: ',$) +1030 FORMAT(1X,('-'),/,' Type Q(Quit), F(File), N(Next), + & D(Dir), R(Read msg #) or other for MORE: ',$) +1040 FORMAT(' Message written to ',A) +1050 FORMAT(/,'Description: ',A53) +1060 FORMAT('From: ',A12,' Date: ',A20,/) + + END + + + + + SUBROUTINE SET_DEFAULT_EXPIRE +C +C SUBROUTINE SET_DEFAULT_EXPIRE +C +C FUNCTION: Sets default expiration date. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER EXPIRE*3 + + IF (SETPRV_PRIV().OR.USERNAME.EQ.FOLDER_OWNER) THEN + IER = CLI$GET_VALUE('DEFAULT_EXPIRE',EXPIRE,EX_LEN) + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + ELSE IF (TEMP.LT.-1) THEN + WRITE (6,'('' ERROR: Expiration must be > -1.'')') + ELSE + FOLDER_BBEXPIRE = TEMP + WRITE (6,'('' Default expiration modified.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to set expiration.'')') + END IF + + RETURN + END diff --git a/decus/vax89a2/nieland/bulletin/bulletin2.for b/decus/vax89a2/nieland/bulletin/bulletin2.for new file mode 100644 index 0000000..6803435 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin2.for @@ -0,0 +1,1520 @@ +C +C BULLETIN2.FOR, Version 6/2/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE SET_BBOARD(BBOARD) +C +C SUBROUTINE SET_BBOARD +C +C FUNCTION: Set username for BBOARD for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($UAIDEF)' + + EXTERNAL CLI$_ABSENT + + CHARACTER EXPIRE*3,INPUT_BBOARD*12,TODAY*23,RESPONSE*1 + + IF (TRIM(BBOARD_DIRECTORY).EQ.0) THEN + WRITE(6,'('' ERROR: System programmer has disabled BBOARD.'')') + RETURN + END IF + + IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + WRITE (6,'( + & '' ERROR: Cannot set BBOARD for remote folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + + IF (BBOARD) THEN + IER = CLI$GET_VALUE('BB_USERNAME',INPUT_BBOARD,INPUT_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_UAF + & (INPUT_BBOARD,USERB,GROUPB,ACCOUNTB,FLAGS,IER1) + CALL CLOSE_BULLFOLDER + IF (IER1.AND..NOT.BTEST(FLAGS,UAI$V_DISACNT)) THEN ! DISUSER? + WRITE (6,'('' ERROR: '',A, + & '' account needs DISUSER flag set.'')') + & INPUT_BBOARD(:INPUT_LEN) + RETURN + ELSE IF (IER1.AND.BTEST(USERB,31)) THEN + WRITE (6,'('' ERROR: User number of UIC cannot '', + & ''be greater than 7777777777.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_TEMP(IER) + DO WHILE ((FOLDER1_BBOARD.NE.INPUT_BBOARD.OR. + & FOLDER1_NUMBER.EQ.FOLDER_NUMBER).AND.IER.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER) + END DO + IF (FOLDER1_BBOARD.EQ.INPUT_BBOARD.AND. + & FOLDER1_NUMBER.NE.FOLDER_NUMBER) THEN + WRITE (6,'( + & '' ERROR: Account used by other folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + IF (.NOT.IER1) THEN + CALL CLOSE_BULLFOLDER + WRITE (6,'('' WARNING: '',A,'' account not in SYSUAF'', + & '' file.'')') INPUT_BBOARD(:INPUT_LEN) + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Is the name a mail forwarding entry? '// + & '(Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + USERB = 1 ! Fake userb/groupb, as old method of + GROUPB = 1 ! indicating /SPECIAL used [0,0] + END IF + GROUPB1 = GROUPB + USERB1 = USERB + ACCOUNTB1 = ACCOUNTB + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + GROUPB = GROUPB1 + USERB = USERB1 + ACCOUNTB = ACCOUNTB1 + FOLDER_BBOARD = INPUT_BBOARD + CALL OPEN_BULLUSER + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM(TODAY,BBOARD_BTIM) + REWRITE (4) USER_HEADER + CALL CLOSE_BULLUSER + IF (CLI$PRESENT('SPECIAL')) THEN ! SPECIAL specified? + USERB = IBSET(USERB,31) ! Set bit to show /SPECIAL + IF (CLI$PRESENT('VMSMAIL')) THEN + GROUPB = IBSET(GROUPB,31) ! Set bit to show /VMSMAIL + END IF + END IF + ELSE IF (CLI$PRESENT('SPECIAL')) THEN + USERB = IBSET(0,31) ! Set top bit to show /SPECIAL + GROUPB = 0 + DO I=1,LEN(FOLDER_BBOARD) + FOLDER_BBOARD(I:I) = ' ' + END DO + ELSE IF (FOLDER_BBOARD.EQ.'NONE') THEN + WRITE (6,'('' ERROR: No BBOARD specified for folder.'')') + END IF + + IER = CLI$GET_VALUE('EXPIRATION',EXPIRE,EX_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (TEMP.LE.0) THEN + WRITE (6,'('' ERROR: Expiration must be > 0.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + FOLDER_BBEXPIRE = TEMP + END IF + ELSE IF (.NOT.CLI$PRESENT('EXPIRATION')) THEN + FOLDER_BBEXPIRE = -1 + END IF + ELSE + FOLDER_BBOARD = 'NONE' + END IF + + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + WRITE (6,'('' BBOARD has been modified for folder.'')') + ELSE + WRITE (6,'('' You are not authorized to modify BBOARD.'')') + END IF + + RETURN + END + + + + + + + SUBROUTINE SET_SYSTEM(SYSTEM_SET) +C +C SUBROUTINE SET_SYSTEM +C +C FUNCTION: Set SYSTEM specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + ELSE IF (SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (SYSTEM_SET) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been set.'')') + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been removed.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL MODIFY_SYSTEM_LIST(0) + CALL CLOSE_BULLFOLDER + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + ELSE + WRITE (6,'('' You are not authorized to modify SYSTEM.'')') + END IF + + RETURN + END + + + + SUBROUTINE MODIFY_SYSTEM_LIST(FILE_OPENED) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + INTEGER SHUTDOWN_BTIM(FLONG),VERSION(FLONG) + + CHARACTER UPDATE*11,UPTIME*8 + + INTEGER UP_BTIM(2) + + IF (.NOT.FILE_OPENED) CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0.OR.VERSION(1).NE.168) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + SHUTDOWN_BTIM(1) = 0 + SHUTDOWN_BTIM(2) = 0 + NODE_NUMBER = 0 + NODE_AREA = 0 + IF (IER.EQ.0) THEN + DO WHILE (TEMP_USER(:7).EQ.'*SYSTEM'.AND.IER.EQ.0) + DELETE (UNIT=4) + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) TEMP_USER + END DO + END DO + IER = 2 + ELSE + VERSION(1) = 168 + END IF + END IF + + IF (VERSION(1).NE.168) THEN + CALL CLOSE_BULLFOLDER + CALL OPEN_BULLFOLDER + NODE_AREA = 0 + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + END DO + IER1 = 0 + DO WHILE (IER1.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER1) + IF (BTEST(FOLDER1_FLAG,2).AND.IER1.EQ.0) THEN + CALL SET2(SYSTEM_FLAG,FOLDER1_NUMBER) + END IF + END DO + VERSION(1) = 168 + END IF + + IF (BTEST(FOLDER_FLAG,2)) THEN + CALL SET2(SYSTEM_FLAG,FOLDER_NUMBER) + ELSE + CALL CLR2(SYSTEM_FLAG,FOLDER_NUMBER) + END IF + + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14,BTEST(FOLDER_FLAG,2), + & NODENAME + IF (IER1.NE.0) THEN + CALL DISCONNECT_REMOTE + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + RETURN + END IF + END IF + + CALL GET_UPTIME(UPDATE,UPTIME) + + CALL SYS_BINTIM(UPDATE//' '//UPTIME,UP_BTIM) + + IF (NODE_AREA.EQ.0) THEN + IF (SHUTDOWN_BTIM(1).EQ.0) THEN + DIFF = -1 + ELSE + DIFF = COMPARE_BTIM(SHUTDOWN_BTIM,UP_BTIM) + END IF + IF (DIFF.EQ.-1) THEN + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + SHUTDOWN_BTIM(1) = UP_BTIM(1) + SHUTDOWN_BTIM(2) = UP_BTIM(2) + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + END IF + ELSE ! Test to make sure NODE_AREA is zero + SEEN_FLAG = 0 ! if all of SHUTDOWN_FLAG is zero + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 + END IF + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + + RETURN + END + + + + SUBROUTINE GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) + CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) + CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist + + IER = SYS$GETSYIW(,,,%VAL(GETSYI_ITMLST),,,) ! Get Info command. +C +C NODE_AREA is set to 0 after shutdown messages are deleted. +C If node is not part of cluster, NODE_AREA will be 0, +C so set it to 1 as a dummy value to cause messages to be deleted. +C + IF (NODE_AREA.EQ.0) NODE_AREA = 1 + + RETURN + END + + + + + SUBROUTINE SET_NODE(NODE_SET) +C +C SUBROUTINE SET_NODE +C +C FUNCTION: Set or reset remote node specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,FOLDER_SAVE*25 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) ! Get folder name + FOLDER_SAVE = FOLDER + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + IF (IER.EQ.0) THEN + IF (FOLDER_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: No privs to modify folder.'')') + IER = 1 + END IF + ELSE + WRITE (6,'('' ERROR: Specified folder not found.'')') + END IF + IF (IER.NE.0) THEN + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + RETURN + END IF + CALL CLOSE_BULLFOLDER + END IF + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' Cannot set remote node for GENERAL folder.'')') + ELSE IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + IF (.NOT.NODE_SET) THEN + IF (INDEX(FOLDER_BBOARD,'*').GT.0) THEN + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + CALL OPEN_BULLDIR ! Remove directory file which + CALL CLOSE_BULLDIR_DELETE ! contains remote folder name + REMOTE_SET = REMOTE_SET_SAVE + END IF + FOLDER1_BBOARD = 'NONE' + WRITE (6,'('' Remote node setting has been removed.'')') + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .FALSE. + ELSE + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Are you sure you want to make folder '// + & FOLDER(:TRIM(FOLDER))// + & ' remote? (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + IER = CLI$GET_VALUE('NODENAME',FOLDER1_BBOARD,FLEN) + FOLDER1_BBOARD = '::'//FOLDER1_BBOARD(:FLEN) + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'( + & '' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE + WRITE (6,'('' Folder has been converted to remote.'')') + END IF + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + IF (FOLDER.NE.FOLDER1) THEN ! Different remote folder name? + CALL OPEN_BULLDIR ! If so, put name in header + BULLDIR_HEADER(13:) = FOLDER1 ! of directory file. + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:FLEN+2)//'*' + END IF + REMOTE_SET = REMOTE_SET_SAVE + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .TRUE. + END IF + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (.NOT.NODE_SET.AND.FOLDER_BBOARD(:2).EQ.'::' + & .AND.BTEST(FOLDER_FLAG,2)) THEN + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER_BBOARD(3:TRIM(FOLDER_BBOARD)) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Disregister remote SYSTEM folder + WRITE(17,'(2A)',IOSTAT=IER) 14,0 + CLOSE (UNIT=17) + END IF + END IF + FOLDER_BBOARD = FOLDER1_BBOARD + IF (NODE_SET) THEN + F_NBULL = F1_NBULL + F_NEWEST_BTIM(1) = F1_NEWEST_BTIM(1) + F_NEWEST_BTIM(2) = F1_NEWEST_BTIM(2) + F_NEWEST_NOSYS_BTIM(1) = F1_NEWEST_NOSYS_BTIM(1) + F_NEWEST_NOSYS_BTIM(2) = F1_NEWEST_NOSYS_BTIM(2) + FOLDER_FLAG = 0 + F_EXPIRE_LIMIT = F1_EXPIRE_LIMIT + ELSE + F_NBULL = 0 + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to modify NODE.'')') + END IF + + IF (CLI$PRESENT('FOLDER')) THEN + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + END IF + + RETURN + END + + + + + SUBROUTINE RESPOND(STATUS) +C +C SUBROUTINE RESPOND +C +C FUNCTION: Sends a mail message in reply to a posted message. +C +C NOTE: Modify the last SPAWN statement to specify the command +C you use to send mail to sites other than via MAIL. +C If you always use a different command, modify both +C spawn commands. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER FROM_TEST*5,INFROM*(LINE_LENGTH) + + EXTERNAL CLI$_NEGATED + + IF (INCMD(:4).NE.'POST') THEN + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + BULL_PARAMETER = 'RE: '//DESCRIP + END IF + + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',BULL_PARAMETER,LEN_P) + IF (LEN_P.GT.LEN(BULL_PARAMETER)-2) THEN + WRITE(6,'('' ERROR: Subject limit is 64 characters.'')') + RETURN + END IF + ELSE IF (INCMD(:4).EQ.'POST') THEN + WRITE(6,'('' Enter subject of message:'')') + CALL GET_LINE(BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.0) THEN + WRITE(6,'('' ERROR: No subject specified.'')') + RETURN + END IF + END IF + + LEN_P = TRIM(BULL_PARAMETER) + + IF (BULL_PARAMETER(:1).NE.'"') THEN + BULL_PARAMETER = '"'//BULL_PARAMETER(:LEN_P) + LEN_P = LEN_P + 1 + END IF + + IF (BULL_PARAMETER(LEN_P:LEN_P).NE.'"') THEN + BULL_PARAMETER = BULL_PARAMETER(:LEN_P)//'"' + LEN_P = LEN_P + 1 + END IF + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + EDIT = .TRUE. + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + ELSE + EDIT = .FALSE. + END IF + + IF (EDIT.AND.CLI$PRESENT('TEXT')) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + RETURN + END IF + END IF + + LENFRO = 0 + IF (CLI$GET_VALUE('CC',INPUT,ILEN)) THEN + INFROM = INPUT(:ILEN)//',' + LENFRO = ILEN + 1 + END IF + + IF ((EDIT.AND.CLI$PRESENT('TEXT')).OR. + & INCMD(:4).NE.'POST') THEN + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INFROM = INFROM(:LENFRO)//INPUT(7:) + LENFRO = LENFRO + ILEN - 6 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + INFROM = INFROM(:LENFRO)//FROM + LENFRO = TRIM(FROM) + LENFRO + END IF + + IF (CLI$PRESENT('LIST')) THEN + INFROM = INFROM(:LENFRO)//',' + LENFRO = LENFRO + 1 + END IF + + IF (EDIT.AND.CLI$PRESENT('TEXT')) THEN + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + + CALL CLOSE_BULLFIL + END IF + + IF (CLI$PRESENT('LIST')) THEN + LIST = INDEX(FOLDER_DESCRIP,'<') + IF (LIST.GT.0) THEN + INFROM = INFROM(:LENFRO)// + & FOLDER_DESCRIP(LIST+1:TRIM(FOLDER_DESCRIP)-1) + LENFRO = LENFRO + TRIM(FOLDER_DESCRIP) - 1 - LIST + ELSE + WRITE (6,'('' ERROR: No list address'', + & '' found in folder description.'')') + GO TO 900 + END IF + END IF +C +C NOTE: Normally, RESPOND simply uses MAIL to respond to bulletin message. +C However, if you have a special mail package, you will have to make some +C sort of modification to the code. At PFC, we are still awaiting INTERNET, +C so we get our mail sent from the user PFCVAX::CHAOSMAIL. Therefore, I have +C to test for that username, and then look for a FROM: line in the message in +C in order to find who really to respond to. However, most sites will +C have intelligent network connections which can use the MAIL utility. +C + IF (INDEX(INFROM,'PFCVAX::CHAOSMAIL').EQ.0.AND. + & INDEX(INFROM,'MFENET::').EQ.0) THEN + I = 1 ! Must change all " to "" in FROM field + DO WHILE (I.LE.LENFRO) + IF (INFROM(I:I).EQ.'"') THEN + INFROM = INFROM(:I)//'"'//INFROM(I+1:) + I = I + 1 + LENFRO = LENFRO + 1 + END IF + I = I + 1 + END DO + CALL DISABLE_PRIVS + IF (EDIT) THEN + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + IF (CLI$PRESENT('TEXT')) THEN + CONTEXT = 0 + CALL LIB$FIND_FILE('SYS$LOGIN:BULL.SCR',INPUT,CONTEXT) + VERSION = INDEX(INPUT,';') + 1 + IF (INPUT(VERSION:VERSION).EQ.'1') THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + END IF + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR "'//INFROM(:LENFRO) + & //'"/SUBJECT='//BULL_PARAMETER,,,,,,STATUS) + ELSE + CALL LIB$SPAWN('$MAIL SYS$INPUT "'//INFROM(:LENFRO)// + & '"/SUBJECT='//BULL_PARAMETER,,,,,,STATUS) + END IF + CALL ENABLE_PRIVS + ELSE + IF (INCMD(:4).NE.'POST') THEN + FROM_TEST = ' ' + CALL OPEN_BULLFIL_SHARED + L_INPUT = LINE_LENGTH + 1 + DO WHILE (L_INPUT.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,L_INPUT) + IF (L_INPUT.GT.0) THEN + CALL STR$UPCASE(FROM_TEST,INPUT(:5)) + IF (FROM_TEST.EQ.'FROM:'.AND. + & INDEX(INPUT,'PFCVAX::CHAOSMAIL').EQ.0) THEN + IF (INDEX(INPUT,'.').GT.0.OR.INDEX(INPUT,'@').GT.0 + & .OR.INDEX(INPUT,'%').GT.0) THEN + L_INPUT = 0 + END IF + END IF + END IF + END DO + CALL CLOSE_BULLFIL + IF (FROM_TEST.EQ.'FROM:') THEN + L_B = INDEX(INPUT,'<') + R_B = INDEX(INPUT,'>') + IF (L_B.GT.0.AND.R_B.GT.0) THEN + INPUT = INPUT(L_B+1:R_B-1) + L_INPUT = R_B - 1 - L_B + ELSE + L_INPUT = TRIM(INPUT) + I = 6 + DO WHILE (INPUT(I:I).EQ.' '.AND.I.GT.0) + I = I + 1 + IF (I.GT.L_INPUT) I = 0 + END DO + INPUT = INPUT(I:L_INPUT) + L_INPUT = L_INPUT - I + 1 + END IF + I = INDEX(INFROM,'PFCVAX::CHAOSMAIL') + INFROM = INFROM(:I-1)//INPUT(:L_INPUT)//INFROM(I+17:) + LENFRO = LENFRO - 17 + L_INPUT + END IF + END IF + I = INDEX(INFROM,'MFENET::') + IF (I.GT.0) THEN + INFROM = INFROM(:I-1)//INFROM(I+8:) + LENFRO = LENFRO - 8 + END IF + CALL DISABLE_PRIVS + IF (EDIT) THEN + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR PFCVAX::'// + & 'MFENET/SUBJECT="'//INFROM(:LENFRO)//'"',,,,,,STATUS) + ELSE + CALL LIB$SPAWN('$MAIL SYS$INPUT PFCVAX::MFENET'// + & '/SUBJECT="'//INFROM(:LENFRO)//'"',,,,,,STATUS) + END IF + CALL ENABLE_PRIVS + END IF + +900 IF (EDIT) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + + END + + + INTEGER FUNCTION CONFIRM_USER(USERNAME) +C +C FUNCTION CONFIRM_USER +C +C FUNCTION: Confirms that username is valid user. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + CALL OPEN_SYSUAF_SHARED + + READ (8,KEY=USERNAME,IOSTAT=CONFIRM_USER) + + CALL CLOSE_SYSUAF + + RETURN + END + + + + + + SUBROUTINE REPLACE +C +C SUBROUTINE REPLACE +C +C FUNCTION: Replaces existing bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER INEXDATE*11,INEXTIME*11 + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH) + CHARACTER*1 ANSWER + + CHARACTER DATE_SAVE*11,TIME_SAVE*11 + + INTEGER TIMADR(2) + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + LOGICAL*1 DOALL + +C +C Get the bulletin number to be replaced. +C + IF (.NOT.CLI$PRESENT('NUMBER')) THEN ! No number has been specified + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE (6,1005) ! Tell user of the error + RETURN ! and return + END IF + NUMBER_PARAM = BULL_POINT ! Replace the bulletin we are reading + ELSE + CALL CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + DECODE(LEN_P,'(I)',BULL_PARAMETER) NUMBER_PARAM + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to system.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SYSTEM cannot be set with selected folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to shutdown.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SHUTDOWN cannot be set with selected folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('PERMANENT').AND. + & .NOT.FOLDER_SET.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to permanent.'')') + RETURN + END IF +C +C Check to see if specified bulletin is present, and if the user +C is permitted to replace the bulletin. +C + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(NUMBER_PARAM,IER) ! Get info for specified bulletin + + CALL CLOSE_BULLDIR + + IF (IER.NE.NUMBER_PARAM+1) THEN ! Was bulletin found? + WRITE (6,1015) ! If not, tell the person + RETURN ! and error out + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.SETPRV_PRIV().AND. + & USERNAME.NE.FOLDER_OWNER.AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1090) ! If not, then error out. + RETURN + ELSE + WRITE (6,1100) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER ! Get his answer + CALL STR$UPCASE(ANSWER,ANSWER) ! Convert input to uppercase + IF (ANSWER.NE.'Y') RETURN ! If not Yes, then exit + END IF + END IF + +C +C If no switches were given, replace the full bulletin +C + + DOALL = .FALSE. + + IF ((.NOT.CLI$PRESENT('EXPIRATION')).AND. + & (.NOT.CLI$PRESENT('GENERAL')).AND. + & (.NOT.CLI$PRESENT('SYSTEM')).AND. + & (.NOT.CLI$PRESENT('HEADER')).AND. + & (.NOT.CLI$PRESENT('SUBJECT')).AND. + & (.NOT.CLI$PRESENT('TEXT')).AND. + & (.NOT.CLI$PRESENT('SHUTDOWN')).AND. + & (.NOT.CLI$PRESENT('PERMANENT'))) THEN + DOALL = .TRUE. + END IF + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + +8 LENDES = 0 + IF (CLI$PRESENT('HEADER').OR.DOALL) THEN + WRITE(6,1050) ! Request header for bulletin + READ(5,'(Q,A)',END=910,ERR=910) LENDES,INDESCRIP + IF (LENDES.EQ.0) GO TO 910 ! If no header, don't add bull + ELSE IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + END IF + + IF (LENDES.GT.0) THEN + INDESCRIP = 'Subj: '//INDESCRIP + LENDES = MIN(LENDES+6,LEN(INDESCRIP)) + END IF + + REC1 = 0 + + LENFROM = 0 + + IF (LENDES.GT.0.OR.CLI$PRESENT('TEXT').OR.DOALL) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='SCRATCH',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + REC1 = 1 + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INFROM = INPUT(:ILEN) + LENFROM = ILEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (LENDES.EQ.0.AND..NOT.DOALL) THEN + INDESCRIP = INPUT(:ILEN) + LENDES = ILEN + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + CALL CLOSE_BULLFIL + + IF (CLI$PRESENT('TEXT').OR.DOALL) CLOSE(UNIT=3) + END IF + + IF (CLI$PRESENT('TEXT').OR.DOALL) THEN +C +C If file specified in REPLACE command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + ICOUNT = 0 ! Line count for bulletin + LAST_NOBLANK = 0 ! Last line with data + REC1 = 1 + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT).OR. ! If file param in ADD command + & ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! or /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)))) THEN + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + IF (LEN_P.EQ.0) THEN ! If no file param specified + IF (.NOT.CLI$PRESENT('NEW')) THEN + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='NEW', + & RECL=LINE_LENGTH, + & ERR=920,FORM='FORMATTED',CARRIAGECONTROL='LIST') + CALL OPEN_BULLFIL_SHARED ! Prepare to copy message + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy message into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + CALL CLOSE_BULLFIL + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + ELSE + IF (.NOT.SETPRV_PRIV()) CALL DISABLE_PRIVS + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + END IF + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;-1') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + ELSE IF (LEN_P.GT.0) THEN + IF (.NOT.SETPRV_PRIV()) CALL DISABLE_PRIVS + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD', + & READONLY,SHARED,ERR=920,FORM='FORMATTED') ! Try opening the file + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT ! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + CALL STR$TRIM(INPUT,INPUT,ILEN) + IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN + 1 ! Increment record count + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0) THEN + IF (ICOUNT.GT.0) THEN + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + ELSE ! 1 space for a blank line. + REC1 = REC1 + 1 + END IF + END IF + END DO + ELSE ! If no input file + OPEN (UNIT=3,STATUS='NEW',FILE='SYS$LOGIN:BULL.SCR',ERR=920, + & DISPOSE='DELETE',FORM='FORMATTED',RECL=LINE_LENGTH, + & CARRIAGECONTROL='LIST') ! Scratch file to save bulletin + WRITE (6,1000) ! Request bulletin input from terminal + ILEN = LINE_LENGTH ! Length of input line + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Line too long. + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput::'')') LINE_LENGTH + ELSE IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + 1 + ILEN ! Increment character count + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.0) THEN + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + END IF ! 1 space for a blank line. + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 ICOUNT = LAST_NOBLANK + IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + END IF + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + DATE_SAVE = DATE + TIME_SAVE = TIME + INPUT = DESCRIP + + CALL OPEN_BULLDIR ! Prepare to add dir entry + + CALL READDIR(NUMBER_PARAM,IER) ! Get info for message + + IF (IER.NE.NUMBER_PARAM+1.OR.DATE.NE.DATE_SAVE.OR. + & TIME.NE.TIME_SAVE.OR.INPUT.NE.DESCRIP) THEN + ! If message disappeared, try to find it. + IF (IER.NE.NUMBER_PARAM+1) DATE = ' ' + NUMBER_PARAM = 0 + IER = 1 + DO WHILE (IER.EQ.NUMBER_PARAM+1.AND. + & (DATE.NE.DATE_SAVE.OR.TIME.NE.TIME_SAVE.OR.DESCRIP.NE.INPUT)) + NUMBER_PARAM = NUMBER_PARAM + 1 + CALL READDIR(NUMBER_PARAM,IER) + END DO + + IF (IER.NE.NUMBER_PARAM+1) THEN ! Couldn't find message + CALL CLOSE_BULLDIR + CLOSE (UNIT=3,STATUS='SAVE') + WRITE(6,'('' ERROR: Message has been deleted'', + & '' by another user.'')') + IF (DOALL.OR.CLI$PRESENT('TEXT')) THEN + WRITE (6,'('' New text has been saved in'', + & '' SYS$LOGIN:BULL.SCR.'')') + END IF + GO TO 100 + END IF + END IF + + CALL READDIR(0,IER) ! Get directory header + + IF (REC1.GT.0) THEN ! If text has been replaced + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + BLOCK = NBLOCK + 1 + BLOCK_SAVE = BLOCK + NEMPTY = NEMPTY + LENGTH + NBLOCK = NBLOCK + ICOUNT + + IF (.NOT.REMOTE_SET) CALL WRITEDIR(0,IER) + + OBLOCK = BLOCK + IF (LENFROM.GT.0) THEN + CALL STORE_BULL(LENFROM,INFROM(:LENFROM),OBLOCK) + END IF + IF (LENDES.GT.0) THEN + CALL STORE_BULL(LENDES,INDESCRIP(:LENDES),OBLOCK) + END IF + REWIND (UNIT=3) + CALL COPY_BULL(3,REC1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) THEN ! Error in creating bulletin + WRITE (6,'(A)') ' ERROR: Unable to replace message.' + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + END IF + + LENGTH_SAVE = OCOUNT - BLOCK + 1 + + CALL CLOSE_BULLFIL + + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(NUMBER_PARAM,IER) ! Get directory entry + LENGTH = LENGTH_SAVE ! Update size + BLOCK = BLOCK_SAVE + CALL WRITEDIR(NUMBER_PARAM,IER) ! Write new directory entry + END IF + ELSE + CALL READDIR(NUMBER_PARAM,IER) + END IF + + IF (.NOT.REMOTE_SET) THEN + + IF (LENDES.GT.0.OR.DOALL) THEN + DESCRIP=INDESCRIP(7:59) ! Update description header + END IF + CALL UPDATE_DIR_HEADER(CLI$PRESENT('EXPIRATION').OR.DOALL, + & CLI$PRESENT('PERMANENT'),CLI$PRESENT('SHUTDOWN'), + & INEXDATE,INEXTIME) + IF (CLI$PRESENT('SYSTEM')) THEN + SYSTEM = IBSET(SYSTEM,0) + ELSE IF (CLI$PRESENT('GENERAL')) THEN + SYSTEM = IBCLR(SYSTEM,0) + END IF + CALL WRITEDIR(NUMBER_PARAM,IER) + ELSE + MSGTYPE = 0 + IF (CLI$PRESENT('SYSTEM').OR. + & (BTEST(SYSTEM,0).AND..NOT.CLI$PRESENT('GENERAL'))) THEN + MSGTYPE = IBSET(MSGTYPE,0) + END IF + IF (CLI$PRESENT('PERMANENT')) THEN + MSGTYPE = IBSET(MSGTYPE,1) + ELSE IF (CLI$PRESENT('SHUTDOWN')) THEN + MSGTYPE = IBSET(MSGTYPE,2) + ELSE IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + MSGTYPE = IBSET(MSGTYPE,3) + END IF + IF (LENDES.EQ.0.AND..NOT.DOALL) INDESCRIP(7:) = DESCRIP + IF (CLI$PRESENT('EXPIRATION')) THEN + EXDATE = INEXDATE + EXTIME = INEXTIME + END IF + WRITE (REMOTE_UNIT,'(7A)',IOSTAT=IER) + & 10,DESCRIP,NUMBER_PARAM,INDESCRIP(7:59),MSGTYPE,EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + + CALL CLOSE_BULLDIR ! Totally finished with replace + + CLOSE (UNIT=3) + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + RETURN + +910 WRITE(6,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(6,1020) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + GOTO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1005 FORMAT (' ERROR: You are not reading any message.') +1010 FORMAT (' No message was replaced.') +1015 FORMAT (' ERROR: Specified message was not found.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1090 FORMAT(' ERROR: Specified message is not owned by you.') +1100 FORMAT(' Message is not owned by you.', + & ' Are you sure you want to replace it? ',$) +2020 FORMAT(1X,A) + + END + + + + SUBROUTINE UPDATE_DIR_HEADER(EXPIRE,PERM,SHUT,INEXDATE,INEXTIME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER TODAY*23,INEXDATE*11,INEXTIME*11 + + IF (EXPIRE) THEN + SYSTEM = IBCLR(SYSTEM,1) + SYSTEM = IBCLR(SYSTEM,2) + EXDATE=INEXDATE ! Update expiration date + EXTIME=INEXTIME + DIFF = COMPARE_DATE(EXDATE,NEWEST_EXDATE) ! Compare expiration + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,NEWEST_EXTIME) + IF (DIFF.LT.0) THEN ! If it's oldest expiration bull + NEWEST_EXDATE = EXDATE ! Update the header in + NEWEST_EXTIME = EXTIME ! the directory file + CALL WRITEDIR(0,IER) + END IF + ELSE IF (PERM.AND.(.NOT.BTEST(SYSTEM,1))) THEN + IF (BTEST(SYSTEM,2)) THEN + SYSTEM = IBCLR(SYSTEM,2) + SHUTDOWN = SHUTDOWN - 1 + CALL WRITEDIR(0,IER) + END IF + SYSTEM = IBSET(SYSTEM,1) + EXDATE = '5-NOV-2000' + EXTIME = '00:00:00.00' + ELSE IF (SHUT.AND.(.NOT.BTEST(SYSTEM,2))) THEN + SYSTEM = IBSET(SYSTEM,2) + SYSTEM = IBCLR(SYSTEM,1) + EXDATE = '5-NOV-2000' + 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) + SHUTDOWN = SHUTDOWN + 1 + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + SHUTDOWN_DATE = TODAY(:11) + SHUTDOWN_TIME = TODAY(13:) + CALL WRITEDIR(0,IER) + END IF + + RETURN + END + + + + SUBROUTINE SEARCH(READ_COUNT) +C +C SUBROUTINE SEARCH +C +C FUNCTION: Search for bulletin with specified string +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*132 SEARCH_STRING,SAVE_STRING + DATA SEARCH_STRING /' '/, SEARCH_LEN /1/ + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CALL DISABLE_CTRL + + IF (CLI$PRESENT('START')) THEN ! Starting message specified + CALL CLI$GET_VALUE('START',BULL_PARAMETER,LEN_P) + DECODE(LEN_P,'(I)',BULL_PARAMETER) BULL_POINT + BULL_POINT = BULL_POINT - 1 + END IF + + SAVE_STRING = SEARCH_STRING + SAVE_LEN = SEARCH_LEN + + IER = CLI$GET_VALUE('SEARCH_STRING',SEARCH_STRING,SEARCH_LEN) + + IF (.NOT.IER) THEN ! If no search string entered + SEARCH_STRING = SAVE_STRING ! use saved search string + SEARCH_LEN = SAVE_LEN + ELSE IF (.NOT.CLI$PRESENT('START')) THEN ! If string entered but no + BULL_POINT = 0 ! starting message, use first + END IF + + IF (IER) SUBJECT = CLI$PRESENT('SUBJECT') + + CALL STR$UPCASE(SEARCH_STRING,SEARCH_STRING) ! Make upper case + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(0,IER) + + IF (BULL_POINT+1.GT.NBULL) THEN + WRITE (6,'('' ERROR: No more messages.'')') + CALL CLOSE_BULLDIR + CALL ENABLE_CTRL + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + CALL DECLARE_CTRLC_AST + + DO BULL_SEARCH = BULL_POINT+1, NBULL + CALL READDIR(BULL_SEARCH,IER) ! Get bulletin directory entry + IF (IER.EQ.BULL_SEARCH+1) THEN + CALL STR$UPCASE(DESCRIP,DESCRIP) ! Make upper case + IF (INDEX(DESCRIP,SEARCH_STRING(:SEARCH_LEN)).GT.0) THEN + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + BULL_POINT = BULL_SEARCH - 1 + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + RETURN + END IF + END IF + IF (IER.EQ.BULL_SEARCH+1.AND..NOT.SUBJECT) THEN + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,BULL_SEARCH + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + GO TO 900 + ELSE + CALL GET_REMOTE_MESSAGE(IER) + IF (IER.GT.0) GO TO 900 + END IF + END IF + ILEN = LINE_LENGTH + 1 + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + CALL STR$UPCASE(INPUT,INPUT) ! Make upper case + IF (INDEX(INPUT,SEARCH_STRING(:SEARCH_LEN)).GT.0) THEN + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + BULL_POINT = BULL_SEARCH - 1 + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + RETURN + ELSE IF (FLAG.EQ.1) THEN + WRITE (6,'('' Search aborted.'')') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CALL ENABLE_CTRL + RETURN + END IF + END DO + END IF + END DO + +900 CALL CANCEL_CTRLC_AST + + CALL CLOSE_BULLFIL ! End of bulletin file read + CALL CLOSE_BULLDIR + + CALL ENABLE_CTRL + + WRITE (6,'('' No messages found with given search string.'')') + + RETURN + END + + + + + SUBROUTINE UNDELETE +C +C SUBROUTINE UNDELETE +C +C FUNCTION: Undeletes deleted message. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + +C +C Get the bulletin number to be undeleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + DECODE(LEN_P,5,BULL_PARAMETER,ERR=920) BULL_DELETE ! Yes +5 FORMAT(I) + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + GO TO 910 ! No, then error. + ELSE + BULL_DELETE = BULL_POINT ! Delete the file we are reading + END IF + + IF (BULL_DELETE.LE.0) GO TO 920 + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + CALL OPEN_BULLDIR + + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER + & .AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1040) ! Then error out. + GO TO 100 + ELSE + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + END IF + END IF + + IF (SYSTEM.LE.1) THEN ! General or System message + EXDATE = EXDATE(:7)//'19'//EXDATE(10:) + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(:6)//'20'//EXDATE(9:) + ELSE + EXDATE = EXDATE(:7)//'20'//EXDATE(10:) + END IF + END IF + + IF (.NOT.REMOTE_SET) THEN + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + WRITE (6,'('' Message was undeleted.'')') + ELSE + WRITE (REMOTE_UNIT,'(5A)',IOSTAT=IER) + & 11,BULL_DELETE,DESCRIP,EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + ELSE + WRITE (6,'('' Message was undeleted.'')') + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + +100 CALL CLOSE_BULLDIR + +900 RETURN + +910 WRITE(6,1010) + GO TO 900 + +920 WRITE(6,1020) + GO TO 900 + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not undeleted. Not owned by you.') + + END diff --git a/decus/vax89a2/nieland/bulletin/bulletin3.for b/decus/vax89a2/nieland/bulletin/bulletin3.for new file mode 100644 index 0000000..ce9a49d --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin3.for @@ -0,0 +1,1588 @@ +C +C BULLETIN3.FOR, Version 6/1/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE UPDATE +C +C SUBROUTINE UPDATE +C +C FUNCTION: Searches for bulletins that have expired and deletes them. +C +C NOTE: Assumes directory file is already opened. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER*107 DIRLINE + + CHARACTER*11 TEMP_DATE,TEMP_EXDATE,TEMP_NOSYSDATE + CHARACTER*11 TEMP_TIME,TEMP_EXTIME,TEMP_NOSYSTIME + + IF (REMOTE_SET.AND. + & NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + + IF (TEST_BULLCP().OR.REMOTE_SET) RETURN + ! BULLCP cleans up expired bulletins + + ENTRY UPDATE_ALWAYS ! Entry to skip BULLCP test + + TEMP_EXDATE = '5-NOV-2000' ! If a bulletin gets deleted, and there are + TEMP_EXTIME = '00:00:00.00' ! are no more bulletins, this is the value + ! assigned to the latest expiration date + + TEMP_DATE = '5-NOV-1956' ! Storage for computing newest + TEMP_TIME = '00:00:00.00' ! bulletin date if deletion occurs + + TEMP_NOSYSDATE = '5-NOV-1956' ! Storage for computing newest + TEMP_NOSYSTIME = '00:00:00.00' ! non-system bulletin date + + BULL_ENTRY = 1 ! Init bulletin pointer + UPDATE_DONE = 0 ! Flag showing bull has been deleted + + NEW_SHUTDOWN = 0 + OLD_SHUTDOWN = SHUTDOWN + + DO WHILE (1) + CALL READDIR(BULL_ENTRY,IER) ! Get next directory entry + IF (IER.EQ.BULL_ENTRY) GO TO 100 ! ERROR: Not found + IF (SYSTEM.LE.3.OR.(OLD_SHUTDOWN.EQ.0! If not shutdown, or time + & .AND.(SYSTEM.AND.4).EQ.4)) THEN ! to delete shutdowns? + IF ((SYSTEM.AND.4).EQ.4) THEN ! Shutdown bulletin? + IF (NODE_AREA.GT.0) THEN + EXTIME(3:4) = EXTIME(4:5) + READ (EXTIME(1:4),'(I4)') NODE_NUMBER_MSG + EXTIME(9:10) = EXTIME(10:11) + READ (EXTIME(7:10),'(I4)') NODE_AREA_MSG + IF (NODE_NUMBER_MSG.EQ.NODE_NUMBER.AND. + & NODE_AREA_MSG.EQ.NODE_AREA) THEN + DIFF = 0 + ELSE + DIFF = 1 + END IF + ELSE + DIFF = 1 + END IF + IF (DIFF.EQ.1) NEW_SHUTDOWN = NEW_SHUTDOWN + 1 + ELSE + DIFF = COMPARE_DATE(EXDATE,' ') ! Has expiration date passed? + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,' ') + END IF + IF (DIFF.LE.0) THEN ! If so then delete bulletin + CALL DELETE_ENTRY(BULL_ENTRY) ! Delete bulletin entry + IF (UPDATE_DONE.EQ.0) THEN ! If this is first deleted file + UPDATE_DONE = BULL_ENTRY ! store it to use for reordering + END IF ! directory file. + ELSE IF (SYSTEM.LE.3) THEN ! Expiration date hasn't passed + ! If a bulletin is deleted, we'll have to update the latest + ! expiration date. The following does that. + DIFF = COMPARE_DATE(EXDATE,TEMP_EXDATE) + IF (DIFF.LT.0.OR.(DIFF.EQ.0.AND. + & COMPARE_TIME(EXTIME,TEMP_EXTIME).LT.0)) THEN + TEMP_EXDATE = EXDATE ! If this is the latest exp + TEMP_EXTIME = EXTIME ! date seen so far, save it. + END IF + TEMP_DATE = DATE ! Keep date after search + TEMP_TIME = TIME ! we have the last message date + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + ELSE + TEMP_DATE = DATE + TEMP_TIME = TIME + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + BULL_ENTRY = BULL_ENTRY + 1 + END DO + +100 IF (UPDATE_DONE.GT.0) THEN ! Reorder directory file + CALL CLEANUP_DIRFILE(UPDATE_DONE) ! due to deleted entries + END IF + + DATE = NEWEST_DATE + TIME = NEWEST_TIME + CALL READDIR(0,IER) + SHUTDOWN = NEW_SHUTDOWN + NEWEST_EXDATE = TEMP_EXDATE + DIFF = COMPARE_DATE(NEWEST_EXDATE,' ') + IF (DIFF.GT.20*356) NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = TEMP_EXTIME + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL WRITEDIR(0,IER) + SYSTEM = 0 ! Updating last non-system date/time + NEWEST_DATE = TEMP_NOSYSDATE + NEWEST_TIME = TEMP_NOSYSTIME + CALL UPDATE_FOLDER + SYSTEM = 1 ! Now update latest date/time + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL UPDATE_FOLDER + + IF (NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN ! Shutdowns deleted? + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) ! Save that info + END IF + +C +C If newest message date has been changed, must change it in BULLUSER.DAT +C and also see if it affects notification of new messages to users +C + IF (TEMP_DATE.NE.DATE.OR.TEMP_TIME.NE.TIME) THEN + CALL UPDATE_LOGIN(.FALSE.) + END IF + + RETURN + + END + + + + SUBROUTINE UPDATE_READ +C +C SUBROUTINE UPDATE_READ +C +C FUNCTION: +C Store the latest date that user has used the BULLETIN facility. +C If new bulletins have been added, alert user of the fact. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($PRVDEF)' + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2),READ_BTIM_SAVE(2) + + LOGICAL MODIFY_SYSTEM /.TRUE./ + +C +C Update user's latest read time in his entry in BULLUSER.DAT. +C + + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.NE.0) THEN ! If header not present, exit + CALL CLOSE_BULLUSER + RETURN + ELSE IF (USERPRIV(1).EQ.-1.AND.USERPRIV(2).EQ.-1) THEN + ! If header present, but no + DO I=1,FLONG ! SET_FLAG and NOTIFY_FLAG + SET_FLAG_DEF(I) = 0 ! information, write default + NOTIFY_FLAG_DEF(I) = 0 ! flags. + BRIEF_FLAG_DEF(I) = 0 + END DO + SET_FLAG_DEF(1) = 1 + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + + CALL SYS$ASCTIM(,TODAY,,) ! Get today's time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + UNLOCK 4 + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + + IF (IER1.EQ.0) THEN ! If entry found, update it + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + ELSE ! If no entry create a new entry + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + CALL WRITE_USER_FILE_NEW(IER) + END IF + + IF (MODIFY_SYSTEM) THEN + CALL MODIFY_SYSTEM_LIST(1) + MODIFY_SYSTEM = .FALSE. + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + RETURN ! to go home... + + END + + + + + SUBROUTINE FIND_NEWEST_BULL +C +C SUBROUTINE FIND_NEWEST_BULL +C +C If new bulletins have been added, alert user of the fact and +C set the next bulletin to be read to the first new bulletin. +C +C OUTPUTS: +C BULL_POINT - If -1, no new bulletins to read, else there are. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INTEGER DIR_BTIM(2) + +C +C Now see if bulletins have been added since the user's previous +C read time. If they have, then search for the first new bulletin. +C Ignore new bulletins that are owned by the user or system notices +C that have not been added since the user has logged in. +C + BULL_POINT = -1 ! Init bulletin pointer + + CALL OPEN_BULLDIR_SHARED ! Yep, so get directory file + CALL READDIR(0,IER) ! Get # bulletins from header + IF (IER.EQ.1) THEN + CALL GET_NEWEST_MSG(LAST_READ_BTIM(1,FOLDER_NUMBER+1),START) + IF (START.LE.0) THEN + BULL_POINT = START + CALL CLOSE_BULLDIR + RETURN + END IF + DO WHILE (START.LE.NBULL.AND.(FROM.EQ.USERNAME.OR.SYSTEM)) + IF (FROM.NE.USERNAME) THEN ! Ignore bull if owner is user + IF (SYSTEM) THEN ! If system bulletin + CALL SYS_BINTIM(DATE//' '//TIME,DIR_BTIM) + DIFF = COMPARE_BTIM(LOGIN_BTIM,DIR_BTIM) + IF (DIFF.GT.0) THEN + START = START + 1 + CALL READDIR(START,IER) + ELSE ! SYSTEM bulletin was not seen + SYSTEM = 0 ! so force exit to read it. + END IF + END IF + ELSE + START = START + 1 + CALL READDIR(START,IER) + END IF + END DO + IF (START.LE.NBULL) BULL_POINT = START - 1 + END IF + + CALL CLOSE_BULLDIR + + RETURN + END + + + + SUBROUTINE GET_EXPIRED(EXPDAT,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 EXPDAT + CHARACTER*23 TODAY + + DIMENSION EXTIME(2),NOW(2) + + EXTERNAL CLI$_ABSENT + + IER = SYS$ASCTIM(,TODAY,,) ! Get today's date + + IERC = CLI$GET_VALUE('EXPIRATION',EXPDAT,ILEN) + + PROMPT = .TRUE. + +5 IF (PROMPT) THEN + IF (IERC.NE.%LOC(CLI$_ABSENT)) THEN ! Was value specified? + PROMPT = .FALSE. + ELSE + DEFAULT_EXPIRE = FOLDER_BBEXPIRE + IF ((DEFAULT_EXPIRE.GT.F_EXPIRE_LIMIT.OR.DEFAULT_EXPIRE + & .EQ.0).AND.F_EXPIRE_LIMIT.GT.0.AND. + & .NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER) THEN + DEFAULT_EXPIRE = F_EXPIRE_LIMIT + END IF + IF (BTEST(FOLDER_FLAG,3)) THEN ! NOPROMPT was set + IF (DEFAULT_EXPIRE.LE.0) THEN ! If no expiration date + SYSTEM = SYSTEM.OR.2 ! make permanent + EXPDAT = '5-NOV-2000 00:00:00.00' + ELSE ! Else set expiration + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + ELSE + IF (DEFAULT_EXPIRE.EQ.0) THEN ! Get expiration date + WRITE(6,1030) TODAY(:INDEX(TODAY,'.')-4) + ELSE IF (DEFAULT_EXPIRE.EQ.-1) THEN + WRITE(6,1031) TODAY(:INDEX(TODAY,'.')-4) + ELSE + WRITE(6,1032) TODAY(:INDEX(TODAY,'.')-4), + & DEFAULT_EXPIRE + END IF + WRITE (6,1035) + CALL GET_LINE(EXPDAT,ILEN) ! Get EXPDAT line + IF (ILEN.EQ.0.AND.DEFAULT_EXPIRE.NE.0) THEN + IF (DEFAULT_EXPIRE.EQ.-1) THEN + EXPDAT = '5-NOV-2000 00:00:00.00' + SYSTEM = IBSET(SYSTEM,1) ! Indicate permanent message + ELSE + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + END IF + END IF + END IF + ELSE + RETURN + END IF + + IF (ILEN.LE.0) THEN + IER = 0 + RETURN + END IF + + EXPDAT = EXPDAT(:ILEN) ! Change trailing zeros 2 spaces + + IF (INDEX(EXPDAT,'-').EQ.0.AND.INDEX(EXPDAT,':').GT.0.AND. + & INDEX(EXPDAT(:ILEN),' ').EQ.0) THEN ! Only time specified? + EXPDAT = TODAY(:INDEX(TODAY(2:),' ')+1)//EXPDAT ! Add date + ELSE IF (INDEX(EXPDAT(6:),'-').EQ.0.AND. ! Date specified + & INDEX(EXPDAT,'-').GT.0) THEN ! but no year? + SPACE = INDEX(EXPDAT,' ') - 1 ! Add year + IF (SPACE.EQ.-1) SPACE = TRIM(EXPDAT) + YEAR = INDEX(TODAY(6:),'-') + EXPDAT = EXPDAT(:SPACE)//TODAY(5+YEAR:9+YEAR)//EXPDAT(SPACE+1:) + END IF + + CALL STR$UPCASE(EXPDAT,EXPDAT) ! Convert to upper case + IER = SYS_BINTIM(EXPDAT,EXTIME) + IF (IER.NE.1) THEN ! If not able to do so + WRITE(6,1040) ! tell user is wrong + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + IF (TIMLEN.EQ.16) THEN + CALL SYS$GETTIM(NOW) + CALL LIB$SUBX(NOW,EXTIME,EXTIME) + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + END IF + + IF (EXPDAT(2:2).EQ.'-') EXPDAT = '0'//EXPDAT + IER = COMPARE_DATE(EXPDAT(:11),TODAY(:11)) ! Compare date with today's + IF (IER.GT.F_EXPIRE_LIMIT.AND.F_EXPIRE_LIMIT.GT.0.AND. + & .NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER) THEN + WRITE(6,1050) F_EXPIRE_LIMIT ! Expiration date > limit + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IF (IER.EQ.0) IER = COMPARE_TIME(EXPDAT(13:),TODAY(13:)) + IF (IER.LE.0) THEN ! If expiration date not future + WRITE(6,1045) ! tell user + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + + IF (PROMPT) THEN + IF (BTEST(SYSTEM,1)) THEN ! Permanent message + WRITE (6,'('' Message will be permanent.'')') + ELSE + WRITE (6,'('' Expiration date will be '',A,''.'')') + & EXPDAT(:TRIM(EXPDAT)) + END IF + END IF + + IER = 1 + + RETURN + +1030 FORMAT(' It is ',A,'. Specify when message expires.') +1031 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is permanent.') +1032 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is ',I3,' days.') +1035 Format(' Enter absolute time: [dd-mmm-yyyy] hh:mm:ss ', + & 'or delta time: dddd hh:mm:ss') +1040 FORMAT(' ERROR: Invalid date format specified.') +1045 FORMAT(' ERROR: Specified time has already passed.') +1050 FORMAT(' ERROR: Specified expiration period too large.' + & ' Limit is ',I3,' days.') + + END + + + SUBROUTINE MAILEDIT(INFILE,OUTFILE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SSDEF)' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL BULLETIN_SUBCOMMANDS + + CHARACTER*(*) INFILE,OUTFILE + + CHARACTER*80 MAIL_EDIT,OUT + + IER = SYS_TRNLNM('MAIL$EDIT',MAIL_EDIT) + + OUT = OUTFILE + IF (TRIM(OUT).EQ.0) THEN + OUT = INFILE + END IF + + IF (INDEX(MAIL_EDIT,'CALLABLE_').EQ.0.AND. + & IER.EQ.SS$_NORMAL) THEN + CALL DISABLE_PRIVS + IF (OUT.EQ.INFILE) THEN + CALL LIB$SPAWN('$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' "" '//OUT(:TRIM(OUT))) + ELSE + CALL LIB$SPAWN('$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' '//INFILE//' '//OUT(:TRIM(OUT))) + END IF + CALL ENABLE_PRIVS + ELSE IF (INDEX(MAIL_EDIT,'EDT').GT.0.OR. + & IER.NE.SS$_NORMAL) THEN + CALL EDT$EDIT(INFILE,OUT) + ELSE IF (INDEX(MAIL_EDIT,'TPU').GT.0) THEN + CONTEXT = 0 + IER = LIB$FIND_FILE(INFILE,MAIL_EDIT,CONTEXT) + IF (.NOT.IER) THEN + CALL TPU$EDIT(' ',OUT) + ELSE + CALL TPU$EDIT(INFILE,OUT) + END IF + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + ! TPU does CLI$ stuff which wipes our parsed command line + END IF + + RETURN + END + + + + + + SUBROUTINE CREATE_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE '($JPIDEF)' + + INCLUDE '($SSDEF)' + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /REALPROC/ REALPROCPRIV(2) + + DIMENSION IMAGEPRIV(2) + + CHARACTER IMAGENAME*132,ANSWER*1,PRCNAM*15 + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: You do not have the privileges '', + & ''to execute the command.'')') + CALL EXIT + END IF + + JUST_STOP = CLI$PRESENT('STOP') + + IF (JUST_STOP.AND..NOT.BTEST(REALPROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: You need SETPRV to execute /STOP.'')') + CALL EXIT + ELSE IF (.NOT.JUST_STOP.AND. + & .NOT.BTEST(REALPROCPRIV(1),PRV$V_SYSNAM)) THEN + CALL SYS$SETPRV(,,,IMAGEPRIV) + IF (.NOT.BTEST(IMAGEPRIV(1),PRV$V_SYSNAM)) THEN + WRITE (6,'('' ERROR: This new version of BULLETIN'', + & '' needs to be installed with SYSNAM.'')') + CALL EXIT + END IF + END IF + + IF (TEST_BULLCP()) THEN + IF (.NOT.JUST_STOP) THEN + WRITE (6,'('' BULLCP process running. + & Do you wish to kill it and restart a new one? '',$)') + READ (5,'(A)') ANSWER + IF (ANSWER.NE.'Y'.AND.ANSWER.NE.'y') CALL EXIT + END IF + + WILDCARD = -1 + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(PRCNAM),JPI$_PRCNAM,%LOC(PRCNAM)) + CALL ADD_2_ITMLST(4,JPI$_PID,%LOC(PID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + IER = 1 + DO WHILE (IER.AND.PRCNAM(:6).NE.'BULLCP') + ! Get next interactive process + IER = SYS$GETJPIW(,WILDCARD,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + IF (IER.AND.PID.NE.0) IER = SYS$DELPRC(PID,) + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + CALL EXIT + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP process has been terminated.'')') + CALL EXIT + END IF + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP is not presently running.'')') + CALL EXIT + END IF + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(FOLDER_DIRECTORY) + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$SET NOON' + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$LOOP:' + WRITE(11,'(A)') '$PURGE '//FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$OUTPUT ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$ERROR ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.ERR' + WRITE(11,'(A)') '$B/BULLCP' + WRITE(11,'(A)') '$WAIT 00:01:00' + WRITE(11,'(A)') '$GOTO LOOP' ! File open timed out + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = 0 + DO WHILE (IER.EQ.0.OR.(IER.EQ.SS$_DUPLNAM.AND.PID.GT.0)) + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT', + & FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM','NL:' + & ,,,,'BULLCP',%VAL(4),,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + END DO + + IF (IER) THEN + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM;-1', + & STATUS='OLD',IOSTAT=IER1) + IF (IER1.EQ.0) CLOSE(UNIT=11,STATUS='DELETE',IOSTAT=IER1) + END IF + + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + ELSE + IF (CONFIRM_USER('DECNET').NE.0) THEN + WRITE (6,'('' WARNING: Account with username DECNET'', + & '' does not exist.'')') + WRITE (6,'('' BULLCP will be owned by present account.'')') + END IF + WRITE (6,'('' Successfully created BULLCP detached process.'')') + END IF + CALL EXIT + + END + + + + + + + SUBROUTINE FIND_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + DATA BULLCP /0/ + + CHARACTER*1 DUMMY + + IER = SYS_TRNLNM('BULL_BULLCP',DUMMY) + IF (IER) BULLCP = 1 + + RETURN + END + + + + + LOGICAL FUNCTION TEST_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + TEST_BULLCP = BULLCP + + RETURN + END + + + + + SUBROUTINE RUN_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + + CHARACTER*23 OLD_TIME,NEW_TIME + + IF (TEST_BULLCP()) CALL EXIT ! BULLCP already running, so exit. + + CALL LIB$DATE_TIME(OLD_TIME) + + BULLCP = 2 ! Enable process to do BULLCP functions + + IER = SYS$CREMBX(%VAL(1),CHAN,,,,,'BULL_BULLCP') + IF (.NOT.IER) THEN ! Can't create mailbox, so exit. + CALL SYS_GETMSG(IER) + CALL EXIT + END IF + + IER = SYS$DELMBX(%VAL(CHAN)) ! If process dies, mailbox is deleted. + + CALL REGISTER_BULLCP + + CALL SET_REMOTE_SYSTEM + + CALL START_DECNET + + DO WHILE (1) ! Loop once every 15 minutes + CALL SYS$SETAST(%VAL(0)) + CALL LIB$DATE_TIME(NEW_TIME) + CALL GET_PROXY_ACCOUNTS ! Proxy info for incoming connections + CALL SYS$SETAST(%VAL(1)) + CALL BBOARD ! Look for BBOARD messages. + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).NE.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + IF (IER) THEN + CALL DELETE_EXPIRED ! Delete expired messages + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Do empty block + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! cleanup at 3 a.m. + IF (NEMPTY.GT.200) THEN + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + END IF + END IF + END IF + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Cleanup deleted users from + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! data files at 3 a.m. + CALL SYS$SETAST(%VAL(0)) + CALL TOTAL_CLEANUP_LOGIN + CALL SYS$SETAST(%VAL(1)) + END IF + + OLD_TIME = NEW_TIME + CALL WAIT('15') ! Wait for 15 minutes +C +C Look at remote folders and update local info to reflect new messages. +C Do here after waiting in case problem with connecting to remote folder +C which requires killing process. +C + FOLDER_Q = FOLDER_Q1 + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + CALL SYS$SETAST(%VAL(0)) + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + CALL REGISTER_BULLCP + CALL SYS$SETAST(%VAL(1)) + END DO + + RETURN + END + + + + + SUBROUTINE SET_REMOTE_SYSTEM + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER NODENAME*8 + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + CALL OPEN_BULLFOLDER_SHARED + + IER = 0 + DO WHILE (IER.EQ.0) + CALL READ_FOLDER_FILE(IER) + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER_FLAG,2) + & .AND.IER.EQ.0) THEN + CALL SELECT_FOLDER(.FALSE.,IER1) + IF (IER1) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14, + & BTEST(FOLDER_FLAG,2),NODENAME + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER + + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + + RETURN + END + + + + + SUBROUTINE REGISTER_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + NODE_AREA = 0 + END IF + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE UPDATE_SHUTDOWN(FOLDER_NUMBER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + CALL CLR2(SHUTDOWN_FLAG,FOLDER_NUMBER) + + SEEN_FLAG = 0 + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 ! All done with that node + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE WAIT(PARAM) +C +C SUBROUTINE WAIT +C +C FUNCTION: Waits for specified time period in minutes. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,PARAM*2 + DATA TIMBUF/'0 00:00:00.00'/ + + DATA WAIT_EF /0/ + + IF (WAIT_EF.EQ.0) CALL LIB$GET_EF(WAIT_EF) + + TIMBUF(6:7) = PARAM + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SETIMR(%VAL(WAIT_EF),TIMADR,,%VAL(2)) ! Set timer. + IER=SYS$WAITFR(%VAL(WAIT_EF)) ! Wait for EFN to be set. + + RETURN + END + + + + SUBROUTINE WAIT_SEC(PARAM) +C +C SUBROUTINE WAIT_SEC +C +C FUNCTION: Waits for specified time period in seconds. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,PARAM*2 + DATA TIMBUF/'0 00:00:00.00'/ + DATA WAIT_EF /0/ + + IF (WAIT_EF.EQ.0) CALL LIB$GET_EF(WAIT_EF) + + TIMBUF(9:10) = PARAM + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SETIMR(%VAL(WAIT_EF),TIMADR,,%VAL(3)) ! Set timer. + IER=SYS$WAITFR(%VAL(WAIT_EF)) ! Wait for EFN to be set. + + RETURN + END + + + + + SUBROUTINE DELETE_EXPIRED + +C +C SUBROUTINE DELETE_EXPIRED +C +C FUNCTION: +C +C Delete any expired bulletins (normal or shutdown ones). +C (NOTE: If bulletin files don't exist, they get created now by +C OPEN_FILE_SHARED. Also, if new format has been defined for files, +C they get converted now. The directory file has had it's record size +C lengthened in the past to include more info, and the bulletin file +C was lengthened from 80 to 81 characters to include byte which indicated +C start of bulletin message. However, that scheme was removed and +C was replaced with a 128 byte record compressed format). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER UPTIME_DATE*11,UPTIME_TIME*11 + + CALL OPEN_BULLDIR_SHARED ! Open directory file + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + CALL CLOSE_BULLFIL + CALL READDIR(0,IER) ! Get directory header + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired bulls? + IF (IER.GT.20*356) IER = -1 ! Check if latest expiration date valid. + IF (IER.EQ.0) IER = COMPARE_TIME(NEWEST_EXTIME,' ') + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)).AND. + & TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown messages exist and need to be checked? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER1.LE.0) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Reopen without sharing + CALL UPDATE ! Need to update + END IF + ELSE ! If header not there, then first time running BULLETIN + CALL OPEN_BULLUSER ! Create user file to be able to set + CALL CLOSE_BULLUSER ! defaults, privileges, etc. + END IF + CALL CLOSE_BULLDIR + + RETURN + END + + + + + SUBROUTINE BBOARD +C +C SUBROUTINE BBOARD +C +C FUNCTION: Converts mail to BBOARD into non-system bulletins. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + CHARACTER*11 INEXDATE + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH),INTO*76 + CHARACTER ACCOUNT_SAVE*8,USERNAME_SAVE*12 + + DIMENSION NEW_MAIL(FOLDER_MAX) + + DATA SPAWN_EF/0/ + + CALL SYS$SETAST(%VAL(0)) + + IF (SPAWN_EF.EQ.0) CALL LIB$GET_EF(SPAWN_EF) + + CALL DISABLE_CTRL + + CALL INIT_QUEUE(FOLDER_Q1,FOLDER_COM) + + FOLDER_Q = FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE(IER) + IF (IER.EQ.0) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + CALL SYS$SETAST(%VAL(1)) + + CALL SYS$SETAST(%VAL(0)) + CALL CHECK_MAIL(NEW_MAIL) + CALL SYS$SETAST(%VAL(1)) + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + + NBBOARD_FOLDERS = 0 + + POINT_FOLDER = 0 + +1 POINT_FOLDER = POINT_FOLDER + 1 + IF (POINT_FOLDER.GT.NUM_FOLDERS) GO TO 900 + + CALL SYS$SETAST(%VAL(0)) + + FOLDER_Q_SAVE = FOLDER_Q + + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (FOLDER_BBOARD.EQ.'NONE'.OR. + & FOLDER_BBOARD(:2).EQ.'::') GO TO 1 + + NBBOARD_FOLDERS = NBBOARD_FOLDERS + 1 + + IF (.NOT.NEW_MAIL(POINT_FOLDER)) GO TO 1 +C +C The process is set to the BBOARD uic and username in order to create +C a spawned process that is able to read the BBOARD mail (a real kludge). +C + + CALL GETUSER(USERNAME_SAVE) ! Get present username + CALL GETACC(ACCOUNT_SAVE) ! Get present account + CALL GETUIC(GROUP_SAVE,USER_SAVE) ! Get present uic + + IF (TRIM(FOLDER_BBOARD).GT.0) THEN ! BBOARD name present? + IER = SETUSER(FOLDER_BBOARD,USERNAME_SAVE)! Set to BBOARD username + IF (IER.EQ.2) GO TO 910 ! Can't set username. New VMS version? + CALL SETACC(ACCOUNTB) ! Set to BBOARD account + CALL SETUIC(IBCLR(GROUPB,31),IBCLR(USERB,31)) ! Set to BBOARD uic + END IF + + LEN_B = TRIM(BBOARD_DIRECTORY) + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.TXT;*') + ! Delete old TXT files left due to errors + + IF (.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)) THEN + ! If normal BBOARD user + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + IF (((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'READ_BOARD.COM', + & STATUS='NEW',ERR=910,CARRIAGECONTROL='LIST') + WRITE(11,'(A)') '$ SET PROTECT=(W:RWED)/DEFAULT' + WRITE(11,'(A)') '$ SET PROC/PRIV=SYSPRV' + WRITE(11,'(A)') + & '$ DEFINE/USER EXTRACT_FILE '//BBOARD_DIRECTORY(:LEN_B)// + & '''F$GETJPI("","USERNAME")''' + WRITE(11,'(A)') '$ MAIL' + WRITE(11,'(A)') 'READ' + WRITE(11,'(A)') 'EXTRACT/ALL/APPEND EXTRACT_FILE' + WRITE(11,'(A)') 'DELETE/ALL' + WRITE(11,'(A)') 'SELECT/NEW' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + ELSE + CONTEXT = 0 + IER = LIB$FIND_FILE(BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.COM',INPUT,CONTEXT) + IF (IER) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.COM','NL:', + & 'NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + IF (.NOT.IER.OR.((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & 'BOARD_SPECIAL.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + END IF + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),FOLDER_Q,FOLDER_COM) + + NBULL = F_NBULL + + CALL SETACC(ACCOUNT_SAVE) ! Reset to original account + CALL SETUSER(USERNAME_SAVE) ! Reset to original username + CALL SETUIC(GROUP_SAVE,USER_SAVE) ! Reset to original uic + + OPEN (UNIT=3,FILE=BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.TXT',STATUS='OLD',ERR=100) + READ (3,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read first line + CALL SYS$SETAST(%VAL(1)) + +5 CALL SYS$SETAST(%VAL(0)) + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),IDUMMY,FOLDER_COM) + + DO WHILE (LEN_INPUT.GT.0) + IF (INPUT(:5).EQ.'From:') THEN + INFROM = INPUT(7:) ! Store username + ELSE IF (INPUT(:5).EQ.'Subj:') THEN + INDESCRIP = INPUT(7:) ! Store subject + ELSE IF (INPUT(:3).EQ.'To:') THEN + INTO = INPUT(5:) ! Store address + END IF + READ (3,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read next line from mail + END DO + + INTO = INTO(:TRIM(INTO)) + CALL STR$TRIM(INTO,INTO) + CALL STR$UPCASE(INTO,INTO) + FLEN = TRIM(FOLDER_BBOARD) + IF (INDEX(INTO,FOLDER_BBOARD(:FLEN)).EQ.0.AND. + & INTO.NE.FOLDER_BBOARD.AND.INDEX(INTO,'@').EQ.0) THEN + POINT_FOLDER1 = 0 + FOLDER_Q2 = FOLDER_Q1 + FOLDER1_BBOARD = FOLDER_BBOARD + FOUND = .FALSE. + DO WHILE (.NOT.FOUND.AND.POINT_FOLDER1.LT.NUM_FOLDERS) + FOLDER_Q2_SAVE = FOLDER_Q2 + CALL READ_QUEUE(%VAL(FOLDER_Q2),FOLDER_Q2,FOLDER1_COM) + FLEN = TRIM(FOLDER1_BBOARD) + POINT_FOLDER1 = POINT_FOLDER1 + 1 + IF (POINT_FOLDER1.LE.NUM_FOLDERS.AND. + & FOLDER1_BBOARD(:2).NE.'::'.AND. + & FOLDER1_BBOARD.NE.'NONE') THEN + IF (INTO.EQ.FOLDER1_BBOARD) THEN + FOUND = .TRUE. + ELSE + FIND_TO = INDEX(INTO,FOLDER1_BBOARD(:FLEN)) + IF (FIND_TO.GT.0) THEN + END_TO = FLEN+FIND_TO + IF (TRIM(INTO).LT.END_TO.OR. + & INTO(END_TO:END_TO).LT.'A'.OR. + & INTO(END_TO:END_TO).GT.'Z') THEN + IF (FIND_TO.EQ.1) THEN + FOUND = .TRUE. + ELSE IF (INTO(FIND_TO-1:FIND_TO-1).LT.'A'.OR. + & INTO(FIND_TO-1:FIND_TO-1).GT.'Z') THEN + FOUND = .TRUE. + END IF + END IF + END IF + END IF + END IF + END DO + IF (FOUND) THEN + FOLDER_COM = FOLDER1_COM + FOLDER_Q_SAVE = FOLDER_Q2_SAVE + END IF + END IF + + READ (3,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT ! Read first line + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12).AND.IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (INPUT(:5).EQ.'From:') GO TO 5 + END DO ! If line is just form feed, the message is empty + IF (IER.NE.0) GO TO 100 ! If end of file, exit + + EFROM = 2 + I = TRIM(INFROM) + DO WHILE (EFROM.GT.0.AND.I.GT.0) ! Strip off the date + IF (INFROM(I:I).EQ.' ') EFROM = EFROM - 1 ! From the "From:" line + I = I - 1 + END DO + IF (I.GT.0) INFROM = INFROM(:I) + + CALL INIT_MESSAGE_ADD_BBOARD(INFROM,INDESCRIP,IER) + + ISTART = 0 + NBLANK = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Move text to bulletin file + IF (LEN_INPUT.EQ.0) THEN + IF (ISTART.EQ.1) THEN + NBLANK = NBLANK + 1 + END IF + ELSE + ISTART = 1 + DO I=1,NBLANK + CALL WRITE_MESSAGE_LINE(' ') + END DO + NBLANK = 0 + CALL WRITE_MESSAGE_LINE(INPUT) + END IF + READ (3,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12)) THEN + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12) + & .AND.IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + END DO + IF (IER.EQ.0.AND.INPUT(:5).EQ.'From:') THEN + IER = 1 + ELSE + NBLANK = NBLANK + 1 + END IF + END IF + END DO + + CALL FINISH_MESSAGE_ADD ! Totally finished with add + + CALL SYS$SETAST(%VAL(1)) + + GO TO 5 ! See if there is more mail + +100 CLOSE (UNIT=3,STATUS='DELETE') ! Close the input file + CALL SYS$SETAST(%VAL(1)) + GO TO 1 + +900 CALL SYS$SETAST(%VAL(0)) + + FOLDER_NUMBER = 0 + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNUM(0,IER) + CALL CLOSE_BULLFOLDER + CALL ENABLE_CTRL + FOLDER_SET = .FALSE. + + IF (NBBOARD_FOLDERS.EQ.0) THEN + CALL OPEN_BULLUSER + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',BBOARD_BTIM) + REWRITE (4) USER_HEADER ! Rewrite header + CALL CLOSE_BULLUSER + END IF + + CALL SYS$SETAST(%VAL(1)) + + RETURN + +910 WRITE (6,1010) + GO TO 100 + +930 CLOSE (UNIT=3) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + WRITE (6,1030) + GO TO 100 + +1010 FORMAT(' ERROR:Install program with CMKRNL privileges or relink.') +1030 FORMAT(' ERROR:Alert system programmer. Data file problems.') + + END + + + + + SUBROUTINE CREATE_BBOARD_PROCESS + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + CHARACTER*132 IMAGENAME + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(BBOARD_DIRECTORY) + + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='OLD',IOSTAT=IER) + IF (IER.EQ.0) CLOSE(UNIT=11,STATUS='DELETE') + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$ON ERROR THEN GOTO EXIT' + WRITE(11,'(A)') '$ON SEVERE THEN GOTO EXIT' + WRITE(11,'(A)') '$ON WARNING THEN GOTO EXIT' + WRITE(11,'(A)') '$B/'//'''F$PROCESS()''' + WRITE(11,'(A)') '$EXIT:' + WRITE(11,'(A)') '$LOGOUT' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT', + & BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM','NL:',, + & PROCPRIV,,'BBOARD',%VAL(4),,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + + RETURN + END + + + + SUBROUTINE GETUIC(GRP,MEM) +C +C SUBROUTINE GETUIC(UIC) +C +C FUNCTION: +C To get UIC of process submitting the job. +C OUTPUT: +C GRP - Group number of UIC +C MEM - Member number of UIC +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,JPI$_GRP,%LOC(GRP)) + CALL ADD_2_ITMLST(4,JPI$_MEM,%LOC(MEM)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + SUBROUTINE GET_UPTIME(UPTIME_DATE,UPTIME_TIME) +C +C SUBROUTINE GET_UPTIME +C +C FUNCTION: Gets time of last reboot. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + INTEGER UPTIME(2) + CHARACTER*(*) UPTIME_TIME,UPTIME_DATE + CHARACTER ASCSINCE*23 + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(8,SYI$_BOOTTIME,%LOC(UPTIME)) + CALL END_ITMLST(GETSYI_ITMLST) + + IER = SYS$GETSYI(,,,%VAL(GETSYI_ITMLST),,,) + + CALL SYS$ASCTIM(,ASCSINCE,UPTIME,) + + UPTIME_DATE = ASCSINCE(:11) + UPTIME_TIME = ASCSINCE(13:) + + RETURN + END + + + + INTEGER FUNCTION GET_L_VAL(I) + INTEGER I + GET_L_VAL = I + RETURN + END + + + + SUBROUTINE CHECK_MAIL(NEW_MAIL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + DIMENSION NEW_MAIL(1) + + CHARACTER INPUT*37,FILENAME*132 + + INTEGER*2 COUNT + + FOLDER_Q = FOLDER_Q1 ! so reinit queue pointer + + OPEN (UNIT=10,FILE='VMSMAIL_PROFILE', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL_PROFILE.DATA', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + OFFSET = 36 + + IF (IER.NE.0) THEN + OPEN (UNIT=10,FILE='VMSMAIL', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL.DAT', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + OFFSET = 34 + END IF + + DO I=1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (((.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)).OR. + & BTEST(GROUPB,31)).AND.FOLDER_BBOARD(:2).NE.'::') THEN + ! If normal BBOARD or /VMSMAIL + READ(10,'(A)',KEY=FOLDER_BBOARD,IOSTAT=IER1) INPUT + CALL LIB$MOVC3(2,%REF(INPUT(OFFSET:)),COUNT) + IF (IER1.EQ.0.AND.(COUNT.GT.0.OR.IER.NE.0)) THEN + NEW_MAIL(I) = .TRUE. + ELSE + NEW_MAIL(I) = .FALSE. + END IF + ELSE + NEW_MAIL(I) = .TRUE. + END IF + END DO + + CLOSE (10) + + RETURN + END + + + + SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C FUNCTION: +C To get image name of process. +C OUTPUT: +C IMAGNAME - Image name of process +C ILEN - Length of imagename +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CHARACTER*(*) IMAGNAME + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST_WITH_RET(LEN(IMAGNAME),JPI$_IMAGNAME, + & %LOC(IMAGNAME),%LOC(ILEN)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + + SUBROUTINE GET_NEWEST_MSG(IN_BTIM,START) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + DIMENSION IN_BTIM(2) + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 12,IN_BTIM(1),IN_BTIM(2) + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(A)',IOSTAT=IER) START + END IF + ELSE + CALL GET_MSGKEY(IN_BTIM,MSG_KEY) + CALL READDIR_KEYGE(START) + IF (START.EQ.0) THEN + START = -1 + END IF + END IF + + RETURN + END diff --git a/decus/vax89a2/nieland/bulletin/bulletin4.for b/decus/vax89a2/nieland/bulletin/bulletin4.for new file mode 100644 index 0000000..01679e4 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin4.for @@ -0,0 +1,1676 @@ +C +C BULLETIN4.FOR, Version 6/1/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C +C +C SUBROUTINE ITMLST_SUBS +C +C FUNCTION: +C A set of routines to easily create item lists. It allows one +C to easily create item lists without the need for declaring arrays +C or itemlist size. Thus, the code can be easily changed to add or +C delete item list codes. +C +C Here is an example of how to use the routines (prints file to a queue): +C +C CALL INIT_ITMLST ! Initialize item list +C ! Now add items to list +C CALL ADD_2_ITMLST(LEN,SJC$_FILE_SPECIFICATION,%LOC(FILENAME)) +C CALL ADD_2_ITMLST(9,SJC$_QUEUE,%LOC(QUEUE)) +C CALL END_ITMLST(SNDJBC_ITMLST) ! Get address of itemlist +C IER = SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SNDJBC_ITMLST),IOSB,,) +C + SUBROUTINE ITMLST_SUBS + + IMPLICIT INTEGER (A-Z) + + DATA SAVE_ITMLST_ADDRESS/0/,NUM_ITEMS/0/,QUEUE_HEADER/0/ + + ENTRY INIT_ITMLST + + IF (QUEUE_HEADER.EQ.0) THEN ! First time INIT_ITMLST ever called? + CALL LIB$GET_VM(8,QUEUE_HEADER) ! Yes, create queue header pointer + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER)) ! Zero out header + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER+4)) ! Zero out header + ELSE IF (SAVE_ITMLST_ADDRESS.GT.0) THEN ! Clean out old item list + CALL LIB$FREE_VM((NUM_ITEMS+1)*12,SAVE_ITMLST_ADDRESS) + NUM_ITEMS = 0 ! Release old itemlist memory + SAVE_ITMLST_ADDRESS = 0 + ELSE ! ITMLST calls cannot be nested. + WRITE (6,'('' ERROR: INIT_ITMLST called before previous'',$)') + WRITE (6,'(''+ ITMLST terminated with END_ITMLST.'')') + CALL EXIT + END IF + + RETURN + + + ENTRY ADD_2_ITMLST(BUFLEN,CODE,BUFADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR,0) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY ADD_2_ITMLST_WITH_RET(BUFLEN,CODE,BUFADR,RETADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR, + & RETADR) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY END_ITMLST(ITMLST_ADDRESS) + + CALL LIB$GET_VM((NUM_ITEMS+1)*12,ITMLST_ADDRESS) + ! Get memory for itemlist + SAVE_ITMLST_ADDRESS = ITMLST_ADDRESS ! Save address to remove memory + + DO I=1,NUM_ITEMS ! Place entries into itemlist + CALL LIB$REMQHI(%VAL(QUEUE_HEADER),INPUT_ITMLST) + CALL LIB$MOVC3(12,%VAL(INPUT_ITMLST+8), + & %VAL(ITMLST_ADDRESS+(I-1)*12)) + CALL LIB$FREE_VM(20,INPUT_ITMLST) + END DO + + CALL LIB$MOVC3(4,0,%VAL(ITMLST_ADDRESS+NUM_ITEMS*12)) + ! Place terminating 0 at end of itemlist + + RETURN + END + + + + SUBROUTINE STORE_ITMLST_ENTRY(INPUT_ITMLST,BUFLEN,CODE,BUFADR, + & RETADR) + + IMPLICIT INTEGER (A-Z) + + STRUCTURE /ITMLST/ + UNION + MAP + INTEGER*2 BUFLEN,CODE + INTEGER BUFADR,RETADR + END MAP + END UNION + END STRUCTURE + + RECORD /ITMLST/ INPUT_ITMLST(1) + + INPUT_ITMLST(1).BUFLEN = BUFLEN + INPUT_ITMLST(1).CODE = CODE + INPUT_ITMLST(1).BUFADR = BUFADR + INPUT_ITMLST(1).RETADR = RETADR + + RETURN + END + + + SUBROUTINE CLEANUP_LOGIN +C +C SUBROUTINE CLEANUP_LOGIN +C +C FUNCTION: Removes entry in user file of user that no longer exist +C if it creates empty space for new user. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 LOGIN_USER + + CALL OPEN_SYSUAF_SHARED + + LOGIN_USER = USERNAME + READ (4,IOSTAT=IER1,KEYGT=USERNAME) USER_ENTRY ! Look forward one + TEMP_USER = USERNAME + USERNAME = LOGIN_USER + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=TEMP_USER,IOSTAT=IER) TEMP_USER ! See if user exists + END DO + + IF (IER.NE.0.AND.IER1.EQ.0.AND.TEMP_USER.NE.USER_HEADER_KEY) THEN + DELETE(UNIT=4) ! Delete non-existant user + CALL OPEN_BULLINF + READ (9,KEY=TEMP_USER,IOSTAT=IER) + IF (IER.EQ.0) DELETE(UNIT=9) + CALL CLOSE_BULLINF + END IF + + CALL CLOSE_SYSUAF ! All done... + + RETURN + END + + + SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C FUNCTION: Removes all entries in user file of usesr that no longer exist +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CALL OPEN_SYSUAF_SHARED + CALL OPEN_BULLUSER + CALL OPEN_BULLINF + + TEMP_USER = USERNAME + + READ (4,IOSTAT=IER) USER_ENTRY ! Skip header + + DO WHILE (IER.EQ.0) ! Clean out BULLUSER.DAT + READ (4,IOSTAT=IER) USER_ENTRY + IF (IER.EQ.0.AND.USERNAME(:1).NE.'*'.AND. + & USERNAME(:1).NE.':') THEN ! See if user exists + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=USERNAME,IOSTAT=IER) + END DO + IF (IER.NE.0) THEN + DELETE (UNIT=4) + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=9) + IER = 0 + END IF + END IF + END DO + + READ (9,KEYGT=' ',IOSTAT=IER) USERNAME + + DO WHILE (IER.EQ.0) ! Clean out BULLINF.DAT + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=USERNAME,IOSTAT=IER) + END DO + IF (IER.NE.0) DELETE (UNIT=9) + READ (9,IOSTAT=IER) USERNAME + END DO + + CALL CLOSE_SYSUAF ! All done... + CALL CLOSE_BULLINF + CALL CLOSE_BULLUSER + + USERNAME = TEMP_USER + + RETURN + END + + + SUBROUTINE COPY_BULL(INLUN,IBLOCK,OBLOCK,IER) +C +C SUBROUTINE COPY_BULL +C +C FUNCTION: To copy data to the bulletin file. +C +C INPUT: +C INLUN - Input logical unit number +C IBLOCK - Input block number in input file to start at +C OBLOCK - Output block number in output file to start at +C +C OUTPUT: +C IER - If error in writing to bulletin, IER will be <> 0. +C +C NOTES: Input file is accessed using sequential access. This is +C to allow files which have variable records to be read. The +C bulletin file is assumed to be opened on logical unit 1. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + IF (IER.NE.0) CALL ERROR_AND_EXIT + END IF + + DO I=1,IBLOCK-1 + READ(INLUN,'(A)') + END DO + + OCOUNT = OBLOCK + ICOUNT = IBLOCK + + NBLANK = 0 + LENGTH = 0 + DO WHILE (1) + ILEN = 0 + DO WHILE (ILEN.EQ.0) + READ(INLUN,'(Q,A)',END=100) ILEN,INPUT + ILEN = MIN(ILEN,TRIM(INPUT),LINE_LENGTH) + IF (ILEN.GT.1.AND.ICHAR(INPUT(ILEN:ILEN)).EQ.10) THEN + INPUT(ILEN-1:ILEN-1) = CHAR(32) ! Remove imbedded + INPUT(ILEN:ILEN) = CHAR(32) ! CR/LFs at end of file. + ILEN = ILEN - 2 + END IF + IF (ILEN.GT.0) THEN + IF (ICOUNT.EQ.IBLOCK) THEN + IF (INPUT(:6).EQ.'From: ') THEN + INPUT(:4) = 'FROM' + END IF + END IF + ICOUNT = ICOUNT + 1 + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.IBLOCK) THEN + NBLANK = NBLANK + 1 + END IF + END DO + IF (NBLANK.GT.0) THEN + DO I=1,NBLANK + CALL STORE_BULL(1,' ',OCOUNT) + END DO + LENGTH = LENGTH + NBLANK*2 + NBLANK = 0 + END IF + CALL STORE_BULL(ILEN,INPUT,OCOUNT) + LENGTH = LENGTH + ILEN + 1 + END DO + +100 LENGTH = (LENGTH+127)/128 + IF (LENGTH.EQ.0) THEN + IER = 1 + ELSE + IER = 0 + END IF + + CALL FLUSH_BULL(OCOUNT) + + RETURN + END + + + + SUBROUTINE STORE_BULL(ILEN,INPUT,OCOUNT) + + IMPLICIT INTEGER (A-Z) + + PARAMETER BRECLEN=128 + + CHARACTER INPUT*(*),OUTPUT*256 + + DATA POINT/0/ + + IF (ILEN+POINT+1.GT.BRECLEN) THEN + IF (POINT.EQ.BRECLEN) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)) + OUTPUT = CHAR(ILEN)//INPUT + POINT = ILEN + 1 + ELSE IF (POINT.EQ.BRECLEN-1) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN)) + OUTPUT = INPUT + POINT = ILEN + ELSE + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN) + & //INPUT(:BRECLEN-1-POINT)) + OUTPUT = INPUT(BRECLEN-POINT:) + POINT = ILEN - (BRECLEN-1-POINT) + END IF + OCOUNT = OCOUNT + 1 + DO WHILE (POINT.GE.BRECLEN) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + OCOUNT = OCOUNT + 1 + OUTPUT = OUTPUT(BRECLEN+1:) + POINT = POINT - BRECLEN + END DO + ELSE + OUTPUT(POINT+1:) = CHAR(ILEN)//INPUT(:ILEN) + POINT = POINT + ILEN + 1 + END IF + + RETURN + + ENTRY FLUSH_BULL(OCOUNT) + + IF (POINT.LT.BRECLEN) OUTPUT(POINT+1:POINT+1) = CHAR(0) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + POINT = 0 + + RETURN + + END + + + SUBROUTINE WRITE_BULL_FILE(OCOUNT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*(*) OUTPUT + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 6,OUTPUT + ELSE + WRITE (1'OCOUNT) OUTPUT + END IF + + RETURN + END + + + SUBROUTINE GET_BULL_LINE(SBLOCK,BLENGTH,BUFFER,ILEN) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + IBLOCK = SBLOCK ! Initialize pointers. + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 + ELSE ! Else set ILEN to zero + ILEN = 0 ! to request next line + END IF + + DO WHILE (ILEN.EQ.0) ! Read until line created + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 ! Need to read new record. + IF (IBLOCK.GE.SBLOCK+BLENGTH) RETURN ! No more records. + END DO + + RETURN + + ENTRY TEST_MORE_RECORDS(SBLOCK,BLENGTH,IREC) + + IREC = (SBLOCK+BLENGTH-1) - IBLOCK + + RETURN + END + + + SUBROUTINE GET_BULL(IBLOCK,BUFFER,ILEN) +C +C SUBROUTINE GET_BULL +C +C FUNCTION: Outputs line from folder file. +C +C INPUT: +C IBLOCK - Input block number in input file to read from. +C +C OUTPUT: +C BUFFER - Character string containing output line. +C ILEN - Length of character string. If 0, signifies that +C new record needs to be read, -1 signifies error. +C +C NOTE: Since message file is stored as a fixed length (128) record file, +C but message lines are variable, message lines may span one or +C more record. This routine takes a record and outputs as many +C lines as it can from the record. When no more lines can be +C outputted, it returns ILEN=0 requesting the calling program to +C increment the record counter. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + PARAMETER BRECLEN=128 + + CHARACTER BUFFER*(*),TEMP*(BRECLEN), LEFT*(LINE_LENGTH) + + DATA POINT /1/, LEFT_LEN /0/ + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + POINT = 1 ! Initialize pointers. + LEFT_LEN = 0 + END IF + + IF (POINT.EQ.1) THEN ! Need to read new line? + IF (REMOTE_SET) THEN ! Remote folder? + IF (IBLOCK.EQ.BLOCK) SCRATCH_R = SCRATCH_R1 ! Read lines + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,TEMP) ! from queue + ELSE ! Local folder + DO WHILE (REC_LOCK(IER)) ! Read from file + READ (1'IBLOCK,IOSTAT=IER) TEMP + END DO + END IF + ELSE IF (POINT.EQ.BRECLEN+1) THEN ! Read all of line + ILEN = 0 ! so indicate need to read + POINT = 1 ! new line to calling routine. + RETURN + END IF + + IF (IER.GT.0) THEN ! Error in reading file. + ILEN = -1 ! ILEN = -1 signifies error + POINT = 1 + LEFT_LEN = 0 + RETURN + END IF + + IF (LEFT_LEN.GT.0) THEN ! Part of line is left from + ILEN = ICHAR(LEFT(:1)) ! previous record read. + IF (LEFT_LEN.LE.BRECLEN) THEN ! Rest of it is in next record. + BUFFER = LEFT(2:ILEN-LEFT_LEN+1)//TEMP(:LEFT_LEN) ! Output line. + POINT = LEFT_LEN + 1 ! Update pointers. + LEFT_LEN = 0 + ELSE ! Rest of line is longer than + LEFT(ILEN-LEFT_LEN+2:) = TEMP ! a record, so store record + LEFT_LEN = LEFT_LEN - BRECLEN ! and request another read. + ILEN = 0 ! Request new record read. + END IF + ELSE ! Else nothing left over. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Get line length + IF (ILEN.GT.BRECLEN-POINT) THEN ! If it extends to next record + LEFT = TEMP(POINT:) ! Store it in leftover buffer + LEFT_LEN = ILEN - (BRECLEN-POINT) ! Store leftover length + ILEN = 0 ! Request new record read + POINT = 1 ! Update record pointer. + ELSE IF (ILEN.EQ.0) THEN ! Empty line signifies + POINT = 1 ! end of message. + ELSE ! Else message line fully read + BUFFER = TEMP(POINT+1:POINT+ILEN) ! So output it + POINT = POINT+ILEN+1 ! and update pointer. + END IF + END IF + + RETURN + + ENTRY TEST_MORE_LINES(ILEN) ! Test for more lines in record. + ! Returns length of next line. + IF (POINT.EQ.BRECLEN+1) THEN ! If pointer greater than + ILEN = 0 ! record, no more lines. + ELSE ! Else there is another line. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Output it's length. + END IF + + RETURN + + END + + + + SUBROUTINE GET_REMOTE_MESSAGE(IER) +C +C SUBROUTINE GET_REMOTE_MESSAGE +C +C FUNCTION: +C Gets remote message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + IF (SCRATCH_R1.NE.0) THEN ! Is queue empty? + SCRATCH_R = SCRATCH_R1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_R,INPUT) + SCRATCH_R1 = SCRATCH_R ! Init header pointer + END IF + + ILEN = 128 + IER = 0 + LENGTH = 0 + DO WHILE (ILEN.GT.0.AND.IER.EQ.0) + READ (REMOTE_UNIT,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER1) + CALL SYS_GETMSG(IER1) + LENGTH = 0 + IER1 = IER + CALL DISCONNECT_REMOTE + IER = IER1 ! IER is set to 0 by DISCONNECT_REMOTE + ELSE IF (ILEN.GT.0) THEN + CALL WRITE_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT) + LENGTH = LENGTH + 1 + END IF + END DO + + RETURN + END + + + + + SUBROUTINE DELETE_ENTRY(BULL_ENTRY) +C +C SUBROUTINE DELETE_ENTRY +C +C FUNCTION: +C To delete a directory entry. +C +C INPUTS: +C BULL_ENTRY - Bulletin entry number to delete +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (NBULL.GT.0) THEN + CALL READDIR(0,IER) + NBULL = -NBULL + CALL WRITEDIR(0,IER) + END IF + + IF (BTEST(FOLDER_FLAG,1)) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',IOSTAT=IER,STATUS='OLD', + & RECL=LINE_LENGTH,CARRIAGECONTROL='LIST',ACCESS='APPEND') + IF (IER.NE.0) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + WRITE (3,'(A)') CHAR(12) + END IF + + CALL OPEN_BULLFIL + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + WRITE(3,1050) INPUT(7:ILEN) + ELSE + WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + + CALL CLOSE_BULLFIL + END IF + +900 CALL READDIR(BULL_ENTRY,IER) + DELETE(UNIT=2) + + NEMPTY = NEMPTY + LENGTH + CALL WRITEDIR(0,IER) + +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,' Date: ',A11) + + RETURN + END + + + + + SUBROUTINE GET_EXDATE(EXDATE,NDAYS) +C +C SUBROUTINE GET_EXDATE +C +C FUNCTION: Computes expiration date giving number of days to expire. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*11 EXDATE + + CHARACTER*3 MONTHS(12) + DIMENSION LENGTH(12) + DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP', + & 'OCT','NOV','DEC'/ + DATA LENGTH/31,27,31,30,31,30,31,31,30,31,30,31/ + + CALL SYS$ASCTIM(,EXDATE,,) ! Get the present date + + DECODE(2,'(I2)',EXDATE(:2)) DAY ! Get day + DECODE(4,'(I4)',EXDATE(8:11)) YEAR ! Get year + + MONTH = 1 + DO WHILE (MONTHS(MONTH).NE.EXDATE(4:6)) ! Get month + MONTH = MONTH + 1 + END DO + + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + + NUM_DAYS = NDAYS ! Put number of days into buffer variable + + DO WHILE (NUM_DAYS.GT.0) + IF (NUM_DAYS+DAY.GT.LENGTH(MONTH)) THEN + ! If expiration date exceeds end of month + NUM_DAYS = NUM_DAYS - (LENGTH(MONTH) - DAY + 1) + ! Decrement # of days by days left in month + DAY = 1 ! Reset day to first of month + MONTH = MONTH + 1 ! Increment month pointer + IF (MONTH.EQ.13) THEN ! Moved into next year? + MONTH = 1 ! Reset month pointer + YEAR = YEAR + 1 ! Increment year pointer + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + END IF + ELSE ! If expiration date is within the month + DAY = DAY + NUM_DAYS ! Find expiration day + NUM_DAYS = 0 ! Force loop exit + END IF + END DO + + ENCODE(2,'(I2)',EXDATE(:2)) DAY ! Put day into new date + ENCODE(4,'(I4)',EXDATE(8:11)) YEAR ! Put year into new date + EXDATE(4:6) = MONTHS(MONTH) ! Put month into new date + + RETURN + END + + + + SUBROUTINE GET_LINE(INPUT,LEN_INPUT) +C +C SUBROUTINE GET_LINE +C +C FUNCTION: +C Gets line of input from terminal. +C +C OUTPUTS: +C LEN_INPUT - Length of input line. If = -1, CTRLC entered. +C if = -2, CTRLZ entered. +C +C NOTES: +C Also, on first call, set LEN_INPUT to 1+LENGTH OF INPUT CHARCTER +C for initializing the CTRLC AST. +C + + IMPLICIT INTEGER (A-Z) + + LOGICAL*1 DESCRIP(8),DTYPE,CLASS + INTEGER*2 LENGTH + CHARACTER*(*) INPUT + EQUIVALENCE (DESCRIP(1),LENGTH),(DESCRIP(3),DTYPE) + EQUIVALENCE (DESCRIP(4),CLASS),(DESCRIP(5),POINTER) + + EXTERNAL SMG$_EOF + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + CHARACTER PROMPT*(*),NULLPROMPT*1 + LOGICAL*1 USE_PROMPT + + USE_PROMPT = .FALSE. + + GO TO 5 + + ENTRY GET_INPUT_PROMPT(INPUT,LEN_INPUT,PROMPT) + + USE_PROMPT = .TRUE. + +5 LIMIT = LEN(INPUT) ! Get input line size limit + INPUT = ' ' ! Clean out input buffer + +C +C Initialize CTRL-C AST with AST routine CTRLC_ROUTINE and +C AST parameter FLAG. When CTRLC occurs, FLAG is set to 1 +C + + CALL DECLARE_CTRLC_AST + + LEN_INPUT = 0 ! Nothing inputted yet + + LENGTH = 0 ! Init special variable + DTYPE = 0 ! descriptor so we won't + CLASS = 2 ! run into any memory limit + POINTER = 0 ! during input. + +C +C LIB$GET_INPUT is nice way of getting input from terminal, +C as it handles such thing as accidental wrap around to next line. +C + + IF (DECNET_PROC) THEN + READ (5,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (IER.NE.0) LEN_INPUT = -2 + RETURN + ELSE IF (USE_PROMPT) THEN + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,PROMPT) ! Get line from terminal with prompt + ELSE + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,NULLPROMPT) ! Get line from terminal with no prompt + END IF + + IF (.NOT.IER.AND.IER.NE.%LOC(SMG$_EOF)) CALL EXIT(IER) + + CALL STR$TRIM(DESCRIP,DESCRIP,LEN_INPUT) + + IF (FLAG.EQ.0) THEN ! If no CTRL-C has occurred + CALL CANCEL_CTRLC_AST ! Cancel CTRL-C AST + IF (IER.NE.%LOC(SMG$_EOF)) THEN ! End of input? + LEN_INPUT = MIN(LIMIT,LENGTH) ! No. Get length of line + DO I=0,LEN_INPUT-1 ! Extract from descriptor + CALL GET_VAL(INPUT(I+1:I+1),%VAL(POINTER+I)) + END DO + CALL CONVERT_TABS(INPUT,LEN_INPUT) + LEN_INPUT = MAX(LEN_INPUT,LENGTH) + ELSE + LEN_INPUT = -2 ! If CTRL-Z, say so + END IF + ELSE + LEN_INPUT = -1 ! If CTRL-C, say so + END IF + RETURN + END + + + + SUBROUTINE CONVERT_TABS(INPUT,LEN_INPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT + + PARAMETER TAB = CHAR(9) + + LIMIT = LEN(INPUT) + + DO WHILE (INDEX(INPUT,TAB).GT.0.AND.LEN_INPUT.LT.LIMIT) + TAB_POINT = INDEX(INPUT,TAB) ! Remove tabs + MOVE = ((TAB_POINT-1)/8)*8 + 9 + ADD = MOVE - TAB_POINT + IF (MOVE-1.LE.LIMIT) THEN + INPUT(MOVE:) = INPUT(TAB_POINT+1:) + DO I = TAB_POINT,MOVE-1 + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LEN_INPUT + ADD - 1 + ELSE + DO I = TAB_POINT,LIMIT + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LIMIT+1 + END IF + END DO + + CALL FILTER (INPUT, LEN_INPUT) + + RETURN + END + + + SUBROUTINE FILTER (INCHAR, LENGTH) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INCHAR + + DO I = 1,LENGTH + IF ((INCHAR(I:I).LT.' '.AND. + & INCHAR(I:I).NE.CHAR(13).AND.INCHAR(I:I).NE.CHAR(10)) + & .OR.INCHAR(I:I).GT.'~') INCHAR(I:I) = '.' + END DO + + RETURN + END + + + SUBROUTINE GET_VAL(OUTPUT,INPUT) ! Used to convert logical + CHARACTER*(*) OUTPUT ! byte to character value + LOGICAL*1 INPUT + OUTPUT = CHAR(INPUT) + RETURN + END + + SUBROUTINE CTRLC_ROUTINE ! CTRL-C AST routine + IMPLICIT INTEGER (A-Z) ! If CTRL-C, come here + + COMMON /CTRLY/ CTRLY + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + IF (FLAG.EQ.2) THEN + CALL LIB$PUT_OUTPUT('Bulletin aborting...') + CALL SYS$CANEXH() + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + CALL EXIT + END IF + FLAG = 1 ! to set flag + RETURN + END + + + + SUBROUTINE DECLARE_CTRLC_AST +C +C SUBROUTINE DECLARE_CTRLC_AST +C +C FUNCTION: +C Declares a CTRLC ast. +C NOTES: +C Assumes terminal assigned to TERM_CHAN in common /TERM_CHAN/. +C + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SETMODE,IO$M_CTRLCAST,CTRLC_ROUTINE + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /CTRLC_FLAG/ FLAG + + FLAG = 0 ! Init CTRL-C flag + IO_CTRLC = %LOC(IO$_SETMODE)+%LOC(IO$M_CTRLCAST) ! Set AST code + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + + ENTRY CANCEL_CTRLC_AST + + IER = SYS$CANCEL(%VAL(TERM_CHAN)) + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + END + + + + + SUBROUTINE GET_INPUT_NOECHO(DATA) +C +C SUBROUTINE GET_INPUT_NOECHO +C +C FUNCTION: Reads data in from terminal without echoing characters. +C Also contains entry to assign terminal. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) DATA,PROMPT + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /READIT/ READIT + + INCLUDE '($TRMDEF)' + + INTEGER TERMSET(2) + + INTEGER MASK(4) + DATA MASK/4*'FFFFFFFF'X/ + + DATA PURGE/.TRUE./ + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NOECHO_PROMPT(DATA,PROMPT) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NUM(DATA,NLEN) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_PURGE,,TERMSET,NLEN,TERM) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA),,, + & TERMSET,NLEN,TERM) + END IF + + IF (TERM.NE.13.AND.TERM.NE.510.AND.NLEN.EQ.0) THEN + ! Input did not end with CR or buffer full + NLEN = 1 + DATA(:1) = CHAR(TERM) + END IF + + RETURN + + ENTRY ASSIGN_TERMINAL + + IER = SYS$ASSIGN('TT',TERM_CHAN,,) ! Assign terminal + + CALL DECLARE_CTRLC_AST + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IF (CLI$PRESENT('KEYPAD')) THEN + CALL SET_KEYPAD + ELSE IF (READIT.EQ.0) THEN + CALL SET_NOKEYPAD + END IF + + TERMSET(1) = 16 + TERMSET(2) = %LOC(MASK) + + DO I=ICHAR('0'),ICHAR('9') + MASK(2) = IBCLR(MASK(2),I-32) + END DO + + RETURN + END + + + + + + SUBROUTINE GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) +C +C SUBROUTINE GETPAGSIZ +C +C FUNCTION: +C Gets page size of the terminal. +C +C OUTPUTS: +C PAGE_LENGTH - Page length of the terminal. +C PAGE_WIDTH - Page size of the terminal. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($DVIDEF)' + + LOGICAL*1 DEVDEPEND(4) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,DVI$_DEVDEPEND,%LOC(DEVDEPEND(1))) + CALL ADD_2_ITMLST(4,DVI$_DEVBUFSIZ,%LOC(PAGE_WIDTH)) + CALL END_ITMLST(GETDVI_ITMLST) ! Get address of itemlist + + CALL SYS$GETDVIW(,,'TT',%VAL(GETDVI_ITMLST),,,,) + + PAGE_LENGTH = ZEXT(DEVDEPEND(4)) + + PAGE_WIDTH = MIN(PAGE_WIDTH,132) + + RETURN + END + + + + + + LOGICAL FUNCTION SLOW_TERMINAL +C +C FUNCTION SLOW_TERMINAL +C +C FUNCTION: +C Indicates that terminal has a slow speed (2400 baud or less). +C +C OUTPUTS: +C SLOW_TERMINAL = .true. if slow, .false. if not. +C + + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SENSEMODE + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON CHAR_BUF(2) + + LOGICAL*1 IOSB(8) + + INCLUDE '($TTDEF)' + + IER = SYS$QIOW(,%VAL(TERM_CHAN),IO$_SENSEMODE,IOSB,,, + & CHAR_BUF,%VAL(8),,,,) + + IF (IOSB(3).LE.TT$C_BAUD_2400) THEN + SLOW_TERMINAL = .TRUE. + ELSE + SLOW_TERMINAL = .FALSE. + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_PRIV +C +C SUBROUTINE SHOW_PRIV +C +C FUNCTION: +C To show privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($PRVDEF)' + + INCLUDE '($SSDEF)' + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + IF (NEW_FLAG(1).EQ.-1.AND.NEW_FLAG(2).EQ.-1) THEN ! Info not present + CALL CLOSE_BULLUSER + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + WRITE (6,'('' Following privileges are needed for privileged + & commands:'')') + DO I=0,38 + IF ((I.LT.32.AND.BTEST(USERPRIV(1),I)).OR. + & (I.GT.31.AND.BTEST(USERPRIV(2),I-32))) THEN + WRITE (6,'(1X,A)') PRIVS(I) + END IF + END DO + ELSE + WRITE (6,'('' ERROR: Cannot show privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + CALL CHKACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE)),IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN + CALL SHOWACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE))) + END IF + + RETURN + + END + + + + + SUBROUTINE SET_PRIV +C +C SUBROUTINE SET_PRIV +C +C FUNCTION: +C To set privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + DATA PRIVS + & /'CMKRNL','CMEXEC','SYSNAM','GRPNAM','ALLSPOOL','DETACH', + & 'DIAGNOSE','LOG_IO','GROUP','ACNT','PRMCEB','PRMMBX','PSWAPM', + & 'ALTPRI','SETPRV','TMPMBX','WORLD','MOUNT','OPER','EXQUOTA', + & 'NETMBX','VOLPRO','PHY_IO','BUGCHK','PRMGBL','SYSGBL','PFNMAP', + & 'SHMEM','SYSPRV','BYPASS','SYSLCK','SHARE','UPGRADE','DOWNGRADE', + & 'GRPPRV','READALL',' ',' ','SECURITY'/ + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + DIMENSION ONPRIV(2),OFFPRIV(2) + + CHARACTER*32 INPUT_PRIV + + IF (.NOT.SETPRV_PRIV().OR..NOT.BTEST(PROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: This command requires SETPRV privileges.'')') + RETURN + END IF + + IF (CLI$PRESENT('ID').OR. + & CLI$PRESENT('ID').EQ.%LOC(CLI$_NEGATED)) THEN + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the IDs + IF (CLI$PRESENT('ID')) THEN + CALL ADD_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + ELSE + CALL DEL_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + END IF + IF (.NOT.IER) CALL SYS_GETMSG(IER) + END DO + RETURN + END IF + + OFFPRIV(1) = 0 + OFFPRIV(2) = 0 + ONPRIV(1) = 0 + ONPRIV(2) = 0 + + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the privileges + PRIV_FOUND = -1 + I = 0 + DO WHILE (I.LT.39.AND.PRIV_FOUND.EQ.-1) + IF (INPUT_PRIV(:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + IF (INPUT_PRIV(3:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + I = I + 1 + END DO + IF (PRIV_FOUND.EQ.-1) THEN + WRITE(6,'('' ERROR: Incorrectly specified privilege = '', + & A)') INPUT_PRIV(:PLEN) + RETURN + ELSE IF (INPUT_PRIV(:2).EQ.'NO') THEN + IF (INPUT_PRIV.EQ.'NOSETPRV') THEN + WRITE(6,'('' ERROR: Cannot remove SETPRV privileges.'')') + RETURN + ELSE IF (PRIV_FOUND.LT.32) THEN + OFFPRIV(1) = IBSET(OFFPRIV(1),PRIV_FOUND) + ELSE + OFFPRIV(2) = IBSET(OFFPRIV(2),PRIV_FOUND-32) + END IF + ELSE + IF (PRIV_FOUND.LT.32) THEN + ONPRIV(1) = IBSET(ONPRIV(1),PRIV_FOUND) + ELSE + ONPRIV(2) = IBSET(ONPRIV(2),PRIV_FOUND-32) + END IF + END IF + END DO + + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + USERPRIV(1) = USERPRIV(1).OR.ONPRIV(1) + USERPRIV(2) = USERPRIV(2).OR.ONPRIV(2) + USERPRIV(1) = USERPRIV(1).AND.(.NOT.OFFPRIV(1)) + USERPRIV(2) = USERPRIV(2).AND.(.NOT.OFFPRIV(2)) + REWRITE (4) USER_HEADER + WRITE (6,'('' Privileges successfully modified.'')') + ELSE + WRITE (6,'('' ERROR: Cannot modify privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + RETURN + + END + + + + + + + SUBROUTINE ADD_ACL(ID,ACCESS,IER) +C +C SUBROUTINE ADD_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + INCLUDE '($SSDEF)' + + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) THEN + IF (IER.EQ.SS$_NOSUCHID.AND.ADDID.AND. + & INDEX(ACCESS,'C').EQ.0) THEN + CALL GET_UAF(ID,USER,GROUP,ACCOUNT,FLAGS,IER) + IF (.NOT.IER) THEN + CALL ERRSNS(IDUMMY,IER) + WRITE (6,'( + & '' ERROR: Specified username cannot be verified.'')') + CALL SYS_GETMSG(IER) + RETURN + END IF + IDENT = USER + ISHFT(GROUP,16) + IER = SYS$ADD_IDENT(ID,%VAL(IDENT),,) + IF (IER) THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + END IF + END IF + END IF + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_ADDACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IF (INDEX(ACCESS,'C').GT.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + SUBROUTINE DEL_ACL(ID,ACCESS,IER) +C +C SUBROUTINE DEL_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + IF (ID.NE.' ') THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_DELACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_DELETEACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + END IF + + IF (INDEX(ACCESS,'C').GT.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + + SUBROUTINE CREATE_FOLDER +C +C SUBROUTINE CREATE_FOLDER +C +C FUNCTION: Creates a new bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + IF (.NOT.SETPRV_PRIV().AND.CLI$PRESENT('NEEDPRIV')) THEN + WRITE(6,'('' ERROR: CREATE is a privileged command.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('CREATE_FOLDER',FOLDER,LEN_T) ! Get folder name + + IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + IF (.NOT.SETPRV_PRIV().AND. ! /NOTIFY /READNEW /BRIEF privileged + & (CLI$PRESENT('NOTIFY').OR.CLI$PRESENT('READNEW').OR. + & CLI$PRESENT('BRIEF').OR.CLI$PRESENT('SYSTEM'))) THEN + WRITE (6,'( + & '' ERROR: No privs for SYSTEM, NOTIFY, BRIEF or READNEW.'')') + RETURN + END IF + + IF (CLI$PRESENT('NODE')) THEN ! Remote node specified? + IER = CLI$GET_VALUE('NODE',FOLDER_BBOARD,LEN_B) ! Get node name + FOLDER_BBOARD = '::'//FOLDER_BBOARD(:LEN_B) + FOLDER1_BBOARD = FOLDER_BBOARD + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE IF (CLI$PRESENT('SYSTEM').AND. + & .NOT.BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' ERROR: /SYSTEM not allowed as remote node'', + & '' is not SYSTEM folder.'')') + RETURN + END IF + END IF + + LENDES = 0 + DO WHILE (LENDES.EQ.0) + IF (CLI$PRESENT('DESCRIPTION')) THEN ! DESCRIPTION specified? + IER = CLI$GET_VALUE('DESCRIPTION',FOLDER_DESCRIP,LENDES) + ELSE + WRITE (6,'('' Enter one line description of folder.'')') + CALL GET_LINE(FOLDER_DESCRIP,LENDES) ! Get input line + FOLDER_DESCRIP = FOLDER_DESCRIP(:LENDES) ! End fill with spaces + END IF + IF (LENDES.LE.0) THEN + WRITE (6,'('' Aborting folder creation.'')') + RETURN + ELSE IF (LENDES.GT.80) THEN ! If too many characters + WRITE(6,'('' ERROR: folder must be < 80 characters.'')') + LENDES = 0 + END IF + END DO + + CALL OPEN_BULLFOLDER ! Open folder file + READ (7,IOSTAT=IER,KEY=FOLDER,KEYID=0) + ! See if folder exists + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Specified folder already exists.'')') + GO TO 1000 + END IF + + IF (CLI$PRESENT('OWNER')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: /OWNER requires privileges.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner not valid username.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + FOLDER_OWNER = FOLDER1_OWNER + END IF + END IF + ELSE + FOLDER_OWNER = USERNAME ! Get present username + FOLDER1_OWNER = FOLDER_OWNER ! Save for later + END IF + + FOLDER_SET = .TRUE. + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + +C +C Folder file is placed in the directory FOLDER_DIRECTORY. +C The file prefix is the name of the folder. +C + + FD_LEN = TRIM(FOLDER_DIRECTORY) + IF (FD_LEN.EQ.0) THEN + WRITE (6,'('' ERROR: System programmer has disabled folders.'')') + GO TO 910 + ELSE + FOLDER_FILE = FOLDER_DIRECTORY(:FD_LEN)//FOLDER + END IF + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder directory file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='NEW', + 1 ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',IOSTAT=IER) + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder message file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + FOLDER_FLAG = 0 + + IF (CLI$PRESENT('PRIVATE').OR.CLI$PRESENT('SEMIPRIVATE')) THEN + ! Will folder have access limitations? + FOLDER1_FILE = FOLDER_FILE + CLOSE (UNIT=1) + CLOSE (UNIT=2) + IF (CLI$PRESENT('SEMIPRIVATE')) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER_OWNER,'R+W+C',IER) + OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLDIR',STATUS='OLD',IOSTAT=IER1) + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='OLD',IOSTAT=IER1) + IF (.NOT.IER) THEN + WRITE(6, + & '('' ERROR: Cannot create private folder using ACLs.'')') + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + + IER = 0 + LAST_NUMBER = 1 + DO WHILE (IER.EQ.0.AND.LAST_NUMBER.LT.FOLDER_MAX-1) + READ (7,IOSTAT=IER,KEY=LAST_NUMBER,KEYID=1) + LAST_NUMBER = LAST_NUMBER + 1 + END DO + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder limit of '',I,'' has been reached.'')') + & FOLDER_MAX + WRITE (6,'('' Unable to add specified folder.'')') + GO TO 910 + ELSE + FOLDER1_NUMBER = LAST_NUMBER - 1 + END IF + + IF (.NOT.CLI$PRESENT('NODE')) THEN + FOLDER_BBOARD = 'NONE' + IF (REMOTE_SET) CLOSE (UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + FOLDER_BBEXPIRE = 14 + F_NBULL = 0 + NBULL = 0 + F_NEWEST_BTIM(1) = 0 + F_NEWEST_BTIM(2) = 0 + F_NEWEST_NOSYS_BTIM(1) = 0 + F_NEWEST_NOSYS_BTIM(2) = 0 + F_EXPIRE_LIMIT = 0 + FOLDER_NUMBER = FOLDER1_NUMBER + ELSE + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + IF (FOLDER1.NE.FOLDER) THEN ! Different remote folder name? + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! If so, store name in directory file + BULLDIR_HEADER(13:) = FOLDER1 + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:LEN_B+2)//'*' + FOLDER1 = FOLDER + END IF + REMOTE_SET = .TRUE. + IF (BTEST(FOLDER1_FLAG,0)) FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + FOLDER1_FLAG = FOLDER_FLAG + FOLDER1_DESCRIP = FOLDER_DESCRIP + FOLDER_COM = FOLDER1_COM + NBULL = F_NBULL + END IF + + FOLDER_OWNER = FOLDER1_OWNER + + IF (CLI$PRESENT('SYSTEM')) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + END IF + + CALL WRITE_FOLDER_FILE(IER) + CALL MODIFY_SYSTEM_LIST(0) + + CLOSE (UNIT=1) + CLOSE (UNIT=2) + + NOTIFY = 0 + READNEW = 0 + BRIEF = 0 + IF (CLI$PRESENT('NOTIFY')) NOTIFY = 1 + IF (CLI$PRESENT('READNEW')) READNEW = 1 + IF (CLI$PRESENT('SHOWNEW')) BRIEF = 1 + IF (CLI$PRESENT('BRIEF')) THEN + BRIEF = 1 + READNEW = 1 + END IF + CALL SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) + + WRITE (6,'('' Folder is now set to '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + + GO TO 1000 + +910 WRITE (6,'('' Aborting folder creation.'')') + IF (FOLDER_NUMBER.EQ.0) FOLDER_SET = .FALSE. + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + +1000 CALL CLOSE_BULLFOLDER + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + diff --git a/decus/vax89a2/nieland/bulletin/bulletin5.for b/decus/vax89a2/nieland/bulletin/bulletin5.for new file mode 100644 index 0000000..c0e7b92 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin5.for @@ -0,0 +1,1596 @@ +C +C BULLETIN5.FOR, Version 5/16/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) +C +C SUBROUTINE SET_FOLDER_DEFAULT +C +C FUNCTION: Sets flag defaults for specified folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL CLI$_NEGATED + + IF (.NOT.SETPRV_PRIV().AND.INCMD(:3).EQ.'SET') THEN + WRITE (6,'( + & '' ERROR: No privs to change all defaults.'')') + RETURN + END IF + + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_HEADER(IER) + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + REWRITE(4) USER_HEADER + + FLAG = 0 + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',TEMP_USER) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',TEMP_USER) + END IF + READ (TEMP_USER(:1),'(I1)',IOSTAT=IER) FLAG + + IF (NOTIFY.EQ.1.AND.BTEST(FLAG,1).AND. + & CLI$PRESENT('CLUSTER').EQ.%LOC(CLI$_NEGATED)) THEN + CALL OPEN_BULLNOTIFY + READ (10,KEY='*',IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=10) + FLAG = -1 + END IF + + IF (BRIEF.NE.-1.AND.NOTIFY.NE.-1.AND.READNEW.NE.-1) THEN + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + IF (TEMP_USER(:1).NE.'*'.AND.TEMP_USER(:1).NE.':') THEN + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG,FOLDER_NUMBER) + REWRITE(4) TEMP_USER//USER_ENTRY(13:) + IF (FLAG.EQ.-1) WRITE (10,IOSTAT=IER) TEMP_USER + END IF + CALL READ_USER_FILE(IER) + END DO + END IF + + IF (FLAG.EQ.-1) THEN + CALL CLOSE_BULLNOTIFY + ELSE IF (NOTIFY.EQ.1.AND.BTEST(FLAG,1).AND. + & CLI$PRESENT('CLUSTER').NE.%LOC(CLI$_NEGATED)) THEN + WRITE (6,'('' NOTE: In a cluster, /ALL or /DEFAULT '', + & ''causes all users to be notified.'')') + WRITE (6,'('' They will not be able to disable this.'', + & '' See HELP SET NOTIFY for more info.'')') + CALL OPEN_BULLNOTIFY + CALL CLOSE_BULLNOTIFY_DELETE + CALL OPEN_BULLNOTIFY + WRITE (10) '* ' + CALL CLOSE_BULLNOTIFY + ELSE IF (NOTIFY.EQ.0.AND.BTEST(FLAG,1)) THEN + CALL OPEN_BULLNOTIFY + READ (10,IOSTAT=IER) TEMP_USER + IF ((IER.EQ.0.AND.TEMP_USER.EQ.'*').OR. + & (BRIEF.NE.-1.AND.READNEW.NE.-1)) THEN + CALL CLOSE_BULLNOTIFY_DELETE + ELSE + CALL CLOSE_BULLNOTIFY + END IF + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + SUBROUTINE REMOVE_FOLDER +C +C SUBROUTINE REMOVE_FOLDER +C +C FUNCTION: Removes a bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,TEMP*80 + + IER = CLI$GET_VALUE('REMOVE_FOLDER',FOLDER1,LEN_T) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + IF (.NOT.FOLDER_SET) THEN + WRITE (6,'('' ERROR: No folder specified.'')') + RETURN + ELSE + FOLDER1 = FOLDER + END IF + ELSE IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Are you sure you want to remove folder ' + & //FOLDER1(:TRIM(FOLDER1))//' (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not removed.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if folder exists + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + GO TO 1000 + END IF + + IF ((FOLDER1_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()).OR. + & FOLDER1_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: You are not able to remove the folder.'')') + GO TO 1000 + END IF + + TEMP = FOLDER_FILE + FOLDER_FILE = FOLDER1_FILE + + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER1_FLAG,2)) THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) FLEN = FLEN - 1 + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER1_BBOARD(3:FLEN) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Deregister remote SYSTEM folder + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + IF (IER.EQ.1) FOLDER1 = BULLDIR_HEADER(13:) + CALL CLOSE_BULLDIR + END IF + WRITE (17,'(2A)',IOSTAT=IER) 1,FOLDER1 ! Select folder + IF (IER.EQ.0) READ(17,'(5A)',IOSTAT=IER) ! Throw away response + IF (IER.EQ.0) WRITE(17,'(2A)',IOSTAT=IER) 14,0 ! Deregister + CLOSE (UNIT=17) + END IF + END IF + + TEMPSET = FOLDER_SET + FOLDER_SET = .TRUE. + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + ! in case files don't exist and are created. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL OPEN_BULLNOTIFY + CALL CLOSE_BULLNOTIFY_DELETE + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + FOLDER_FILE = TEMP + FOLDER_SET = TEMPSET + + DELETE (7) + + TEMP_NUMBER = FOLDER_NUMBER + FOLDER_NUMBER = FOLDER1_NUMBER + CALL SET_FOLDER_DEFAULT(0,0,0) + FOLDER_NUMBER = TEMP_NUMBER + + WRITE (6,'('' Folder removed.'')') + + IF (FOLDER.EQ.FOLDER1) THEN + FOLDER_SET = .FALSE. + ELSE + REMOTE_SET = REMOTE_SET_SAVE + END IF + +1000 CALL CLOSE_BULLFOLDER + + RETURN + + END + + + SUBROUTINE SELECT_FOLDER(OUTPUT,IER) +C +C SUBROUTINE SELECT_FOLDER +C +C FUNCTION: Selects the specified folder. +C +C INPUTS: +C OUTPUT - Specifies whether status messages are outputted. +C +C NOTES: +C FOLDER_NUMBER is used for selecting the folder. +C If FOLDER_NUMBER = -1, the name stored in FOLDER1 is used. +C If FOLDER_NUMBER = -2, the name stored in FOLDER1 is used, +C but the folder is not selected if it is remote. +C If the specified folder is on a remote node and does not have +C a local entry (i.e. specified via NODENAME::FOLDERNAME), then +C FOLDER_NUMBER is set to -1. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + INCLUDE '($SSDEF)' + + COMMON /POINT/ BULL_POINT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /TAGS/ BULL_TAG,READ_TAG + + EXTERNAL CLI$_ABSENT + + CHARACTER*80 LOCAL_FOLDER1_DESCRIP + + DIMENSION FIRST_TIME(FLONG) ! Bit set for folder if folder has + DATA FIRST_TIME /FLONG*0/ ! been selected before this. + + COMMAND = (INCMD(:3).EQ.'ADD').OR.(INCMD(:3).EQ.'DEL').OR. + & (INCMD(:3).EQ.'DIR').OR.(INCMD(:3).EQ.'IND').OR. + & (INCMD(:3).EQ.'REP').OR.(INCMD(:3).EQ.'SEL').OR. + & (INCMD(:3).EQ.'SET') + + IF (.NOT.OUTPUT.OR.FOLDER_NUMBER.NE.-1.OR.COMMAND) THEN + IF (OUTPUT) THEN ! Get folder name + IER = CLI$GET_VALUE('SELECT_FOLDER',FOLDER1) + END IF + + FLEN = TRIM(FOLDER1) ! Add GENERAL after :: if no + IF (FLEN.GT.1) THEN ! name specified after the :: + IF (FOLDER1(FLEN-1:FLEN).EQ.'::') THEN + FOLDER1 = FOLDER1(:FLEN)//'GENERAL' + END IF + END IF + + IF (((IER.EQ.%LOC(CLI$_ABSENT).OR.FOLDER1.EQ.'GENERAL').AND. + & OUTPUT).OR.((FOLDER_NUMBER.EQ.0.OR.(FOLDER1.EQ.'GENERAL'.AND. + & FOLDER_NUMBER.LE.-1)).AND..NOT.OUTPUT)) THEN ! Select GENERAL + FOLDER_NUMBER = 0 + FOLDER1 = 'GENERAL' + END IF + END IF + + CALL OPEN_BULLFOLDER_SHARED ! Go find folder + + REMOTE_TEST = 0 + + IF (OUTPUT.OR.FOLDER_NUMBER.LE.-1) THEN + REMOTE_TEST = INDEX(FOLDER1,'::') + IF (REMOTE_TEST.GT.0) THEN + FOLDER1_BBOARD = '::'//FOLDER1(:REMOTE_TEST-1) + FOLDER1 = FOLDER1(REMOTE_TEST+2:TRIM(FOLDER1)) + FOLDER1_NUMBER = -1 + IER = 0 + ELSE IF (INCMD(:2).EQ.'SE') THEN + CALL READ_FOLDER_FILE_KEYNAME_TEMP + & (FOLDER1(:TRIM(FOLDER1)),IER) + ELSE + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + END IF + ELSE + FOLDER1_NUMBER = FOLDER_NUMBER + CALL READ_FOLDER_FILE_KEYNUM_TEMP(FOLDER_NUMBER,IER) + END IF + + IF (BTEST(FOLDER1_FLAG,29)) THEN ! Error in folder flag!! + FOLDER1_FLAG = FOLDER1_FLAG.AND.3 + F1_EXPIRE_LIMIT = 0 + CALL REWRITE_FOLDER_FILE_TEMP + END IF + + CALL CLOSE_BULLFOLDER + + IF (IER.EQ.0.AND.FOLDER1_BBOARD(:2).EQ.'::') THEN + IF (FOLDER_NUMBER.EQ.-2) RETURN ! Don't allow + LOCAL_FOLDER1_FLAG = FOLDER1_FLAG + LOCAL_FOLDER1_DESCRIP = FOLDER1_DESCRIP + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + IF (OUTPUT) THEN + WRITE (6,'('' ERROR: Unable to connect to folder.'')') + END IF + RETURN + END IF + IF (REMOTE_TEST.GT.0) THEN ! Folder specified with "::" + FOLDER1 = FOLDER1_BBOARD(3:TRIM(FOLDER1_BBOARD))//'::'// + & FOLDER1 + FOLDER1_NUMBER = -1 + ELSE ! True remote folder + FOLDER1_DESCRIP = LOCAL_FOLDER1_DESCRIP ! Use local description + IF (BTEST(FOLDER1_FLAG,0)) THEN ! Copy remote folder protection + LOCAL_FOLDER1_FLAG = IBSET(LOCAL_FOLDER1_FLAG,0) + ELSE + LOCAL_FOLDER1_FLAG = IBCLR(LOCAL_FOLDER1_FLAG,0) + END IF + FOLDER1_FLAG = LOCAL_FOLDER1_FLAG ! Use local flag info + CALL OPEN_BULLFOLDER ! Update local folder information + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + FOLDER_COM = FOLDER1_COM + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + END IF + REMOTE_SET = .TRUE. + END IF + + IF (IER.EQ.0) THEN ! Folder found + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + IF (BTEST(FOLDER1_FLAG,0).AND.FOLDER1_BBOARD(:2).NE.'::' + & .AND..NOT.SETPRV_PRIV()) THEN + ! Is folder protected and not remote? + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER1_OWNER) THEN + IF (SETPRV_PRIV()) THEN + READ_ACCESS = 1 + WRITE_ACCESS = 1 + ELSE + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + END IF + IF (.NOT.READ_ACCESS.AND..NOT.WRITE_ACCESS) THEN + IF (OUTPUT) THEN + WRITE(6,'('' You are not allowed to access folder.'')') + WRITE(6,'('' See '',A,'' if you wish to access folder.'')') + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + ELSE IF (TEST2(BRIEF_FLAG,FOLDER1_NUMBER).OR. + & TEST2(SET_FLAG,FOLDER1_NUMBER)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER1_NUMBER) + CALL CLR2(SET_FLAG,FOLDER1_NUMBER) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + IER = 0 + RETURN + END IF + ELSE IF (BTEST(FOLDER1_FLAG,0).AND. + & IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER1) + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + ELSE ! Folder not protected + IER = SS$_ACLEMPTY.OR.SS$_NORMAL ! Indicate folder selected + END IF + + IF (FOLDER1_BBOARD(:2).NE.'::') THEN + IF (REMOTE_SET) CLOSE(UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + END IF + + IF (IER) THEN + FOLDER_COM = FOLDER1_COM ! Folder successfully set so + FOLDER_FILE = FOLDER1_FILE ! update folder parameters + + IF (FOLDER_NUMBER.NE.0) THEN + FOLDER_SET = .TRUE. + ELSE + FOLDER_SET = .FALSE. + END IF + + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + WRITE (6,'('' Folder has been set to '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + BULL_POINT = 0 ! Reset pointer to first bulletin + END IF + + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER_OWNER) THEN + IF (.NOT.WRITE_ACCESS) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') + & WRITE (6,'('' Folder only accessible for reading.'')') + READ_ONLY = .TRUE. + ELSE + READ_ONLY = .FALSE. + END IF + ELSE + READ_ONLY = .FALSE. + END IF + + IF (FOLDER_NUMBER.GT.0) THEN + IF (TEST_BULLCP()) THEN + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + ELSE IF (.NOT.TEST2(FIRST_TIME,FOLDER_NUMBER)) THEN + ! If first select, look for expired messages. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) ! Get header info from BULLDIR.DAT + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired? + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)) + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown bulletins exist? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER.GT.20*356.OR.IER1.LE.0) THEN + CALL UPDATE ! Need to update + END IF + ELSE + NBULL = 0 + END IF + CALL CLOSE_BULLDIR + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + END IF + END IF + + IF (OUTPUT) THEN + IF (FOLDER_NUMBER.GE.0.AND.CLI$PRESENT('MARKED')) THEN + READ_TAG = .TRUE. + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + IF (INCMD(:3).NE.'DIR') THEN + IF (IER.EQ.0) THEN + WRITE(6,'('' NOTE: Only marked messages'', + & '' will be shown.'')') + ELSE + WRITE(6,'('' ERROR: No marked messages found.'')') + END IF + END IF + ELSE + READ_TAG = .FALSE. + END IF + END IF + + IF (FOLDER_NUMBER.NE.0.AND..NOT.READ_TAG) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN ! If new unread messages + CALL FIND_NEWEST_BULL ! See if we can find it + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + END IF + END IF + END IF + END IF + IER = 1 + ELSE IF (OUTPUT) THEN + WRITE (6,'('' Cannot access specified folder.'')') + CALL SYS_GETMSG(IER) + END IF + ELSE ! Folder not found + IF (OUTPUT) WRITE (6,'('' ERROR: Folder does not exist.'')') + IER = 0 + END IF + + RETURN + + END + + + + SUBROUTINE CONNECT_REMOTE_FOLDER(READ_ONLY,IER) +C +C SUBROUTINE CONNECT_REMOTE_FOLDER +C +C FUNCTION: Connects to folder that is located on other DECNET node. +C + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_UNIT /15/ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*12 FOLDER_BBOARD_SAVE,FOLDER_OWNER_SAVE + CHARACTER*25 FOLDER_SAVE + + DIMENSION DUMMY(2) + + REMOTE_UNIT = 31 - REMOTE_UNIT + + SAME = .TRUE. + LEN_BBOARD = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN ! Remote folder name different + SAME = .FALSE. ! from local? Yes. + LEN_BBOARD = LEN_BBOARD - 1 + END IF + + OPEN (UNIT=REMOTE_UNIT,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=FOLDER1_BBOARD(3:LEN_BBOARD)//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IF (.NOT.SAME) THEN + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + FOLDER_FILE = FOLDER1_FILE + FOLDER_SAVE = FOLDER1 + FOLDER1 = BULLDIR_HEADER(13:) + END IF + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 1,FOLDER1 + FOLDER_OWNER_SAVE = FOLDER1_OWNER + FOLDER_BBOARD_SAVE = FOLDER1_BBOARD + FOLDER_NUMBER_SAVE = FOLDER1_NUMBER + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(5A)',IOSTAT=IER)IER1,READ_ONLY, + & DUMMY(1),DUMMY(2),FOLDER1_COM + END IF + IF (.NOT.SAME) FOLDER1 = FOLDER_SAVE + END IF + + IF (IER.NE.0.OR..NOT.IER1) THEN + CLOSE (UNIT=REMOTE_UNIT) + REMOTE_UNIT = 31 - REMOTE_UNIT + IF (IER.EQ.0.AND.FOLDER_NUMBER_SAVE.GE.0) THEN + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + & .OR.TEST2(SET_FLAG,FOLDER_NUMBER_SAVE)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + CALL CLR2(SET_FLAG,FOLDER_NUMBER_SAVE) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + END IF + IER = 2 + ELSE + FOLDER1_BBOARD = FOLDER_BBOARD_SAVE + FOLDER1_NUMBER = FOLDER_NUMBER_SAVE + FOLDER1_OWNER = FOLDER_OWNER_SAVE + CLOSE (UNIT=31-REMOTE_UNIT) +C +C If remote folder has returned a last read time for the folder, +C and if in /LOGIN mode, or last selected folder was a different +C folder, or folder specified with "::", then update last read time. +C + IF (((FOLDER_NUMBER.NE.FOLDER1_NUMBER.OR.LOGIN_SWITCH) + & .AND.(DUMMY(1).NE.0.OR.DUMMY(2).NE.0)) + & .OR.FOLDER1_NUMBER.EQ.-1) THEN + LAST_READ_BTIM(1,FOLDER1_NUMBER+1) = DUMMY(1) + LAST_READ_BTIM(2,FOLDER1_NUMBER+1) = DUMMY(2) + END IF + IER = 0 + END IF + + RETURN + END + + + + + + + + + + SUBROUTINE UPDATE_FOLDER +C +C SUBROUTINE UPDATE_FOLDER +C +C FUNCTION: Updates folder info due to new message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (FOLDER_NUMBER.LT.0) RETURN + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + + F_NBULL = NBULL + + IF (FOLDER_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + + IF (.NOT.BTEST(SYSTEM,0)) THEN ! Is non-system message? + F_NEWEST_NOSYS_BTIM(1) = F_NEWEST_BTIM(1) ! If so, update latest + F_NEWEST_NOSYS_BTIM(2) = F_NEWEST_BTIM(2) ! system time. + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + SUBROUTINE SHOW_FOLDER +C +C SUBROUTINE SHOW_FOLDER +C +C FUNCTION: Shows the information on any folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + INCLUDE '($SSDEF)' + + INCLUDE '($RMSDEF)' + + EXTERNAL CLI$_ABSENT + + IF (CLI$GET_VALUE('SHOW_FOLDER',FOLDER1).EQ.%LOC(CLI$_ABSENT)) + & FOLDER1 = FOLDER + + IF (INDEX(FOLDER1,'::').NE.0) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Specified folder was not found.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (FOLDER.EQ.FOLDER1) THEN + WRITE (6,1000) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + ELSE + WRITE (6,1010) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + END IF + + IF (CLI$PRESENT('FULL')) THEN + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL).OR.(.NOT.IER)) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND. ! Is folder remote + & BTEST(FOLDER1_FLAG,0)) THEN ! and private? + WRITE (6,'('' Folder is a private folder.'')') + ELSE + WRITE (6,'('' Folder is not a private folder.'')') + END IF + ELSE + IF (SETPRV_PRIV()) THEN + READ_ACCESS = 1 + WRITE_ACCESS = 1 + ELSE + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + END IF + IF (WRITE_ACCESS) + & CALL SHOWACL(FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL') + END IF + IF (SETPRV_PRIV().OR.USERNAME.EQ.FOLDER1_OWNER) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').EQ.0) THEN + WRITE (6,'('' Folder is located on node '', + & A,''.'')') FOLDER1_BBOARD(3:FLEN) + ELSE + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + WRITE (6,'('' Folder is located on node '', + & A,''. Remote folder name is '',A,''.'')') + & FOLDER1_BBOARD(3:FLEN-1), + & BULLDIR_HEADER(13:TRIM(BULLDIR_HEADER)) + END IF + ELSE IF (FOLDER1_BBOARD.NE.'NONE') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (FLEN.GT.0) THEN + WRITE (6,'('' BBOARD for folder is '',A,''.'')') + & FOLDER1_BBOARD(:FLEN) + END IF + IF ((USERB1.EQ.0.AND.GROUPB1.EQ.0).OR.BTEST(USERB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /SPECIAL.'')') + IF (BTEST(GROUPB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /VMSMAIL.'')') + END IF + END IF + ELSE + WRITE (6,'('' No BBOARD has been defined.'')') + END IF + IF (FOLDER1_BBEXPIRE.GT.0) THEN + WRITE (6,'('' Default expiration is '',I3,'' days.'')') + & FOLDER1_BBEXPIRE + ELSE IF (FOLDER1_BBEXPIRE.EQ.-1) THEN + WRITE (6,'('' Default expiration is permanent.'')') + ELSE + WRITE (6,'('' No default expiration set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' SYSTEM has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,1)) THEN + WRITE (6,'('' DUMP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,3)) THEN + WRITE (6,'('' NOPROMPT_EXPIRE has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,4)) THEN + WRITE (6,'('' STRIP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,5)) THEN + WRITE (6,'('' DIGEST has been set.'')') + END IF + IF (F1_EXPIRE_LIMIT.GT.0) THEN + WRITE (6,'('' EXPIRATION limit is '',I3,'' days.'')') + & F1_EXPIRE_LIMIT + END IF + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_HEADER(IER) + IF (TEST2(SET_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is BRIEF.'')') + ELSE + WRITE (6,'('' Default is READNEW.'')') + END IF + ELSE + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is SHOWNEW.'')') + ELSE + WRITE (6,'('' Default is NOREADNEW.'')') + END IF + END IF + IF (TEST2(NOTIFY_FLAG_DEF,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is NOTIFY.'')') + ELSE + WRITE (6,'('' Default is NONOTIFY.'')') + END IF + CALL CLOSE_BULLUSER + END IF + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + +1000 FORMAT(' Current folder is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) +1010 FORMAT(' Folder name is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) + END + + + SUBROUTINE DIRECTORY_FOLDERS(FOLDER_COUNT) +C +C SUBROUTINE DIRECTORY_FOLDERS +C +C FUNCTION: Display all FOLDER entries. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + DATA SCRATCH_D1/0/ + + CHARACTER*17 DATETIME + + IF (FOLDER_COUNT.GT.0) GO TO 50 ! Skip init steps if this is + ! not the 1st page of folder + + IF (CLI$PRESENT('DESCRIBE')) THEN + NLINE = 2 ! Include folder descriptor if /DESCRIBE specified + ELSE + NLINE = 1 + END IF + +C +C Folder listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C folder file, and to avoid the possibility of the user holding the screen, +C and thus causing the folder file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + CALL INIT_QUEUE(SCRATCH_D1,FOLDER1_COM) + SCRATCH_D = SCRATCH_D1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDER = 0 + IER = 0 + FOLDER1 = ' ' ! Start folder search + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0) THEN + IF (BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + NUM_FOLDER = NUM_FOLDER + 1 + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + IF (NUM_FOLDER.EQ.0) THEN + WRITE (6,'('' There are no folders.'')') + RETURN + END IF + +C +C Folder entries are now in queue. Output queue entries to screen. +C + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + + FOLDER_COUNT = 1 ! Init folder number counter + +50 CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + WRITE (6,'(1X,''Folder'',22X,''Last message'',7X,''Messages'', + & 2X,''Owner'',/,1X,80(''-''))') + + IF (.NOT.PAGING) THEN + DISPLAY = (NUM_FOLDER-FOLDER_COUNT+1)*NLINE+2 + ELSE + DISPLAY = MIN((NUM_FOLDER-FOLDER_COUNT+1)*NLINE+2,PAGE_LENGTH-4) + ! If more entries than page size, truncate output + END IF + + DO I=FOLDER_COUNT,FOLDER_COUNT+(DISPLAY-2)/NLINE-1 + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + DIFF = COMPARE_BTIM + & (LAST_READ_BTIM(1,FOLDER1_NUMBER+1),F1_NEWEST_BTIM) + IF (F1_NBULL.GT.0) THEN + CALL SYS$ASCTIM(,DATETIME,F1_NEWEST_BTIM,) + ELSE + DATETIME = ' NONE' + END IF + IF (DIFF.GE.0.OR.F1_NBULL.EQ.0) THEN + WRITE (6,1000) ' '//FOLDER1,DATETIME,F1_NBULL,FOLDER1_OWNER + ELSE + WRITE (6,1000) '*'//FOLDER1,DATETIME,F1_NBULL,FOLDER1_OWNER + END IF + IF (NLINE.EQ.2) WRITE (6,'(1X,A)') FOLDER1_DESCRIP + FOLDER_COUNT = FOLDER_COUNT + 1 ! Update folder counter + END DO + + IF (FOLDER_COUNT.GT.NUM_FOLDER) THEN ! Outputted all entries? + FOLDER_COUNT = 0 ! Yes. Set counter to 0. + ELSE + WRITE(6,1010) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(1X,A26,2X,A17,2X,I8,2X,A12) +1010 FORMAT(1X,/,' Press RETURN for more...',/) + + END + + + SUBROUTINE SET_ACCESS(ACCESS) +C +C SUBROUTINE SET_ACCESS +C +C FUNCTION: Set access on folder for specified ID. +C +C PARAMETERS: +C ACCESS - Logical: If .true., grant access, if .false. deny access +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + LOGICAL ACCESS,ALL,READONLY + + EXTERNAL CLI$_ABSENT + + CHARACTER ID*64,RESPONSE*1 + + CHARACTER INPUT*132 + + IF (CLI$PRESENT('ALL')) THEN + ALL = .TRUE. + ELSE + ALL = .FALSE. + END IF + + IF (CLI$PRESENT('READONLY')) THEN + READONLY = .TRUE. + ELSE + READONLY = .FALSE. + END IF + + IER = CLI$GET_VALUE('ACCESS_FOLDER',FOLDER1,LEN) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + FOLDER1 = FOLDER + ELSE IF (LEN.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if it exists + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + ELSE IF (FOLDER1_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6, + & '('' ERROR: You are not able to modify access to the folder.'')') + ELSE + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + IF ((ALL.AND..NOT.READONLY).OR.(.NOT.ACCESS)) THEN + WRITE (6,'('' ERROR: Folder is not a private folder.'')') + RETURN + END IF + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Folder is not private. Do you want to make it so? (Y/N): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder access was not changed.'')') + RETURN + ELSE + FOLDER1_FLAG = IBSET(FOLDER1_FLAG,0) + IF (READONLY.AND.ALL) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + IF (ALL) THEN ! All finished, so exit + WRITE (6,'('' Access to folder has been modified.'')') + GOTO 100 + END IF + END IF + END IF + + IF (ALL) THEN + IF (ACCESS) THEN + CALL DEL_ACL(' ','R+W',IER) + IF (READONLY) THEN + CALL ADD_ACL('*','R',IER) + ELSE + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + END IF + ELSE + CALL DEL_ACL('*','R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access.'')') + CALL SYS_GETMSG(IER) + END IF + END IF + + DO WHILE (CLI$GET_VALUE('ACCESS_ID',INPUT,ILEN) + & .NE.%LOC(CLI$_ABSENT).AND..NOT.ALL) + IER = SYS_TRNLNM(INPUT,INPUT) + IF (INPUT(:1).EQ.'@') THEN + ILEN = INDEX(INPUT,',') - 1 + IF (ILEN.EQ.-1) ILEN = TRIM(INPUT) + OPEN (UNIT=3,STATUS='OLD',FILE=INPUT(2:ILEN), + & DEFAULTFILE='.DIS',IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Cannot find file '',A)') + & INPUT(2:ILEN) + RETURN + END IF + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + ELSE + FILE_OPEN = .TRUE. + END IF + ELSE + FILE_OPEN = .FALSE. + END IF + DO WHILE (TRIM(INPUT).GT.0) + COMMA = INDEX(INPUT,',') + IF (INPUT(:1).EQ.'[') COMMA = INDEX(INPUT,']') + 1 + IF (INPUT(:1).EQ.'"') COMMA = INDEX(INPUT(2:),'"') + 2 + IF (COMMA.GT.0) THEN + ID = INPUT(1:COMMA-1) + INPUT = INPUT(COMMA+1:) + ELSE + ID = INPUT + INPUT = ' ' + END IF + ILEN = TRIM(ID) + IF (ID.EQ.FOLDER1_OWNER) THEN + WRITE (6,'('' ERROR: Cannot modify access'', + & '' for owner of folder.'')') + ELSE + IF (ACCESS) THEN + IF (READONLY) THEN + CALL ADD_ACL(ID,'R',IER) + ELSE + CALL ADD_ACL(ID,'R+W',IER) + END IF + ELSE + CALL DEL_ACL(ID,'R+W',IER) + IF (.NOT.IER) CALL DEL_ACL(ID,'R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access for '',A, + & ''.'')') ID(:ILEN) + CALL SYS_GETMSG(IER) + ELSE + WRITE(6,'('' Access modified for '',A,''.'')') + & ID(:ILEN) + END IF + END IF + IF (TRIM(INPUT).EQ.0.AND.FILE_OPEN) THEN + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + FILE_OPEN = .FALSE. + END IF + END IF + END DO + END DO + +100 IF (OLD_FOLDER1_FLAG.NE.FOLDER1_FLAG) THEN + CALL OPEN_BULLFOLDER ! Open folder file + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FLAG = OLD_FOLDER1_FLAG + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + END IF + + RETURN + + END + + + + SUBROUTINE CHKACL(FILENAME,IERACL) +C +C SUBROUTINE CHKACL +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C IERACL - Error returned for attempt to open file. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) FILENAME + + INCLUDE '($ACLDEF)' + INCLUDE '($SSDEF)' + + CHARACTER*255 ACLENT,ACLSTR + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IERACL=SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + IF (IERACL.EQ.SS$_ACLEMPTY) THEN + IERACL = SS$_NORMAL.OR.IERACL + END IF + + RETURN + END + + + + SUBROUTINE CHECK_ACCESS(FILENAME,USERNAME,READ_ACCESS,WRITE_ACCESS) +C +C SUBROUTINE CHECK_ACCESS +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C USERNAME - Name of user to check access for. +C READ_ACCESS - Error returned indicating read access. +C WRITE_ACCESS - Error returned indicating write access. +C If initially set to -1, indicates just +C folder for read access. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER FILENAME*(*),USERNAME*(*),ACE*255,OUTPUT*80 + + INCLUDE '($ACLDEF)' + INCLUDE '($CHPDEF)' + INCLUDE '($ARMDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,CHP$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(4,CHP$_ACCESS,%LOC(ACCESS)) + CALL ADD_2_ITMLST(LEN(ACE),CHP$_MATCHEDACE,%LOC(ACE)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + FLAGS = 0 ! Default is no access + + ACCESS = ARM$M_READ ! Check if user has read access + READ_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + IF (.NOT.SETPRV_PRIV().AND.ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'READ').EQ.0) READ_ACCESS = 0 + ELSE IF (ICHAR(ACE(:1)).EQ.0.AND.READ_ACCESS) THEN + READ_ACCESS = 0 + END IF + + IF (WRITE_ACCESS.EQ.-1) THEN ! Only check read access + RETURN + ELSE IF (READ_ACCESS.EQ.0) THEN ! If no read access, then of + WRITE_ACCESS = 0 ! course there is no write access. + RETURN + END IF + + ACCESS = ARM$M_WRITE ! Check if user has write access + WRITE_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + IF (.NOT.SETPRV_PRIV().AND.ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'WRITE').EQ.0) WRITE_ACCESS = 0 + END IF + + RETURN + END + + + + + SUBROUTINE SHOWACL(FILENAME) +C +C SUBROUTINE SHOWACL +C +C FUNCTION: Shows users who are allowed to read private bulletin. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER*(*) FILENAME + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + CALL LIB$GET_VM(ACLLENGTH+8,ACLSTR) + CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) + + CALL READACL(FILENAME,%VAL(ACLSTR),ACLLENGTH) + + RETURN + END + + + + SUBROUTINE FOLDER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLFOLDER.INC' + + ENTRY WRITE_FOLDER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + WRITE (7,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + ENTRY REWRITE_FOLDER_FILE + + REWRITE (7) FOLDER_COM + + RETURN + + ENTRY REWRITE_FOLDER_FILE_TEMP + + REWRITE (7) FOLDER1_COM + + RETURN + + ENTRY READ_FOLDER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_TEMP(IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM(KEY_NUMBER,IER) + + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER_COM + END DO + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM_TEMP(KEY_NUMBER,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME_TEMP(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + END + + + SUBROUTINE USER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 SAVE_USERNAME + + ENTRY READ_USER_FILE(IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) USER_ENTRY + END DO + + TEMP_USER = USERNAME + USERNAME = SAVE_USERNAME + + RETURN + + ENTRY READ_USER_FILE_KEYNAME(KEY_NAME,IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=KEY_NAME,IOSTAT=IER) USER_ENTRY + END DO + + USERNAME = SAVE_USERNAME + TEMP_USER = KEY_NAME + + RETURN + + ENTRY READ_USER_FILE_HEADER(IER) + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=' ',IOSTAT=IER) USER_HEADER + END DO + + RETURN + + ENTRY WRITE_USER_FILE_NEW(IER) + + SET_FLAG(1) = SET_FLAG_DEF(1) + SET_FLAG(2) = SET_FLAG_DEF(2) + BRIEF_FLAG(1) = BRIEF_FLAG_DEF(1) + BRIEF_FLAG(2) = BRIEF_FLAG_DEF(2) + NOTIFY_FLAG(1) = NOTIFY_FLAG_DEF(1) + NOTIFY_FLAG(2) = NOTIFY_FLAG_DEF(2) + + ENTRY WRITE_USER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + WRITE (4,IOSTAT=IER) USER_ENTRY + END DO + + RETURN + + END + + + + + + SUBROUTINE SET_GENERIC(GENERIC) +C +C SUBROUTINE SET_GENERIC +C +C FUNCTION: Enables or disables "GENERIC" display, i.e. displaying +C general bulletins continually for a certain amount of days. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change GENERIC.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + IF (IER.EQ.0) THEN + IF (GENERIC) THEN + IF (CLI$PRESENT('DAYS')) THEN + IER = CLI$GET_VALUE('DAYS',BULL_PARAMETER) + CALL LIB$MOVC3(4,%REF(BULL_PARAMETER),NEW_FLAG(2)) + ELSE + NEW_FLAG(2) = ' 7' + END IF + ELSE + NEW_FLAG(2) = 0 + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET_LOGIN(LOGIN) +C +C SUBROUTINE SET_LOGIN +C +C FUNCTION: Enables or disables bulletin display at login. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER TODAY*23 + + DIMENSION NOLOGIN_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change LOGIN.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + IF (IER.EQ.0) THEN + IF (LOGIN.AND.COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + CALL SYS_BINTIM(TODAY,LOGIN_BTIM) + ELSE IF (.NOT.LOGIN) THEN + LOGIN_BTIM(1) = NOLOGIN_BTIM(1) + LOGIN_BTIM(2) = NOLOGIN_BTIM(2) + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE GET_UAF(USERNAME,USER,GROUP,ACCOUNT,FLAGS,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER USERNAME*(*),ACCOUNT*(*) + + INCLUDE '($UAIDEF)' + + INTEGER*2 UIC(2) + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(LEN(ACCOUNT),UAI$_ACCOUNT,%LOC(ACCOUNT)) + CALL ADD_2_ITMLST(4,UAI$_UIC,%LOC(UIC)) + CALL END_ITMLST(GETUAI_ITMLST) + + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) + + USER = UIC(1) + GROUP = UIC(2) + + RETURN + END + + + + SUBROUTINE DCLEXH(EXIT_ROUTINE) + + IMPLICIT INTEGER (A-Z) + + INTEGER*4 EXBLK(4) + + EXBLK(2) = EXIT_ROUTINE + EXBLK(3) = 1 + EXBLK(4) = %LOC(EXBLK(4)) + + CALL SYS$DCLEXH(EXBLK(1)) + + RETURN + END diff --git a/decus/vax89a2/nieland/bulletin/bulletin6.for b/decus/vax89a2/nieland/bulletin/bulletin6.for new file mode 100644 index 0000000..99bc71f --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin6.for @@ -0,0 +1,1502 @@ +C +C BULLETIN6.FOR, Version 5/1/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE CLOSE_FILE +C +C SUBROUTINE CLOSE_FILE +C +C FUNCTION: To close out the bulletin files and enable CTRL-C & -Y +C + DATA LUN /0/ + + ENTRY CLOSE_BULLNOTIFY + LUN = LUN + 1 ! Unit = 10 + + ENTRY CLOSE_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY CLOSE_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY CLOSE_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY CLOSE_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY CLOSE_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN) + + LUN = 0 + + RETURN + END + + + SUBROUTINE CLOSE_FILE_DELETE + + IMPLICIT INTEGER (A-Z) + + DATA LUN /0/ + + ENTRY CLOSE_BULLNOTIFY_DELETE + LUN = LUN + 8 ! Unit = 10 + + ENTRY CLOSE_BULLDIR_DELETE + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL_DELETE + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN,STATUS='DELETE') + + LUN = 0 + + RETURN + END + + + SUBROUTINE OPEN_FILE(UNIT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($FORIOSDEF)' + + INCLUDE '($PRVDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + DATA LUN /0/ + + LUN = UNIT - 10 ! 10 gets added to LUN + + ENTRY OPEN_BULLNOTIFY + LUN = LUN + 1 ! Unit = 10 + + ENTRY OPEN_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL ! No breaks while file is open + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + WRITE (4,FMT=USER_FMT) USER_HEADER_KEY,NEWEST_BTIM, + & BBOARD_BTIM,PRV$M_OPER.OR.PRV$M_CMKRNL.OR. + & PRV$M_SETPRV,(0,I=1,FLONG*4-1) + CLOSE (UNIT=4) + IDUMMY = FILE_LOCK(IER,IER1) + ELSE IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + FOLDER1 = 'GENERAL' + FOLDER1_OWNER = 'SYSTEM' + FOLDER1_DESCRIP = 'Default general bulletin folder.' + FOLDER1_BBOARD = 'NONE' + FOLDER1_BBEXPIRE = 14 + NBULL = 0 + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER2, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + WRITE (7,FMT=FOLDER_FMT,IOSTAT=IER2) + & FOLDER1,0,FOLDER1_OWNER,FOLDER1_DESCRIP + & ,FOLDER1_BBOARD,FOLDER1_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,4,0,F_NEWEST_NOSYS_BTIM + ! 4 means system folder + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = 0 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.10) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=10,STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=3, + & ORGANIZATION='INDEXED',KEY=(1:12:CHARACTER), + & FORM='UNFORMATTED', + & FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.NOTIFY') + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (IER.NE.0) THEN + WRITE (6,'( + & '' Cannot open file in OPEN_FILE, unit = '',I)') LUN + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT ! Enable CTRL-Y & -C & EXIT + END IF + + LUN = 0 + + RETURN + END + + + + SUBROUTINE TIMER_ERR(UNIT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*14 NAMES(6) + DATA NAMES/'directory','message','BULLUSER.DAT','BULLFOLDER.DAT', + & 'BULLINF.DAT','notify'/ + INTEGER NAME(10) + DATA NAME/1,2,0,3,0,0,4,0,5,6/ + + IF (TEST_BULLCP().NE.2) THEN ! If BULLCP process, don't log error + WRITE(6,'('' ERROR: Unable to open '',A, + & '' file after 30 secs.'')') + & NAMES(NAME(UNIT))(:TRIM(NAMES(NAME(UNIT)))) + WRITE (6,'('' Please try again later.'')') + END IF + + CALL ENABLE_CTRL_EXIT ! No breaks while file is open + END + + + + SUBROUTINE OPEN_FILE_SHARED + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + EXTERNAL LNM_MODE_EXEC,ENABLE_CTRL_EXIT +C +C The following 2 files were used prior to V1.1. +C + CHARACTER*80 BULLDIR_FILE /'BULL_DIR:BULLDIR.DAT'/ + CHARACTER*80 BULLETIN_FILE /'BULL_DIR:BULLETIN.DAT'/ + + CHARACTER*25 SAVE_FOLDER + DATA SAVE_BLOCK/-1/ + + DATA LUN /0/ + + ENTRY OPEN_BULLNOTIFY_SHARED + LUN = LUN + 1 ! Unit = 10 + + ENTRY OPEN_BULLINF_SHARED + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF_SHARED + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER_SHARED + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER_SHARED + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR_SHARED + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL_SHARED + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.(FOLDER_NUMBER.EQ.0 + & .OR.FOLDER.EQ.'GENERAL')) THEN + IER2 = LIB$RENAME_FILE(BULLETIN_FILE,'GENERAL.BULLFIL') + IER2 = LIB$RENAME_FILE(BULLDIR_FILE,'GENERAL.BULLDIR') + IF (IER2) IDUMMY = FILE_LOCK(IER,IER1) ! Don't break out of loop + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND.REMOTE_SET.AND.(SAVE_BLOCK.NE.BLOCK.OR. + & SAVE_FOLDER.NE.FOLDER)) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,BULL_POINT + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + SAVE_BLOCK = BLOCK + SAVE_FOLDER = FOLDER + CALL GET_REMOTE_MESSAGE(IER) + IER = 0 + END IF + ELSE IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED',IOSTAT=IER,SHARED) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + + IF (IER.EQ.0) THEN + INQUIRE(UNIT=7,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.FOLDER_RECORD/4) THEN + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_BULLFOLDER(ASK_SIZE) + NTRIES = 0 + END IF + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.8) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=8,FILE='SYSUAF',DEFAULTFILE='SYS$SYSTEM:SYSUAF.DAT', + & ACCESS='KEYED',FORM='UNFORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,IOSTAT=IER,SHARED, + & USEROPEN=LNM_MODE_EXEC) + END DO + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.10) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=10,STATUS='OLD',IOSTAT=IER, + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=3, + & ORGANIZATION='INDEXED',KEY=(1:12:CHARACTER), + & FORM='UNFORMATTED', + & FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.NOTIFY') + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.LUN.NE.8) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + CALL OPEN_FILE(LUN) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + ELSE IF (IER.NE.0) THEN + WRITE (6,'( + & '' Cannot open file in OPEN_FILE_SHARE, unit = '',I)') LUN + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT + END IF + + LUN = 0 + + RETURN + END + + + + + + SUBROUTINE CONVERT_BULLDIRS + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER BUFFER*115 + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP', + & IOSTAT=IER) + + IF (IER.NE.0) GO TO 900 ! No BULLDIR file found. + + READ (2'1,IOSTAT=IER1) BUFFER + + CALL LIB$MOVC3(4,%REF(BUFFER(39:)),NBULL) + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+5 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END IF + + IF (IER1.NE.0) GO TO 800 + + CALL SYS_BINTIM(BUFFER(1:11)//' '//BUFFER(12:19),NEWEST_EXBTIM) + CALL SYS_BINTIM(BUFFER(20:30)//' '//BUFFER(31:38),NEWEST_MSGBTIM) + BULLDIR_HEADER(29:40) = BUFFER(39:) + CALL SYS_BINTIM(BUFFER(51:61)//' '//BUFFER(62:69),SHUTDOWN_BTIM) + BULLDIR_HEADER(49:52) = BUFFER(70:) + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) BULLDIR_HEADER + + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ (2'ICOUNT,IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + MSG_NUM = ICOUNT - 1 + DESCRIP = BUFFER(1:) + FROM = BUFFER(54:) + BULLDIR_ENTRY(78:81) = BUFFER(85:) + BULLDIR_ENTRY(90:97) = BUFFER(108:) + CALL SYS_BINTIM(BUFFER(89:99)//' '//BUFFER(100:107),EX_BTIM) + CALL SYS_BINTIM(BUFFER(66:76)//' '//BUFFER(77:84),MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (9,IOSTAT=IER) BULLDIR_ENTRY + ICOUNT = ICOUNT + 1 + END IF + END DO + +800 CLOSE (UNIT=9,DISPOSE='KEEP') + CLOSE (UNIT=2) + +900 CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFILES +C +C SUBROUTINE CONVERT_BULLFILES +C +C FUNCTION: Converts bulletin files to new format file. +C Add expiration time to directory file, add extra byte to bulletin +C file to show where each bulletin starts (for redunancy sake in +C case crash occurs). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*81 BUFFER + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=107,ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP',FORM='FORMATTED', + & SHARED,READONLY,IOSTAT=IER) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=10,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=80, + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=81, + & FORM='FORMATTED') + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + NEWEST_EXTIME = '00:00:00.00' + READ (9'1,1000,IOSTAT=IER) + & NEWEST_EXDATE,NEWEST_DATE,NEWEST_TIME(:8), + & NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_DATE,SHUTDOWN_TIME(:8) + NEMPTY = 0 + IF (IER.EQ.0) CALL WRITEDIR(0,IER1) + + EXTIME = '00:00:00.00' + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ(9'ICOUNT,1010,IOSTAT=IER) + & DESCRIP,FROM,DATE,TIME(:8),LENGTH,EXDATE,SYSTEM,BLOCK + IF (IER.EQ.0) THEN + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER(1:80)//CHAR(1) + DO I=2,LENGTH + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER + END DO + CALL WRITEDIR(ICOUNT-1,IER1) + ICOUNT = ICOUNT + 1 + END IF + END DO + + CLOSE (UNIT=9) + CLOSE (UNIT=2) + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + RETURN + +1000 FORMAT(A11,A11,A8,A4,A4,A4,A11,A8) +1010 FORMAT(A53,A12,A11,A8,A4,A11,A4,A4) + + END + + SUBROUTINE CONVERT_BULLFILE +C +C SUBROUTINE CONVERT_BULLFILE +C +C FUNCTION: Converts bulletin data file to new format file. +C +C NOTE: CONVERT_BULLFILES converts from 80 to 81 byte length. +C This converts from 81 byte length to 128 compressed format. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*80 BUFFER,NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL CLOSE_BULLDIR + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + CALL OPEN_BULLFOLDER + +100 READ (7,FMT=FOLDER_FMT,ERR=200) + & FOLDER,FOLDER_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + NEW_FILE = FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFILOLD' + OPEN (UNIT=10,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL' + & ,STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=81,ACCESS='DIRECT', + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.BULLFIL;-1',NEW_FILE) + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + IF (IER.EQ.1) THEN + NBLOCK = 0 + DO I=1,NBULL + CALL READDIR(I,IER) + NBLOCK = NBLOCK + 1 + SBLOCK = NBLOCK + DO J=BLOCK,LENGTH+BLOCK-1 + READ(10'J,'(A)') BUFFER + ILEN = TRIM(BUFFER) + IF (ILEN.EQ.0) ILEN = 1 + CALL STORE_BULL(ILEN,BUFFER,NBLOCK) + END DO + CALL FLUSH_BULL(NBLOCK) + LENGTH = NBLOCK - SBLOCK + 1 + BLOCK = SBLOCK + CALL WRITEDIR(I,IER) + END DO + + NEMPTY = 0 + CALL WRITEDIR(0,IER) + END IF + + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL CLOSE_BULLDIR + GOTO 100 + +200 CALL OPEN_BULLDIR_SHARED + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFOLDER(ASK_SIZE) +C +C SUBROUTINE CONVERT_BULLFOLDER +C +C FUNCTION: Converts bulletin folder file to new format. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + CHARACTER*80 NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + + EODIR = MAX(INDEX(BULLFOLDER_FILE,':'),INDEX(BULLFOLDER_FILE,']')) + SUFFIX = INDEX(BULLFOLDER_FILE(EODIR:),'.') + EODIR - 1 + NEW_FILE = BULLFOLDER_FILE(:SUFFIX)//'OLD' + IER = LIB$RENAME_FILE(BULLFOLDER_FILE,NEW_FILE) + + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=NEW_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + END DO + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=9,FILE=BULLFOLDER_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER),DISPOSE='DELETE') + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + IF (ASK_SIZE.EQ.173/4) THEN + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8,5A4)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + IF (IER.EQ.0) THEN + WRITE (9,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + & ,F_NEWEST_BTIM + F_NUMBER = F_NUMBER + 1 + END IF + END DO + ELSE + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + IF (IER.EQ.0) THEN + FOLDER_FLAG = 0 + IF (F_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) + IF (NEWEST_DATE.EQ.'5-NOV-1956 ') THEN + IF (NBULL.GT.0) THEN + CALL READDIR(NBULL,IER) + NEWEST_DATE = DATE + NEWEST_TIME = TIME + CALL WRITEDIR(0,IER) + END IF + END IF + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + WRITE (9,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,FOLDER_FLAG,0,F_NEWEST_BTIM + CALL CLOSE_BULLDIR + F_NUMBER = F_NUMBER + 1 + END IF + END DO + END IF + + CLOSE (UNIT=7) + CLOSE (UNIT=9,STATUS='SAVE') + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:TRIM(BBOARD_DIRECTORY)) + & //'BOARD.COM;*') ! BULLETIN$ is referenced in old file + + RETURN + END + + SUBROUTINE CONVERT_USERFILE +C +C SUBROUTINE CONVERT_USERFILE +C +C FUNCTION: Converts user file to new format which has 8 bytes added. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER BUFFER*74,NEW_FILE*80 + + CHARACTER*11 LOGIN_DATE,READ_DATE + CHARACTER*8 LOGIN_TIME,READ_TIME + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + EODIR = MAX(INDEX(BULLUSER_FILE,':'),INDEX(BULLUSER_FILE,']')) + SUFFIX = INDEX(BULLUSER_FILE(EODIR:),'.') + EODIR - 1 + NEW_FILE = BULLUSER_FILE(:SUFFIX)//'OLD' + IER = LIB$RENAME_FILE(BULLUSER_FILE,NEW_FILE) + + OPEN (UNIT=9,FILE=NEW_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + INQUIRE (UNIT=9,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IER = LIB$RENAME_FILE(NEW_FILE,BULLUSER_FILE) + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + IF (IER.EQ.0) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot convert user file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + CALL SYS_GETMSG(IER1) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + CALL ENABLE_CTRL_EXIT + END IF + + DO I=1,FLONG + NEW_FLAG(I) = 'FFFFFFFF'X + NOTIFY_FLAG(I) = 0 + BRIEF_FLAG(I) = 0 + SET_FLAG(I) = 0 + END DO + + IF (RECL.EQ.42.OR.RECL.EQ.50.OR.RECL.EQ.58.OR.RECL.EQ.66.OR. + & RECL.EQ.74) THEN ! Old format + IF (RECL.LE.58) RECL = 50 + IER = 0 + DO WHILE (IER.EQ.0) + READ (9,'(A)',IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + TEMP_USER = BUFFER(1:12) + LOGIN_DATE = BUFFER(13:23) + LOGIN_TIME = BUFFER(24:31) + READ_DATE = BUFFER(32:42) + READ_TIME = BUFFER(43:50) + IF (RECL.EQ.58) + & CALL LIB$MOVC3(8,%REF(BUFFER(51:)),SET_FLAG(1)) + IF (RECL.EQ.66) + & CALL LIB$MOVC3(8,%REF(BUFFER(59:)),NEW_FLAG(1)) + IF (RECL.EQ.74) + & CALL LIB$MOVC3(8,%REF(BUFFER(67:)),NOTIFY_FLAG(1)) + CALL SYS_BINTIM(LOGIN_DATE//' '//LOGIN_TIME,LOGIN_BTIM) + CALL SYS_BINTIM(READ_DATE//' '//READ_TIME,READ_BTIM) + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + IF (RECL.LT.66) THEN + READ (4,KEY=USER_HEADER_KEY,FMT=USER_FMT) TEMP_USER, + & LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + NEW_FLAG(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + ELSE ! Folder maxmimum increase + OFLONG = (RECL - 28) / 16 ! Old #longwords/flag + DO WHILE (IER.EQ.0) + READ (9,FMT='(A12,<4+OFLONG*4>A4)',IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM, + & (NEW_FLAG(I),I=1,OFLONG),(SET_FLAG(I),I=1,OFLONG), + & (BRIEF_FLAG(I),I=1,OFLONG),(NOTIFY_FLAG(I),I=1,OFLONG) + IF (IER.EQ.0) THEN + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + END IF + + IER = 0 + + CLOSE (UNIT=9) + CLOSE (UNIT=4) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + END + + + SUBROUTINE READDIR(BULLETIN_NUM,ICOUNT) +C +C SUBROUTINE READDIR +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file and returns the information for that entry. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, gives header info, i.e number of bulls, +C number of blocks in bulletin file, etc. +C OUTPUTS: +C ICOUNT - The last record read by this routine. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + CHARACTER*3 CFOLDER_NUMBER + + ICOUNT = BULLETIN_NUM + + IF (ICOUNT.EQ.0) THEN + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=0,IOSTAT=IER) BULLDIR_HEADER + END DO + IF (IER.EQ.0) THEN + CALL CONVERT_HEADER_FROMBIN + DIR_NUM = 0 + END IF + ELSE + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 8,0 + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_HEADER + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + CALL CONVERT_HEADER_FROMBIN + RETURN + END IF + END IF + IF (IER.EQ.0) THEN + IF (NBULL.LT.0) THEN ! This indicates bulletin deletion + ! was incomplete. + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR + CALL CLEANUP_DIRFILE(1) + CALL UPDATE_FOLDER + END IF + IF (NEMPTY.EQ.' ') NEMPTY = 0 +C +C Check to see if cleanup of empty file space is necessary, which is +C defined here as being 50 blocks (200 128byte records). Also check +C to see if cleanup was in progress but didn't properly finish. +C + IF (NEMPTY.GT.200.AND.TEST_BULLCP().EQ.0) THEN + WRITE (CFOLDER_NUMBER,'(I3)') FOLDER_NUMBER + IER1 = LIB$SPAWN('$'//COMMAND_PROMPT(1:INDEX( + & COMMAND_PROMPT,'>')-1)//'/CLEANUP='//CFOLDER_NUMBER, + & 'NL:','NL:',1,'BULL_CLEANUP') + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLEANUP_BULLFILE + END IF + END IF + ELSE + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + IF (DIR_NUM.EQ.ICOUNT-1) THEN + READ(2,IOSTAT=IER) BULLDIR_ENTRY + IF (MSG_NUM.NE.ICOUNT) IER = 36 + ELSE + READ(2,KEYID=0,KEY=ICOUNT,IOSTAT=IER) BULLDIR_ENTRY + END IF + END DO + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + DIR_NUM = -1 + END IF + ELSE + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 8,ICOUNT + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_ENTRY + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + CALL CONVERT_ENTRY_FROMBIN + RETURN + END IF + END IF + END IF + + IF (IER.EQ.0) ICOUNT = ICOUNT + 1 + + UNLOCK 2 + + RETURN + + END + + + + + + SUBROUTINE READDIR_KEYGE(IER) +C +C SUBROUTINE READDIR_KEYGE +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file corresponding to or later than the date specified. +C +C INPUTS: +C MSG_KEY - Message key (passed via BULLDIR.INC common block). +C OUTPUTS: +C IER - If not 0, no entry found. Else contains message number. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ(2,KEYID=1,KEYGT=MSG_KEY,IOSTAT=IER) BULLDIR_ENTRY + END DO + IF (IER.EQ.0) THEN + IER = MSG_NUM + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + IER = 0 + DIR_NUM = -1 + END IF + UNLOCK 2 + ELSE + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 8,-1,MSG_KEY + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_ENTRY + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + IER = MSG_NUM + CALL CONVERT_ENTRY_FROMBIN + END IF + END IF + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,NEWEST_EXBTIM,) + + NEWEST_EXDATE = DATETIME + NEWEST_EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,NEWEST_MSGBTIM,) + + NEWEST_DATE = DATETIME + NEWEST_TIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,SHUTDOWN_BTIM,) + + SHUTDOWN_DATE = DATETIME + SHUTDOWN_TIME = DATETIME(13:) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,EX_BTIM,) + + EXDATE = DATETIME + EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,MSG_BTIM,) + + DATE = DATETIME + TIME = DATETIME(13:) + + RETURN + END + + + + + + SUBROUTINE WRITEDIR(BULLETIN_NUM,IER) +C +C SUBROUTINE WRITEDIR +C +C FUNCTION: Writes the entry for the specified bulletin in the +C directory file. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, write the header of the directory file. +C OUTPUTS: +C IER - Error status from WRITE. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + INCLUDE 'BULLDIR.INC' + + CONV = .TRUE. + + GO TO 10 + + ENTRY WRITEDIR_NOCONV(BULLETIN_NUM,IER) + + CONV = .FALSE. + +10 IF (BULLETIN_NUM.EQ.0) THEN + IF (CONV) CALL CONVERT_HEADER_TOBIN + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,0,BULLDIR_HEADER + ELSE + IER = -1 + IF (DIR_NUM.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=0,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + IF (IER.NE.0) THEN + WRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + ELSE + IF (CONV) CALL CONVERT_ENTRY_TOBIN + MSG_NUM = BULLETIN_NUM + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,BULLETIN_NUM,BULLDIR_ENTRY + ELSE + IER = -1 + IF (DIR_NUM.EQ.MSG_NUM) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=BULLETIN_NUM,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + ELSE + WRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + END IF + END IF + END IF + + IF (REMOTE_SET.AND.IER.GT.0) CALL ERROR_AND_EXIT + + DIR_NUM = -1 + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(NEWEST_EXDATE//' '//NEWEST_EXTIME,NEWEST_EXBTIM) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_MSGBTIM) + + CALL SYS_BINTIM(SHUTDOWN_DATE//' '//SHUTDOWN_TIME,SHUTDOWN_BTIM) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(EXDATE//' '//EXTIME,EX_BTIM) + + CALL SYS_BINTIM(DATE//' '//TIME,MSG_BTIM) + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + + RETURN + END + + + + + SUBROUTINE READACL(FILENAME,ACLENT,ACLLENGTH) +C +C SUBROUTINE READACL +C +C FUNCTION: Reads the ACL of a file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C ACLENT - String which will be large enough to hold ACL information. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*(*),OUTPUT*80,ACLSTR*255,FILENAME*(*) + CHARACTER NOT_ID*3 + DATA NOT_ID /'=[,'/ + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + DO ACC_TYPE=1,2 + POINT = 1 + OUTLEN = 0 + DO WHILE ((POINT.LT.ACLLENGTH).AND.IER) + IER = SYS$FORMAT_ACL(ACLENT(POINT:POINT-1+ + & ICHAR(ACLENT(POINT:POINT))),ACLLEN,ACLSTR,,,,) + AC = INDEX(ACLSTR,',ACCESS') + IF ((ACC_TYPE.EQ.1.AND.INDEX(ACLSTR(AC:),'WRITE').GT.0).OR. + & (ACC_TYPE.EQ.2.AND.INDEX(ACLSTR(AC:),'READ').GT.0)) THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,',ACCESS') - 1 + IF (ACLSTR(END_ID:END_ID).EQ.']') THEN + START_ID = END_ID - 1 + DO WHILE + & (INDEX(NOT_ID,ACLSTR(START_ID:START_ID)).EQ.0) + START_ID = START_ID - 1 + END DO + START_ID = START_ID + 1 + END_ID = END_ID - 1 + IF (ACLSTR(START_ID:START_ID).EQ.'*') THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,'ACCESS') - 2 + END IF + END IF + IF (OUTLEN.EQ.0) THEN + IF (FILENAME.NE.BULLUSER_FILE) THEN + IF (ACC_TYPE.EQ.1) THEN + WRITE (6,'( + & '' These users can read and write to this folder:'')') + ELSE + WRITE (6,'( + & '' These users can only read this folder:'')') + END IF + ELSE + WRITE (6,'('' The following are rights identifiers'', + & '' which will give privileges.'')') + END IF + OUTLEN = 1 + END IF + IDLEN = END_ID - START_ID + 1 + IF (OUTLEN+IDLEN-1.GT.80) THEN + WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-1) + OUTPUT = ACLSTR(START_ID:END_ID)//',' + OUTLEN = IDLEN + 2 + ELSE IF (OUTLEN+IDLEN-1.EQ.80) THEN + WRITE (6,'(1X,A)') + & OUTPUT(:OUTLEN-1)//ACLSTR(START_ID:END_ID) + OUTLEN = 1 + ELSE + OUTPUT(OUTLEN:) = ACLSTR(START_ID:END_ID)//',' + OUTLEN = OUTLEN + IDLEN + 1 + END IF + END IF + POINT = POINT + ICHAR(ACLENT(POINT:POINT)) + END DO + IF (OUTLEN.GT.1) WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-2) + END DO + + RETURN + END + + + + + SUBROUTINE CONVERT_INFFILE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + OPEN (UNIT=10,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + INQUIRE (UNIT=10,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + RECL = RECL/8 + + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + DO WHILE (IER.EQ.0) + READ (10,IOSTAT=IER) TEMP_USER,((LAST_READ_BTIM(J,I),J=1,2),I=1,RECL) + IF (IER.EQ.0) WRITE (9) TEMP_USER, + & ((LAST_READ_BTIM(J,I),J=1,2),I=1,FOLDER_MAX) + END DO + + CLOSE (UNIT=10,STATUS='DELETE') + + CLOSE (UNIT=9) + + RETURN + END + + + SUBROUTINE ERROR_AND_EXIT + + IMPLICIT INTEGER (A-Z) + + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + CALL ENABLE_CTRL_EXIT + + RETURN + END + diff --git a/decus/vax89a2/nieland/bulletin/bulletin7.for b/decus/vax89a2/nieland/bulletin/bulletin7.for new file mode 100644 index 0000000..26b81bd --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin7.for @@ -0,0 +1,1750 @@ +C +C BULLETIN7.FOR, Version 4/16/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE UPDATE_LOGIN(ADD_BULL) +C +C SUBROUTINE UPDATE_LOGIN +C +C FUNCTION: Updates the login file when a bulletin has been deleted +C or added. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($BRKDEF)' + + INCLUDE '($SSDEF)' + + DIMENSION READ_BTIM_SAVE(2),TEMP_BTIM(2) + + CHARACTER OUTPUT*160,TERMINAL*7,FLAGS*1 + CHARACTER*1 CR/13/,LF/10/,BELL/7/ + +C +C We want to keep the last read date for comparison when selecting new +C folders, so save it for later restoring. +C + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL OPEN_BULLUSER_SHARED + +C +C Newest date/time in user file only applies to general bulletins. +C This was present before adding folder capability. +C We set flags in user entry to show new folder added for folder bulletins. +C However, the newest bulletin for each folder is not continually updated, +C As it is only used when comparing to the last bulletin read time, and to +C store this for each folder would be too expensive. +C + + TEMP_BTIM(1) = NEWEST_BTIM(1) + TEMP_BTIM(2) = NEWEST_BTIM(2) + CALL READ_USER_FILE_HEADER(IER) + NEWEST_BTIM(1) = TEMP_BTIM(1) + NEWEST_BTIM(2) = TEMP_BTIM(2) + + IF (IER.NE.0) THEN + CALL CLOSE_BULLUSER + RETURN + ELSE IF (FOLDER_NUMBER.EQ.0) THEN + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_BTIM) + REWRITE (4,IOSTAT=IER) USER_HEADER + END IF + + IF (ADD_BULL.AND.FOLDER_NUMBER.GE.0) THEN ! Message added? + IF (FOLDER_NUMBER.GT.0) THEN ! Folder private? + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CHECK_ACL = 0 + ELSE + CHECK_ACL = 1 + END IF + ELSE + CHECK_ACL = 0 + END IF + + OUTPUT = BELL//CR//LF//LF// + & 'New bulletin added to folder '//FOLDER(1:TRIM(FOLDER)) + & //'. From: '//FROM(1:TRIM(FROM))//CR//LF// + & 'Description: '//DESCRIP(1:TRIM(DESCRIP)) + + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',FLAGS) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',FLAGS) + END IF + + FLAG = 0 + BFLAG = 0 + + IF (IER) THEN + READ (FLAGS(:1),'(I1)',IOSTAT=IER) FLAG + IF (BTEST(FLAG,1).AND.IER.EQ.0) THEN ! Node part of cluster? + CALL OPEN_BULLNOTIFY_SHARED ! Yes, get notify list. + DO WHILE (REC_LOCK(IER1)) ! Any entries? + READ (10,IOSTAT=IER1) TEMP_USER + END DO + IF (IER1.NE.0) THEN ! No entries. + CALL READ_USER_FILE(IER) ! Create entries from + DO WHILE (IER.EQ.0) ! user file. + IF (TEMP_USER(:1).NE.':'.AND.TEMP_USER(:1).NE.'*' + & .AND.TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (10) TEMP_USER + END IF + CALL READ_USER_FILE(IER) + END DO + DO WHILE (REC_LOCK(IER1)) ! Reset to first entry. + READ (10,KEYGT=' ',IOSTAT=IER1) + & TEMP_USER + END DO + END IF + + BFLAG = BRK$M_CLUSTER ! Broadcast to all nodes + + IF (TEST2(NOTIFY_FLAG_DEF,FOLDER_NUMBER).AND. ! If /ALL then + & TEMP_USER.EQ.'*'.AND.IER1.EQ.0) THEN ! notify all. + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & ,%VAL(BRK$C_ALLUSERS),,,%VAL(BFLAG),,,,) + IER1 = 1 ! Don't have to loop through notify list + END IF + END IF + END IF + + DO WHILE ((BFLAG.EQ.0.AND.GETUSERS(TEMP_USER,TERMINAL)).OR. + & (BFLAG.NE.0.AND.IER1.EQ.0)) + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + IF (IER.EQ.0.AND.TEMP_USER.NE.FROM.AND. + & TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + IF (CHECK_ACL) THEN + CALL CHECK_ACCESS + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL', + & TEMP_USER,IER,WRITE_ACCESS) + ELSE + IER = 1 + END IF + IF (IER) THEN + IF (BFLAG.EQ.0) THEN + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & TERMINAL(:TRIM(TERMINAL)),%VAL(BRK$C_DEVICE) + & ,,,%VAL(BFLAG),,,,) + ELSE + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & TEMP_USER(:TRIM(TEMP_USER)),%VAL(BRK$C_USERNAME) + & ,,,%VAL(BFLAG),,,,) + END IF + ELSE + CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + REWRITE (4,IOSTAT=IER) TEMP_USER//USER_ENTRY(13:) + END IF + ELSE IF (IER.NE.0.AND.BFLAG.NE.0) THEN + DELETE (UNIT=10) + END IF + IF (BFLAG.NE.0) THEN + DO WHILE (REC_LOCK(IER1)) + READ (10,IOSTAT=IER1) TEMP_USER + END DO + END IF + END DO + IF (BFLAG.NE.0) CALL CLOSE_BULLNOTIFY + END IF + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + ! Reobtain present values as calling programs still uses them + + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + + CALL CLOSE_BULLUSER + + RETURN + + END + + + + + + SUBROUTINE ADD_ENTRY +C +C SUBROUTINE ADD_ENTRY +C +C FUNCTION: Enters a new directory entry in the directory file. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY_TIME*32 + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + IF (REMOTE_SET) THEN + LOCAL = .TRUE. + IF (INCMD(:3).EQ.'ADD') LOCAL = CLI$PRESENT('LOCAL') + IF (LOCAL) THEN + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,0,0,0,0 + ELSE + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,CLI$PRESENT('BROADCAST'), + & CLI$PRESENT('BELL'),CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER') + END IF + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,TODAY_TIME,F1_NEWEST_BTIM,) + NEWEST_DATE = TODAY_TIME(1:11) + NEWEST_TIME = TODAY_TIME(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + CALL UPDATE_LOGIN(.TRUE.) + RETURN + END IF + + CALL SYS$ASCTIM(,TODAY_TIME,,) + DATE = TODAY_TIME(1:11) + TIME = TODAY_TIME(13:) + + CALL READDIR(0,IER) + + IF (IER.NE.1) THEN + NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = '00:00:00.00' + NBULL = 0 + NBLOCK = 0 + SHUTDOWN = 0 + NEMPTY = 0 + END IF + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + NBULL = NBULL + 1 + BLOCK = NBLOCK + 1 + NBLOCK = NBLOCK + LENGTH + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + CALL UPDATE_LOGIN(.TRUE.) + + CALL WRITEDIR(NBULL,IER) + + CALL WRITEDIR(0,IER) + + RETURN + END + + + + + INTEGER FUNCTION COMPARE_BTIM(BTIM1,BTIM2) +C +C FUNCTION COMPARE_BTIM +C +C FUCTION: Compares times in binary format to see which is farther in future. +C +C INPUTS: +C BTIM1 - First time in binary format +C BTIM2 - Second time in binary format +C OUTPUT: +C Returns +1 if first time is farther in future +C Returns -1 if second time is farther in future +C Returns 0 if equal time +C + IMPLICIT INTEGER (A - Z) + + DIMENSION BTIM1(2),BTIM2(2),DIFF(2) + + CALL LIB$SUBX(BTIM1,BTIM2,DIFF) + + IF (DIFF(2).LT.0) THEN + COMPARE_BTIM = -1 + ELSE IF (DIFF(2).GE.0) THEN + COMPARE_BTIM = +1 + END IF + + RETURN + END + + + + + + INTEGER FUNCTION MINUTE_DIFF(DATE2,DATE1) +C +C FUNCTION MINUTE_DIFF +C +C FUNCTION: Finds difference in minutes between 2 binary times. +C +C + IMPLICIT INTEGER (A-Z) + + DIMENSION DATE1(2),DATE2(2) + + CALL LIB$DAY(DAYS1,DATE1,MSECS1) + CALL LIB$DAY(DAYS2,DATE2,MSECS2) + + MINUTE_DIFF = (DAYS2-DAYS1)*3600 + (MSECS2-MSECS1)/6000 + + RETURN + END + + + + + + + INTEGER FUNCTION COMPARE_DATE(DATE1,DATE2) +C +C FUNCTION COMPARE_DATE +C +C FUCTION: Compares dates to see which is farther in future. +C +C INPUTS: +C DATE1 - First date (dd-mm-yy) +C DATE2 - Second date (If is equal to ' ', then use present date) +C OUTPUT: +C Returns the difference in days between the two dates. +C If the DATE1 is farther in the future, the output is positive, +C else it is negative. +C + IMPLICIT INTEGER (A - Z) + + CHARACTER*(*) DATE1,DATE2 + INTEGER USER_TIME(2) + + CALL SYS_BINTIM(DATE1,USER_TIME) + + CALL VERIFY_DATE(USER_TIME) +C +C LIB$DAY crashes if date invalid, which happened once due to an unknown +C hardware or software error which created a date very far in the future. +C + CALL LIB$DAY(DAY1,USER_TIME) + + IF (DATE2.NE.' ') THEN + CALL SYS_BINTIM(DATE2,USER_TIME) + CALL VERIFY_DATE(USER_TIME) + ELSE + CALL SYS$GETTIM(USER_TIME) + END IF + + CALL LIB$DAY(DAY2,USER_TIME) + + COMPARE_DATE = DAY1 - DAY2 + + RETURN + END + + + + SUBROUTINE VERIFY_DATE(BTIM) + + IMPLICIT INTEGER (A-Z) + + DIMENSION BTIM(2),TEMP(2) + + CALL SYS_BINTIM(' 5-NOV-2011 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.GT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + CALL SYS_BINTIM(' 5-NOV-1955 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.LT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + RETURN + END + + + + INTEGER FUNCTION COMPARE_TIME(TIME1,TIME2) +C +C FUNCTION COMPARE_TIME +C +C FUCTION: Compares times to see which is farther in future. +C +C INPUTS: +C TIME1 - First time (hh:mm:ss.xx) +C TIME2 - Second time +C OUTPUT: +C Outputs (TIME1-TIME2) in seconds. Thus, if TIME1 is further +C in the future, outputs positive number, else negative. +C + + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) TIME1,TIME2 + CHARACTER*23 TODAY_TIME + CHARACTER*11 TEMP2 + + IF (TIME2.EQ.' ') THEN + CALL SYS$ASCTIM(,TODAY_TIME,,) + TEMP2 = TODAY_TIME(13:) + ELSE + TEMP2 = TIME2 + END IF + + COMPARE_TIME = 3600*10*(ICHAR(TIME1(1:1))-ICHAR(TEMP2(1:1))) + & +3600*(ICHAR(TIME1(2:2))-ICHAR(TEMP2(2:2))) + & +60*10*(ICHAR(TIME1(4:4))-ICHAR(TEMP2(4:4))) + & +60*(ICHAR(TIME1(5:5))-ICHAR(TEMP2(5:5))) + & +10*(ICHAR(TIME1(7:7))-ICHAR(TEMP2(7:7))) + & +(ICHAR(TIME1(8:8))-ICHAR(TEMP2(8:8))) + + IF (COMPARE_TIME.EQ.0) THEN + COMPARE_TIME = 10*(ICHAR(TIME1(10:10))-ICHAR(TEMP2(10:10))) + & +(ICHAR(TIME1(11:11))-ICHAR(TEMP2(11:11))) + IF (COMPARE_TIME.GT.0) THEN + COMPARE_TIME = 1 + ELSE IF (COMPARE_TIME.LT.0) THEN + COMPARE_TIME = -1 + END IF + END IF + + RETURN + END + +C------------------------------------------------------------------------- +C +C The following are subroutines to create a linked-list queue for +C temporary buffer storage of data that is read from files to be +C outputted to the terminal. This is done so as to be able to close +C the file as soon as possible. +C +C Each record in the queue has the following format. The first two +C words are used for creating a character variable. The first word +C contains the length of the character variable, the second contains +C the address. The address is simply the address of the 3rd word of +C the record. The last word in the record contains the address of the +C next record. Every time a record is written, if that record has a +C zero link, it adds a new record for the next write operation. +C Therefore, there will always be an extra record in the queue. To +C check for the end of the queue, the last word (link to next record) +C is checked to see if it is zero. +C +C------------------------------------------------------------------------- + SUBROUTINE INIT_QUEUE(HEADER,DATA) + CHARACTER*(*) DATA + INTEGER HEADER + IF (HEADER.NE.0) RETURN ! Queue already initialized + LENGTH = LEN(DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + CALL LIB$GET_VM(LENGTH+12,HEADER) + CALL MAKE_CHAR(%VAL(HEADER),LEN(DATA),LENGTH) + RETURN + END + + + SUBROUTINE WRITE_QUEUE(RECORD,NEXT,DATA) + INTEGER RECORD(1) + CHARACTER*(*) DATA + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,DATA,%VAL(%LOC(RECORD))) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + IF (NEXT.NE.0) RETURN + CALL LIB$GET_VM(LENGTH+12,NEXT) + CALL MAKE_CHAR(%VAL(NEXT),RECORD(1),LENGTH) + RECORD((LENGTH+12)/4) = NEXT + RETURN + END + + SUBROUTINE READ_QUEUE(RECORD,NEXT,DATA) + CHARACTER*(*) DATA + INTEGER RECORD(1) + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,%VAL(%LOC(RECORD)),DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + RETURN + END + + SUBROUTINE COPY_CHAR(LENGTH,INCHAR,OUTCHAR) + CHARACTER*(*) INCHAR,OUTCHAR + OUTCHAR = INCHAR(:LENGTH) + RETURN + END + + SUBROUTINE MAKE_CHAR(IARRAY,CHAR_LEN,REAL_LEN) + IMPLICIT INTEGER (A-Z) + DIMENSION IARRAY(1) + IARRAY(1) = CHAR_LEN + IARRAY(2) = %LOC(IARRAY(3)) + IARRAY(REAL_LEN/4+3) = 0 + RETURN + END + + + + SUBROUTINE DISABLE_PRIVS +C +C SUBROUTINE DISABLE_PRIVS +C +C FUNCTION: Disable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + DATA PRV_DEPTH /0/ + + COMMON /REALPROC/ REALPROCPRIV(2) + + PRV_DEPTH = PRV_DEPTH + 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(0),,,SETPRV) ! Get privileges + + SETPRV(1) = SETPRV(1).AND..NOT.REALPROCPRIV(1) + + CALL SYS$SETPRV(%VAL(0),SETPRV,,) ! Disable installed privs + + RETURN + END + + + + SUBROUTINE ENABLE_PRIVS +C +C SUBROUTINE ENABLE_PRIVS +C +C FUNCTION: Enable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + PRV_DEPTH = PRV_DEPTH - 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(1),SETPRV,,) ! Enable image privs + + RETURN + END + + + + SUBROUTINE CHECK_PRIV_IO(ERROR) +C +C SUBROUTINE CHECK_PRIV_IO +C +C FUNCTION: Checks SYS$OUTPUT and SYS$ERROR to see if they need +C privileges to output to. +C + + IMPLICIT INTEGER (A-Z) + + CALL DISABLE_PRIVS ! Disable SYSPRV + + OPEN (UNIT=6,FILE='SYS$OUTPUT',IOSTAT=IER,STATUS='NEW') + CLOSE (UNIT=6,STATUS='DELETE') + + OPEN (UNIT=4,FILE='SYS$ERROR',IOSTAT=IER1,STATUS='NEW') + IF (IER.NE.0.OR.IER1.NE.0) THEN + IF (IER1.EQ.0) WRITE (4,100) + IF (IER.EQ.0) WRITE (6,200) + ERROR = 1 + ELSE + CLOSE (UNIT=4,STATUS='DELETE') + ERROR = 0 + END IF + + CALL ENABLE_PRIVS ! Enable SYSPRV + +100 FORMAT(1X,'ERROR: SYS$OUTPUT cannot be opened.') +200 FORMAT(1X,'ERROR: SYS$ERROR cannot be opened.') + + RETURN + END + + + SUBROUTINE CHANGE_FLAG(CMD,FLAG) +C +C SUBROUTINE CHANGE_FLAG +C +C FUNCTION: Sets flags for specified folder. +C +C INPUTS: +C CMD - LOGICAL*4 value. If TRUE, set flag. +C If FALSE, clear flag. +C FLAG - If 1, modify NEW_FLAG, if 2, modify SET_FLAG +C If 3, modify BRIEF_FLAG, 4, modify NOTIFY_FLAG +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + + DATA CHANGE_FOLDER /.FALSE./ + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) + IF (IER) THEN + FOLDER_NUMBER_SAVE = FOLDER_NUMBER + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + CALL CLOSE_BULLFOLDER + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder found.'')') + RETURN + END IF + END IF + FOLDER_NUMBER = FOLDER1_NUMBER + CHANGE_FOLDER = .TRUE. + END IF + +C +C Find user entry in BULLUSER.DAT to update information. +C + + ENTRY CHANGE_FLAG_NOCMD(CMD,FLAG) + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.GT.0) THEN ! No entry (how did this happen??) + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's today + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) ! Fake new entry + CALL READ_USER_FILE_HEADER(IER) + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + ELSE + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + CALL CLOSE_FILE (4) + + IF (FLAG.EQ.4) THEN ! If notify, see if cluster + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',TEMP_USER) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',TEMP_USER) + END IF + READ (TEMP_USER(:1),'(I1)',IOSTAT=IER) BFLAG + IF (BTEST(BFLAG,1).AND.IER.EQ.0) THEN + CALL OPEN_BULLNOTIFY_SHARED + DO WHILE (REC_LOCK(IER)) + READ (10,IOSTAT=IER) TEMP_USER + END DO + IF (TEMP_USER.NE.'*') THEN + IF (CMD) THEN + WRITE (10,IOSTAT=IER) USERNAME + ELSE + DO WHILE (REC_LOCK(IER)) + READ (10,KEY=USERNAME,IOSTAT=IER) + END DO + IF (IER.EQ.0) DELETE (UNIT=10) + END IF + END IF + CALL CLOSE_BULLNOTIFY + END IF + END IF + + IF (CHANGE_FOLDER) THEN + FOLDER_NUMBER = FOLDER_NUMBER_SAVE + CHANGE_FOLDER = .FALSE. + END IF + + RETURN + + END + + + + + SUBROUTINE SET_VERSION +C +C SUBROUTINE SET_VERSION +C +C FUNCTION: Sets version number. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + +C +C Find user entry in BULLUSER.DAT to update information. +C + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.EQ.0) THEN + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY ! Write modified entry + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + CALL CLOSE_FILE (4) + RETURN + + END + + + + + + SUBROUTINE CONFIRM_PRIV(USERNAME,ALLOW) +C +C SUBROUTINE CONFIRM_PRIV +C +C FUNCTION: Confirms that given username has SETPRV. +C +C INPUTS: +C USERNAME - Username +C OUTPUTS: +C ALLOW - Returns 1 if account has SETPRV. +C returns 0 if account has no SETPRV. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + INCLUDE '($PRVDEF)' + + INCLUDE '($UAIDEF)' + + INTEGER DEF_PRIV(2) + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(8,UAI$_DEF_PRIV,%LOC(DEF_PRIV)) + CALL END_ITMLST(GETUAI_ITMLST) + + ALLOW = 0 ! Set return false + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) ! Read Record + IF (IER) THEN ! If username found + IF (BTEST(DEF_PRIV(1),PRV$V_SETPRV).OR. ! SETPRV or CMRKNL + & BTEST(DEF_PRIV(1),PRV$V_CMKRNL)) THEN ! privileges? + ALLOW = 1 ! Yep + END IF + END IF + + RETURN ! Return + END ! End + + + + + + SUBROUTINE CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) +C +C SUBROUTINE CHECK_NEWUSER +C +C FUNCTION: Checks flags for a new: Whether DISMAIL is set, +C and what the last password change was. +C +C INPUTS: +C USERNAME - Username +C OUTPUTS: +C DISMAIL - Returns 1 if account has DISMAIL. +C returns 0 if account has no DISMAIL. +C PASSCHANGE - Date of last password change. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + INTEGER PASSCHANGE(2) + + INCLUDE '($UAIDEF)' + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(8,UAI$_PWD_DATE,%LOC(PASSCHANGE)) + CALL END_ITMLST(GETUAI_ITMLST) + + DISMAIL = 0 ! Set return false + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) ! Read Record + IF (IER) THEN ! If username found + IF (BTEST(FLAGS,UAI$V_NOMAIL)) THEN ! DISMAIL SET? + DISMAIL = 1 ! Yep + END IF + END IF + + RETURN ! Return + END ! End + + + + INTEGER FUNCTION SYS_TRNLNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM = SYS$TRNLNM(,'LNM$FILE_DEV',INPUT(:TRIM(INPUT)),, + & %VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM) OUTPUT = OUTPUT(:OLEN) + + RETURN + END + + + + + INTEGER FUNCTION SYS_TRNLNM_SYSTEM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM_SYSTEM = SYS$TRNLNM(,'LNM$SYSTEM', + & INPUT(:TRIM(INPUT)),,%VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM_SYSTEM) OUTPUT = OUTPUT(:OLEN) + + RETURN + END + + + + INTEGER FUNCTION FILE_LOCK(IER,IER1) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($RMSDEF)' + + DATA INIT /.TRUE./ + + IF (INIT) THEN + FILE_LOCK = 1 + INIT = .FALSE. + ELSE + IF (IER.GT.0) THEN + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.RMS$_FLK) THEN + FILE_LOCK = 1 + CALL WAIT_SEC('01') + ELSE + FILE_LOCK = 0 + INIT = .TRUE. + END IF + ELSE + FILE_LOCK = 0 + IER1 = 0 + INIT = .TRUE. + END IF + END IF + + RETURN + END + + + + SUBROUTINE ENABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + QUIT = 1 + + ENTRY ENABLE_CTRL_EXIT + + QUIT = QUIT.AND.1 ! If called via entry, QUIT = 0 + IF (QUIT.EQ.1) LEVEL = LEVEL - 1 + + IF (LEVEL.LT.0.AND.QUIT.EQ.1) THEN + WRITE (6,'('' ERROR: Error in CTRL.'')') + END IF + + IF (LEVEL.EQ.0.OR.QUIT.EQ.0) THEN + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + END IF + + IF (QUIT.EQ.0) THEN + CALL UPDATE_USERINFO + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL EXIT + END IF + QUIT = 0 ! Reinitialize + + RETURN + END + + + SUBROUTINE DISABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + DATA LEVEL /0/ + + IF (LEVEL.EQ.0) CALL LIB$DISABLE_CTRL(CTRLY,) + LEVEL = LEVEL + 1 + + RETURN + END + + + + + SUBROUTINE CLEANUP_BULLFILE +C +C SUBROUTINE CLEANUP_BULLFILE +C +C FUNCTION: Searches for empty space in bulletin file and deletes it. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER FILENAME*132,BUFFER*128 + + CALL OPEN_BULLDIR_SHARED + +C +C NOTE: Can't use READDIR for reading header since it'll spawn a +C BULL/CLEANUP. (Fooey). +C + + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=HEADER_KEY,IOSTAT=IER) BULLDIR_HEADER + END DO + + IF (NEMPTY.EQ.0) THEN ! No cleanup necessary + CALL CLOSE_BULLDIR + RETURN + ELSE IF (NEMPTY.GT.0) THEN + + OPEN (UNIT=11,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + 1 STATUS='UNKNOWN',IOSTAT=IER,DISPOSE='DELETE', + 1 RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',INITIALSIZE=((NBLOCK-NEMPTY)*128)/512) + ! Compressed version is number 1 + + IF (IER.NE.0) THEN + OPEN (UNIT=11, + 1 FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + 1 STATUS='UNKNOWN',IOSTAT=IER,DISPOSE='DELETE', + 1 RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED') + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + + NBLOCK = 0 + + DO I=1,NBULL ! Copy bulletins to new file + CALL READDIR(I,IER) + ICOUNT = BLOCK + DO J=1,LENGTH + NBLOCK = NBLOCK + 1 + DO WHILE (REC_LOCK(IER1)) + READ(1'ICOUNT,IOSTAT=IER1) BUFFER + END DO + IF (IER1.NE.0) THEN ! This file is corrupt + NBLOCK = NBLOCK - 1 + NBULL = I - 1 + GO TO 100 + END IF + WRITE(11) BUFFER + ICOUNT = ICOUNT + 1 + END DO + END DO + +100 CALL CLOSE_BULLFIL + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + RETURN + END IF + + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+1 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.NE.0) THEN + CLOSE (UNIT=11) + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + + NEMPTY = 0 + WRITE (12,IOSTAT=IER) BULLDIR_HEADER ! Write directory header + + NBLOCK = 0 ! Update directory entry pointers + DO I=1,NBULL + CALL READDIR(I,IER) + BLOCK = NBLOCK + 1 + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (12,IOSTAT=IER) BULLDIR_ENTRY + NBLOCK = NBLOCK + LENGTH + END DO + + CLOSE (UNIT=12,STATUS='KEEP') + CLOSE (UNIT=11,STATUS='KEEP') + + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + + NEMPTY = -1 ! Copying done, indicate that in case of crash + WRITE (2,IOSTAT=IER) BULLDIR_HEADER ! Write new directory header + + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + + RETURN + END + + + + + SUBROUTINE CLEANUP_DIRFILE(DELETE_ENTRY) +C +C SUBROUTINE CLEANUP_DIRFILE +C +C FUNCTION: Reorder directory file after deletions. +C Is called either directly after a deletion, or is +C called if it is detected that a deletion was not fully +C completed due to the fact that the deleting process +C was abnormally terminated. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + CHARACTER*11 DATE_SAVE,EXDATE_SAVE + CHARACTER*11 TIME_SAVE,EXTIME_SAVE + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + DATE_SAVE = DATE + TIME_SAVE = TIME + EXDATE_SAVE = EXDATE + EXTIME_SAVE = EXTIME + + NBULL = -NBULL ! Negative # Bulls signals deletion in progress + MOVE_TO = 0 ! Moving directory entries starting here + MOVE_FROM = 0 ! Moving directory entries from here + I = DELETE_ENTRY ! Start search point for first deleted entries + DO WHILE (MOVE_TO.EQ.0.AND.I.LE.NBULL) + CALL READDIR(I,IER) + IF (IER.NE.I+1) THEN ! Have we found a deleted entry? + MOVE_TO = I ! If so, start moving entries to here + J=I+1 ! Search for next entry in file + DO WHILE (MOVE_FROM.EQ.0.AND.J.LE.NBULL) + CALL READDIR(J,IER) + IF (IER.EQ.J+1) MOVE_FROM = J + J = J + 1 + END DO + IF (MOVE_FROM.EQ.0) THEN ! There are no more entries + NBULL = I - 1 ! so just update number of bulletins + CALL WRITEDIR(0,IER) + RETURN + END IF + LENGTH = -LENGTH ! Indicate starting point by writing + CALL WRITEDIR(I,IER) ! next entry into deleted entry + FIRST_DELETE = I ! with negative length + MOVE_FROM = MOVE_FROM + 1 ! Set up pointers to move rest of + MOVE_TO = MOVE_TO + 1 ! the entries + ELSE IF (LENGTH.LT.0) THEN ! If negative length found, deletion + FIRST_DELETE = I ! was previously in progress + J = I ! Try to find where entry came from + CALL INIT_QUEUE(ENTRY_Q1,BULLDIR_ENTRY) + ENTRY_Q = ENTRY_Q1 + DO K=J,NBULL + CALL READDIR(K,IER) + IF (IER.EQ.K+1) THEN + CALL WRITE_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + END IF + END DO + ENTRY_QLAST = ENTRY_Q + ENTRY_Q2 = ENTRY_Q1 + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q2.NE.ENTRY_QLAST) + CALL READ_QUEUE(%VAL(ENTRY_Q2),ENTRY_Q,BULLDIR_ENTRY) + ENTRY_Q2 = ENTRY_Q + BLOCK_SAVE = BLOCK + MSG_NUM_SAVE = MSG_NUM + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q.NE.ENTRY_QLAST) + ! Search for duplicate entries + CALL READ_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + IF (BLOCK_SAVE.EQ.BLOCK) THEN + MOVE_TO = MSG_NUM_SAVE + 1 + MOVE_FROM = MSG_NUM + 1 + END IF + END DO + ! If no duplicate entry found for this + ! entry, see if one exists for any + END DO ! of the other entries + END IF + I = I + 1 + END DO + + IF (I.LE.NBULL) THEN ! Move reset of entries if necessary + IF (MOVE_FROM.GT.0) THEN + DO J=MOVE_FROM,NBULL + CALL READDIR(J,IER) + IF (IER.EQ.J+1) THEN ! Skip any other deleted entries + CALL WRITEDIR(MOVE_TO,IER) + MOVE_TO = MOVE_TO + 1 + END IF + END DO + END IF + DO J=MOVE_TO,NBULL ! Delete empty records at end of file + CALL READDIR(J,IER) + DELETE(UNIT=2,IOSTAT=IER) + END DO + NBULL = MOVE_TO - 1 ! Update # bulletin count + END IF + + CALL READDIR(FIRST_DELETE,IER) + IF (IER.EQ.FIRST_DELETE+1.AND.LENGTH.LT.0) THEN + LENGTH = -LENGTH ! Fix entry which has negative length + CALL WRITEDIR(FIRST_DELETE,IER) + END IF + + CALL WRITEDIR(0,IER) + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + DATE = DATE_SAVE + TIME = TIME_SAVE + EXDATE = EXDATE_SAVE + EXTIME = EXTIME_SAVE + + RETURN + END + + + SUBROUTINE SHOW_FLAGS +C +C SUBROUTINE SHOW_FLAGS +C +C FUNCTION: Show user flags. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + +C +C Find user entry in BULLUSER.DAT to obtain flags. +C + + CALL OPEN_BULLUSER_SHARED ! Open user file + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + WRITE (6,'('' For the selected folder '',A)') FOLDER(1:TRIM(FOLDER)) + + IF (TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' NOTIFY is set.'')') + END IF + + IF (TEST2(SET_FLAG,FOLDER_NUMBER).AND. + & (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER))) THEN + WRITE (6,'('' READNEW is set.'')') + ELSE IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' BRIEF is set.'')') + ELSE IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' SHOWNEW is set.'')') + ELSE IF (.NOT.TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' No flags are set.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(2) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBSET(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + SUBROUTINE CLR2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBCLR(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + LOGICAL FUNCTION TEST2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + TEST2 = BTEST(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + + INTEGER FUNCTION GETUSERS(USERNAME,TERMINAL) +C +C FUNCTION GETUSERS +C +C FUNCTION: +C To get names of all users that are logged in. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CHARACTER USERNAME*(*),TERMINAL*(*) + + DATA WILDCARD /-1/ + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL ADD_2_ITMLST(LEN(TERMINAL),JPI$_TERMINAL,%LOC(TERMINAL)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = 1 + TERMINAL(1:1) = CHAR(0) + DO WHILE (IER.AND.TERMINAL(1:1).EQ.CHAR(0)) + ! Get next interactive process + IER = SYS$GETJPIW(,WILDCARD,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + + IF (.NOT.IER) WILDCARD = -1 + + GETUSERS = IER + + RETURN + END + + + + + + SUBROUTINE OPEN_USERINFO +C +C SUBROUTINE OPEN_USERINFO +C +C FUNCTION: Opens the file in SYS$LOGIN which contains user information. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /USERINFO/ USERINFO_READ + DATA USERINFO_READ /.FALSE./ + + CALL OPEN_BULLINF_SHARED + + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2 ! Is this BULLCP process? + & .AND.CONFIRM_USER(USERNAME).NE.0) THEN ! Not real user? + USERNAME = 'DECNET' + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + + IF (IER.NE.0) THEN + OPEN (UNIT=10,FILE='SYS$LOGIN:BULLETIN.INF',STATUS='OLD', + & RECORDTYPE='FIXED',FORM='UNFORMATTED',IOSTAT=IER) + INQUIRE(UNIT=10,RECORDSIZE=INF_SIZE) + IF (IER.EQ.0) THEN + READ (10) + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,INF_SIZE/2) + CLOSE (UNIT=10,STATUS='DELETE') + ELSE + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Find user's info + CALL CLOSE_BULLUSER + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2) THEN ! BULLCP process? + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's date + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) + CALL READ_USER_FILE_HEADER(IER) + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + END IF + IF (IER.EQ.0) THEN + DO I=1,FOLDER_MAX + LAST_READ_BTIM(1,I) = READ_BTIM(1) + LAST_READ_BTIM(2,I) = READ_BTIM(2) + END DO + END IF + END IF + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + + CALL CLOSE_BULLINF + + USERINFO_READ = .TRUE. + + RETURN + END + + + + SUBROUTINE UPDATE_USERINFO +C +C SUBROUTINE UPDATE_USERINFO +C +C FUNCTION: Updates the latest message read times for each folder. +C + IMPLICIT INTEGER (A - Z) + + COMMON /USERINFO/ USERINFO_READ + + INCLUDE 'BULLUSER.INC' + + IF (.NOT.USERINFO_READ) RETURN + + CALL OPEN_BULLINF_SHARED + + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) REWRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + + CALL CLOSE_BULLINF + + RETURN + END + + + INTEGER FUNCTION SYS_BINTIM(TIME,BTIM) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*(*) TIME + + IF (TRIM(TIME).EQ.20) THEN + SYS_BINTIM = SYS$BINTIM(TIME//'.00',BTIM) + ELSE + SYS_BINTIM = SYS$BINTIM(TIME,BTIM) + END IF + + RETURN + END + + + + + SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C FUNCTION: +C +C Update user's last read bulletin date. If new bulletins have been +C added since the last time bulletins have been read, position bulletin +C pointer so that next bulletin read is the first new bulletin, and +C alert user. If READNEW set and no new bulletins, just exit. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /POINT/ BULL_POINT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + DIMENSION LOGIN_BTIM_SAVE(2) + + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + CALL UPDATE_READ ! Update login time + + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL SELECT_FOLDER(.TRUE.,IER) + IF (IER) RETURN + END IF + + CALL INIT_QUEUE(FOLDER_Q1,FOLDER_COM) + FOLDER_Q = FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Go find folders + + DO FOLDER_NUMBER = 0,FOLDER_MAX-1 + CALL CLR2(NEW_MSG,FOLDER_NUMBER) ! Clear new message flag + IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL SET2(NEW_MSG,FOLDER_NUMBER) + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + ELSE IF ((NEW_FLAG(1).LT.142.OR.NEW_FLAG(1).GT.143).AND. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + CALL CHANGE_FLAG_NOCMD(0,3) + CALL SET_VERSION + ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & (FOLDER_NUMBER.GT.0.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND.READIT.EQ.1)) THEN + CALL READ_FOLDER_FILE_KEYNUM(FOLDER_NUMBER,IER) +C +C Unknown problem caused system folder flag in folder file to disappear +C so this tests to see if the flag has disappeared and resets if needed. +C + IF (TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND. + & .NOT.BTEST(FOLDER_FLAG,2).AND.IER.EQ.0) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + CALL REWRITE_FOLDER_FILE + END IF + IF (IER.NE.0) THEN + CALL CHANGE_FLAG_NOCMD(0,2) + CALL CHANGE_FLAG_NOCMD(0,3) + CALL CHANGE_FLAG_NOCMD(0,4) + IF (TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + FOLDER_FLAG = 0 + CALL MODIFY_SYSTEM_LIST(0) + END IF + ELSE IF (READIT.EQ.1.AND.SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM, + & F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.READIT.EQ.1) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.DIFF.GE.0) THEN + IER = MINUTE_DIFF(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + IF (IER.LE.15) DIFF = -1 + END IF + END IF + END IF + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN ! If new unread messages + CALL SET2(NEW_MSG,FOLDER_NUMBER) ! Set new message flag + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER + + FOLDER_Q = FOLDER_Q1 + + IF (READIT.EQ.0) THEN ! If not in READNEW mode + IF (TEST2(NEW_MSG,0)) THEN + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + NEW_MESS = .FALSE. + DO FOLDER_NUMBER = 1,FOLDER_MAX-1 + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN ! Are there unread messages? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_NOSYS_BTIM) + IF (DIFF.GT.0) THEN ! Unread non-system messages? + DIFF = COMPARE_BTIM(LOGIN_BTIM,F_NEWEST_BTIM) + ! No. Unread system messages? + IF (DIFF.GT.0) THEN ! No, update last read time. + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(2) + END IF + END IF + IF (DIFF.LT.0) THEN + WRITE (6,'('' There are new messages in '', + & ''folder '',A,''.'',$)') FOLDER(1:TRIM(FOLDER)) + NEW_MESS = .TRUE. + END IF + END IF + END IF + END DO + IF (NEW_MESS) THEN + WRITE (6,'('' Type SELECT followed by foldername to'', + & '' read above messages.'')') + END IF + FOLDER_NUMBER = 0 + CALL SELECT_FOLDER(.FALSE.,IER) + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN + CALL FIND_NEWEST_BULL ! See if there are new messages + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new GENERAL messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + END IF + ELSE ! READNEW mode. + DO FOLDER_NUMBER = 0,FOLDER_MAX-1 + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + CALL SELECT_FOLDER(.FALSE.,IER) + IF (IER) THEN + IF (SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + END IF + IF (DIFF.LT.0) THEN + IF (FOLDER_NUMBER.GT.0) CALL LOGIN_FOLDER + IF (BULL_POINT.NE.-1) THEN + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + IF (FOLDER_NUMBER.GT.0) THEN + WRITE (6,'('' There are new messages in folder '', + & A,''.'')') FOLDER(1:TRIM(FOLDER)) + END IF + ELSE IF (FOLDER_NUMBER.EQ.0.OR. + & .NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + SAVE_BULL_POINT = BULL_POINT + REDO = .TRUE. + DO WHILE (REDO) + REDO = .FALSE. + CALL READNEW(REDO) + IF (REDO) CALL REDISPLAY_DIRECTORY + BULL_POINT = SAVE_BULL_POINT + END DO + END IF + END IF + END IF + END IF + END IF + END DO + CALL EXIT + END IF + + RETURN + END + + + + + SUBROUTINE DISCONNECT_REMOTE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + WRITE (6,'('' ERROR: Connection to remote folder disconnected.'')') + + FOLDER_NUMBER = -1 + FOLDER1 = 'GENERAL' + + CALL SELECT_FOLDER(.FALSE.,IER) + + WRITE (6,'('' Resetting to GENERAL folder.'')') + + RETURN + END diff --git a/decus/vax89a2/nieland/bulletin/bulletin8.for b/decus/vax89a2/nieland/bulletin/bulletin8.for new file mode 100644 index 0000000..4720507 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin8.for @@ -0,0 +1,1460 @@ +C +C BULLETIN8.FOR, Version 12/15/88 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE START_DECNET + + IMPLICIT INTEGER (A - Z) + + CHARACTER NAMEDESC*9 /'BULLETIN1'/ + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for + INTEGER*2 MBX_IOSB ! terminal QIO calls. + LOGICAL*1 MBX_BUF + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + DIMENSION NFBDESC(2) + LOGICAL*1 NFB(5) + + EXTERNAL IO$_ACPCONTROL + + PARAMETER NFB$C_DECLNAME = '15'X + + IF (CONFIRM_USER('DECNET').EQ.0) THEN + CALL SETDEFAULT('DECNET') + END IF + +C CALL SET_TIMER('02') + + IER = SYS$CREMBX(%VAL(0),MBX_CHAN,%VAL(132),%VAL(528),,, + & 'BULL_MBX') + IF (.NOT.IER) CALL EXIT(IER) + + IER = SYS$ASSIGN('_NET:',DCL_CHAN,,'BULL_MBX') ! Assign net device + IF (.NOT.IER) CALL EXIT(IER) + + NFBDESC(1) = 5 + NFBDESC(2) = %LOC(NFB) + + NFB(1) = NFB$C_DECLNAME + + IER = SYS$QIOW(,%VAL(DCL_CHAN),IO$_ACPCONTROL,,,, + & NFBDESC,NAMEDESC,,,,) + IF (.NOT.IER) CALL EXIT(IER) + + DO I=1,MAXLINK + CALL LIB$GET_EF(READ_EFS(I)) + CALL LIB$GET_EF(WRITE_EFS(I)) + END DO + + CALL READ_MBX + + RETURN + END + + + SUBROUTINE SETDEFAULT(USERNAME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LNMDEF)' + + INCLUDE '($PSLDEF)' + + INCLUDE '($UAIDEF)' + + CHARACTER DEFDIR*64,DEFDEV*16,USERNAME*(*),ACCOUNT*9 + + 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 SYS$SETDDIR(DEFDIR(2:ICHAR(DEFDIR(:1))+1),,) + + RETURN + END + + + + SUBROUTINE READ_MBX + + IMPLICIT INTEGER (A-Z) + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + 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) + + IER = SYS$QIO(%VAL(MBX_EF),%VAL(MBX_CHAN),IO$_READVBLK,MBX_IOSB, + & MBX_AST,,MBX_BUF,%VAL(132),,,,) + IF (.NOT.IER) CALL EXIT(IER) + + RETURN + + END + + + + + SUBROUTINE MBX_AST + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($MSGDEF)' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + 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*6,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 CONNECT(NODENAME,USERNAME,FROMNAME) + ELSE IF ((MBXMSG.EQ.MSG$_INTMSG.OR.MBXMSG.EQ.MSG$_REJECT.OR. + & MBXMSG.EQ.MSG$_CONFIRM).AND.MBX_IOSB(1)) THEN + CALL READ_MBX + 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 + END IF + + RETURN + END + + + + + SUBROUTINE READ_CHAN(CHAN,UNIT_INDEX) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + EXTERNAL READ_AST + + EXTERNAL IO$_READVBLK + + IER = SYS$QIO(%VAL(READ_EFS(UNIT_INDEX)),%VAL(CHAN),IO$_READVBLK, + & READ_IOSB(1,UNIT_INDEX),READ_AST, + & %VAL(UNIT_INDEX),READ_BUF(1,UNIT_INDEX),%VAL(200),,,,) + + RETURN + + END + + + + + SUBROUTINE WRITE_CHAN(NUM,OUTPUT,UNIT_INDEX,IER) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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)) + + IER = SYS$QIO(%VAL(WRITE_EFS(UNIT_INDEX)), + & %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 WRITE_AST(ASTPRM) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) + COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,FROM_SAVE*12,NODE_SAVE*12 + + CHARACTER*128 INPUT + + 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) + END IF + + RETURN + END + + + + SUBROUTINE READ_AST(ASTPRM) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) + + UNIT_INDEX = %LOC(ASTPRM) + + IF (.NOT.READ_IOSB(1,UNIT_INDEX)) RETURN + + IO(UNIT_INDEX) = IO(UNIT_INDEX) + 1 + + CALL EXECUTE_COMMAND(UNIT_INDEX) + + CALL READ_CHAN(DEVS(UNIT_INDEX),UNIT_INDEX) + + RETURN + END + + + + + + SUBROUTINE CONNECT(NODENAME,USERNAME,FROMNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /ANY_ACTIVITY/ CONNECT_COUNT + DATA CONNECT_COUNT /0/ + + CHARACTER*(*) USERNAME,FROMNAME + + EXTERNAL IO$_ACCESS,IO$M_ABORT + + CONNECT_COUNT = CONNECT_COUNT + 1 + + IO_REJECT = %LOC(IO$_ACCESS)+%LOC(IO$M_ABORT) + + CALL CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, + & NODENAME,USERNAME,FROMNAME) + + IF (REJECT.NE.IO_REJECT) THEN + CALL READ_CHAN(CHAN,UNIT_INDEX) + END IF + + CALL READ_MBX + + RETURN + END + + + SUBROUTINE CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, + & NODENAME,USERNAME,FROMNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for + INTEGER*2 MBX_IOSB ! terminal QIO calls. + LOGICAL*1 MBX_BUF + + PARAMETER MAXLINK = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,FROM_SAVE*12,NODE_SAVE*12 + + 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 + ELSE + IER = SYS$ASSIGN('_NET:',DEV_CHAN,,'BULL_MBX') + + 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).GT.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 + 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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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 + + IF (UNITS(UNIT_INDEX).EQ.0) RETURN + + CALL SYS$DASSGN(%VAL(DEVS(UNIT_INDEX))) + + CALL UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + COUNT = COUNT - 1 + DEVS(UNIT_INDEX) = 0 + UNITS(UNIT_INDEX) = 0 + + 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 TIMBUF*13,MIN*2 + DATA TIMBUF/'0 00:00:00.00'/ + + EXTERNAL CHECK_CONNECTIONS + + CALL LIB$GET_EF(WAITEFN) + + TIMBUF(6:7) = MIN + + IER=SYS$BINTIM(TIMBUF,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 = 10 + + COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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) + + 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 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,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 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + DIMENSION SCRATCH(MAXLINK),OUT_HEAD(MAXLINK) + DATA SCRATCH/MAXLINK*0/,OUT_HEAD/MAXLINK*0/ + + EXTERNAL ENABLE_CTRL_EXIT,SS$_NOSUCHNODE,SS$_NOSUCHOBJ + + PARAMETER TIMEOUT = -10*1000*1000*30 + DIMENSION TIMEBUF(2) + DATA TIMEBUF /TIMEOUT,-1/, TIMEEFN/0/ + + CHARACTER BUFFER*(FOLDER_RECORD+16),DESCRIP_TEMP*53 + CHARACTER NODENAME*6,BULLCP_USER*12,INQUEUE*128 + + EQUIVALENCE (BUFFER,CMD_TYPE),(BUFFER,INQUEUE) + + INTEGER BULLCP_PRIV(2) + + BULLCP_PRIV(1) = PROCPRIV(1) + BULLCP_PRIV(2) = PROCPRIV(2) + + ILEN = READ_IOSB(2,UNIT_INDEX) + CALL LIB$MOVC3(ILEN,READ_BUF(1,UNIT_INDEX),%REF(BUFFER)) + + REC_SAVE(UNIT_INDEX) = 0 + USERNAME = USER_SAVE(UNIT_INDEX) + FOLDER = FOLDER_NAME(UNIT_INDEX) + FOLDER_NUMBER = FOLDER_NUM(UNIT_INDEX) + NODENAME = NODE_SAVE(UNIT_INDEX) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,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) THEN ! Do we need priv info? + IF (PROCPRIV(1).EQ.0.AND.PROCPRIV(2).EQ.0) THEN + CALL GET_USER_PRIV(USERNAME,PRIV_SAVE(1,UNIT_INDEX)) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,UNIT_INDEX) + IF ( (PROCPRIV(1).AND.NEEDPRIV(1)).EQ.0.AND. + & (PROCPRIV(2).AND.NEEDPRIV(2)).EQ.0) THEN + CALL CHECK_BULLETIN_PRIV(USERNAME) + PRIV_SAVE(1,UNIT_INDEX) = PROCPRIV(1) + PRIV_SAVE(2,UNIT_INDEX) = PROCPRIV(2) + END IF + END IF + END IF + + IF (CMD_TYPE.EQ.1) THEN ! Select folder + FOLDER1 = BUFFER(5:ILEN) + FOLDER_NUMBER = -2 + CALL SELECT_FOLDER(.FALSE.,IER) + CALL LIB$MOVC3(4,IER,%REF(BUFFER(1:1))) + CALL LIB$MOVC3(4,READ_ONLY,%REF(BUFFER(5: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13:13))) + ELSE + CALL LIB$MOVC3(8,LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & %REF(BUFFER(9: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13:13))) + END IF + BUFFER = BUFFER(:16)//FOLDER_COM + CALL WRITE_CHAN(16+LEN(FOLDER_COM),BUFFER,UNIT_INDEX,IER1) + IF (IER.AND.IER1) THEN + FOLDER_NAME(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(53,%REF(BUFFER(5:5)),%REF(DESCRIP)) + CALL LIB$MOVC3(11,%REF(BUFFER(58:58)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(69:69)),%REF(EXTIME)) + CALL LIB$MOVC3(4,%REF(BUFFER(80:80)),SYSTEM) + 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.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.NE.0.AND..NOT.SETPRV_PRIV()) THEN ! Priv test + IF (FOLDER_OWNER.NE.USERNAME) THEN + SYSTEM = 0 + ELSE ! Allow permanent if + SYSTEM = SYSTEM.AND.2 ! owner of folder + END IF + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + 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(84:84)),BROAD) + IF (BROAD.AND..NOT.SETPRV_PRIV().AND..NOT.OPER_PRIV()) THEN + BROAD = 0 + END IF + CALL LIB$MOVC3(4,%REF(BUFFER(88:88)),BELL) + CALL LIB$MOVC3(4,%REF(BUFFER(92:92)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(97:97)),CLUSTER) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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 + 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 (1) + 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:).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 + IER = SYS$SETIMR(%VAL(TIMEEFN),TIMEBUF,ENABLE_CTRL_EXIT, + & %VAL(1)) + 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 + IER = SYS$CANTIM(%VAL(1),) + END DO + ELSE IF (CMD_TYPE.EQ.8) THEN ! Read directory entry + CALL LIB$MOVC3(4,%REF(BUFFER(5:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + IF (ICOUNT.GE.0) THEN + CALL READDIR(ICOUNT,IER) + ELSE + CALL LIB$MOVC3(8,%REF(BUFFER(9:9)),%REF(MSG_KEY(1:1))) + CALL READDIR_KEYGE(IER) + END IF + CALL CLOSE_BULLDIR + CALL LIB$MOVC3(4,IER,%REF(BUFFER(1: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:5)),SBULL) + CALL LIB$MOVC3(4,%REF(BUFFER(9:9)),EBULL) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),BULL_DELETE) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR + CALL LIB$MOVC3(53,%REF(BUFFER(5:5)),%REF(DESCRIP_TEMP)) + CALL LIB$MOVC3(4,%REF(BUFFER(58:58)),ICOUNT) + 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(53,%REF(BUFFER(62:62)),%REF(DESCRIP)) + CALL LIB$MOVC3(4,%REF(BUFFER(115:115)),%REF(MSGTYPE)) + CALL LIB$MOVC3(11,%REF(BUFFER(119:119)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(130:130)),%REF(EXTIME)) + 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:5)),BULL_DELETE) + DESCRIP_TEMP = BUFFER(9:61) + 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(11,%REF(BUFFER(62:62)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(73:73)),%REF(EXTIME)) + 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 + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) + CALL GET_NEWEST_MSG(%REF(BUFFER(5: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: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:5)),BLENGTH) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:13)), + & %VAL(SCRATCH(UNIT_INDEX)+START-1)) + ELSE + CALL LIB$MOVC3(BLENGTH,%VAL(SCRATCH(UNIT_INDEX)), + & %REF(BMESSAGE(1:1))) + CALL LIB$MOVC3(4,%REF(BUFFER(13:13)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(17:17)),CLUSTER) + CALL LIB$FREE_VM(BRDCST_LIMIT,SCRATCH(UNIT_INDEX)) + IF (ILEN.GT.20) THEN + CALL LIB$MOVC3(4,%REF(BUFFER(21:21)),FOLDER_NUMBER) + FOLDER = BUFFER(25:) + GO TO 100 + ELSE IF (SETPRV_PRIV().OR.OPER_PRIV()) THEN + CALL BROADCAST(ALL,CLUSTER) + END IF + END IF + END IF + +1000 PROCPRIV(1) = BULLCP_PRIV(1) + PROCPRIV(2) = BULLCP_PRIV(2) + + RETURN + END + + + + SUBROUTINE UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) + COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,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.GE.0) RETURN + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = LAST_SAVE(1,UNIT_INDEX) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = LAST_SAVE(2,UNIT_INDEX) + 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 + + END + + + + + SUBROUTINE CHECK_BULLETIN_PRIV(USERNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + INCLUDE 'BULLFILES.INC' + + 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) THEN + PROCPRIV(1) = NEEDPRIV(1) + PROCPRIV(2) = NEEDPRIV(2) + END IF + 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 + REC_LOCK = 1 + 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) + + CHARACTER*80 MESSAGE + + CALL LIB$SYS_GETMSG(IER,,MESSAGE) + WRITE (6,'(A)') MESSAGE + + RETURN + END diff --git a/decus/vax89a2/nieland/bulletin/bulletin9.for b/decus/vax89a2/nieland/bulletin/bulletin9.for new file mode 100644 index 0000000..a57ed02 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulletin9.for @@ -0,0 +1,1763 @@ +C +C BULLETIN9.FOR, Version 6/1/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + 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 + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER LOCAL_NODE*32,NODE_TEMP*256 + + 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)) + IF (INDEX(NODES(NODE_NUM),'::').GT.0) THEN ! Remove :: if + NLEN = INDEX(NODES(NODE_NUM),'::') - 1 ! addedd + END IF + IF (LOCAL_NODE(1:L_NODE).EQ.NODES(NODE_NUM)(1:NLEN)) THEN + NODE_NUM = NODE_NUM - 1 + LOCAL_NODE_FOUND = .TRUE. + ELSE + POINT_NODE = NODE_NUM + OPEN (UNIT=9+NODE_NUM,NAME=NODES(NODE_NUM)(1: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 DELETE_NODE +C +C SUBROUTINE DELETE_NODE +C +C FUNCTION: Deletes files sent via ADD/NODES at remote hosts. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER PASSWORD*31,INLINE*80,DEFAULT_USER*12 + + CALL GET_NODE_INFO + + IF (NODE_ERROR) GO TO 940 + + IF (NODE_NUM.EQ.0.OR.LOCAL_NODE_FOUND) THEN + WRITE (6,'('' ERROR: Cannot specify local node.'')') + GO TO 999 + END IF + + IER = CLI$GET_VALUE('USERNAME',DEFAULT_USER) + IF (.NOT.IER) DEFAULT_USER = USERNAME + IER = CLI$GET_VALUE('SUBJECT',DESCRIP) + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + SEMI = INDEX(NODES(POINT_NODE),'::') ! Look for semicolon after node + NLEN = TRIM(NODES(POINT_NODE)) ! Length of node name + IF (SEMI.GT.0) THEN ! Is semicolon present? + IF (NLEN.GT.SEMI+1) THEN ! Yes, is username after node? + TEMP_USER = NODES(POINT_NODE)(SEMI+2:) ! Yes, set username + NLEN = SEMI - 1 ! Remove semicolon + ELSE ! No username after nodename + TEMP_USER = DEFAULT_USER ! Set username to default + NLEN = SEMI - 1 ! Remove semicolon + SEMI = 0 ! Indicate no username + END IF + ELSE ! No semicolon present + TEMP_USER = DEFAULT_USER ! Set username to default + END IF + INLINE = 'DELETE/SUBJECT="'//DESCRIP(:TRIM(DESCRIP))// + & '"/USERNAME='//TEMP_USER(:TRIM(TEMP_USER)) + IF (CLI$PRESENT('USERNAME').OR.SEMI.GT.0) THEN ! If username was + IER = 1 ! specified, prompt for password + DO WHILE (IER.NE.0) + WRITE(6,'('' Enter password for node '',2A)') + & NODES(POINT_NODE),CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) GO TO 910 + OPEN (UNIT=10+NODE_NUM,NAME=NODES(POINT_NODE)(:NLEN) + & //'"'//TEMP_USER(1:TRIM(TEMP_USER))//' '// + & PASSWORD(1:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10+NODE_NUM) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + END IF + END DO + END IF + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INLINE + IF (INLINE.EQ.'END') THEN + WRITE (6,'('' Message successfully deleted from node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while deleting message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INLINE + END IF + END DO + + GO TO 999 + +910 WRITE (6,1010) + GO TO 999 + +940 WRITE (6,1015) NODES(POINT_NODE) + +999 DO WHILE (NODE_NUM.GT.0) + CLOSE(UNIT=9+NODE_NUM) + NODE_NUM = NODE_NUM - 1 + END DO + + RETURN + +1010 FORMAT (' ERROR: Deletion aborted.') +1015 FORMAT (' ERROR: Unable to reach node ',A) + + END + + + + + SUBROUTINE SET_FOLDER_FLAG(SETTING,FLAG,FLAGNAME) +C +C SUBROUTINE SET_FOLDER_FLAG +C +C FUNCTION: Sets or clears specified flag for folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*(*) FLAGNAME + + IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (SETTING) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,FLAG) + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,FLAG) + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + WRITE (6,'(1X,A,'' has been modified for folder.'')') + & FLAGNAME + ELSE + WRITE (6,'(1X,'' You are not authorized to modify '',A)') + & FLAGNAME//'.' + END IF + + RETURN + END + + + + + SUBROUTINE SET_FOLDER_EXPIRE_LIMIT(LIMIT) +C +C SUBROUTINE SET_FOLDER_EXPIRE_LIMIT +C +C FUNCTION: Sets folder expiration limit. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (LIMIT.LT.0) THEN + WRITE (6,'('' ERROR: Invalid expiration length specified.'')') + ELSE IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + F_EXPIRE_LIMIT = LIMIT + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + WRITE (6,'('' Folder expiration date modified.'')') + ELSE + WRITE (6,'('' You are not allowed to modify folder.'')') + END IF + + RETURN + END + + + + + + SUBROUTINE MERGE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + ENTRY INITIALIZE_MERGE(IER1) + + DO WHILE (FILE_LOCK(IER1,IER2)) + OPEN (UNIT=13,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER1.NE.0) RETURN + + NBULL = 0 + + WRITE(13,IOSTAT=IER1) BULLDIR_HEADER + CALL CONVERT_HEADER_FROMBIN + + TO_POINTER = 1 + + RETURN + + ENTRY ADD_MERGE_TO(IER1) + + IER1 = 0 + + DO WHILE (IER1.EQ.0) + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + + CALL READDIR(TO_POINTER,IER) + + DIFF = COMPARE_BTIM(%REF(BULLDIR_ENTRY_SAVE),MSG_BTIM) + IF (DIFF.LT.0.OR.TO_POINTER+1.NE.IER) THEN + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + CALL CONVERT_ENTRY_FROMBIN + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + END DO + + CLOSE (UNIT=13) + + RETURN + + ENTRY ADD_MERGE_FROM(IER1) + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + BLOCK = NBLOCK - LENGTH + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + RETURN + + ENTRY ADD_MERGE_REST(IER1) + + CALL UPDATE_LOGIN(.TRUE.) + + DO WHILE (IER1.EQ.0) + + CALL READDIR(TO_POINTER,IER) + IF (TO_POINTER+1.NE.IER) THEN + READ (13,KEYID=0,KEY=0,IOSTAT=IER1) + CALL CONVERT_HEADER_TOBIN + REWRITE(13,IOSTAT=IER1) BULLDIR_HEADER + IF (IER1.EQ.0) THEN + CLOSE (UNIT=13,DISPOSE='KEEP') + CALL LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.TMPDIR',FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR') + ELSE + CLOSE (UNIT=13) + END IF + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + END DO + + CLOSE (UNIT=13) + + RETURN + END + + + + + SUBROUTINE SET_NOKEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + INCLUDE '($SMGDEF)' + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'SET KEYPAD',) + + RETURN + END + + + + + + SUBROUTINE SET_KEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + INCLUDE '($SMGDEF)' + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF1',,,,'GOLD') + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'HELP',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2','GOLD',TERM,'SET NOKEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3',,,'EXTRACT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3','GOLD',,'FILE ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4',,TERM,'SHOW KEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4','GOLD',TERM, + & 'SHOW KEYPAD/PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0',,TERM, + & 'SHOW FOLDER/FULL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0','GOLD',TERM,'SHOW FLAGS',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1',,TERM,'BACK',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1','GOLD',TERM,'NEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2',,TERM,'PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2','GOLD',TERM,'PRINT/NONOTIFY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3',,TERM,'DIR',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3','GOLD',TERM,'DIR/FOLDER',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4',,TERM,'CURRENT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4','GOLD',TERM,'CURRENT/EDIT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5',,TERM,'RESPOND',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5','GOLD',TERM,'RESP/EDIT/TEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP6',,TERM,'LAST',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7',,TERM,'ADD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7','GOLD',TERM,'ADD/EDIT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8',,TERM,'REPLY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8','GOLD',TERM,'REPL/EDIT/TEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9',,TERM,'MAIL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9','GOLD',TERM,'MAIL/NOHEAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS',,TERM,'READ/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS','GOLD',TERM,'SHOW NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA',,TERM,'DIR/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA','GOLD',TERM,'INDEX',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD',,TERM,'DELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD','GOLD',TERM,'UNDELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'ENTER','GOLD',,'SELECT ',) + + RETURN + END + + + + SUBROUTINE SHOW_KEYPAD(LIBRARY) + + IMPLICIT INTEGER (A-Z) + EXTERNAL LIB$PUT_OUTPUT,PRINT_OUTPUT + CHARACTER*(*) LIBRARY + + INCLUDE '($HLPDEF)' + + IF (CLI$PRESENT('PRINT')) THEN + OPEN (UNIT=8,STATUS='NEW',FILE='SYS$PRINT:KEYPAD.DAT', + & IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR WHILE OPENING FILE TO PRINTER.'')') + ELSE + CALL LBR$OUTPUT_HELP(PRINT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + CLOSE (UNIT=8) + END IF + ELSE + CALL LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + END IF + + RETURN + END + + INTEGER FUNCTION PRINT_OUTPUT(INPUT) + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) INPUT + WRITE (8,'(1X,A)',IOSTAT=IER) INPUT(:TRIM(INPUT)) + IF (IER.EQ.0) PRINT_OUTPUT = 1 + RETURN + END + + + + SUBROUTINE OUTPUT_HELP(PARAMETER,LIBRARY) +C +C SUBROUTINE OUTPUT_HELP +C +C FUNCTION: +C To create interactive help session. Prompting is enabled. +C INPUTS: +C PARAMETER - Character string. Optional input parameter +C containing a list of help keys. +C LIBRARY - Character string. Name of help library. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LBRDEF)' + + COMMON /HELP/ HELP_PAGE,DISPLAY_ID,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID + CHARACTER*80 HELP_INPUT + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + + EXTERNAL PUT_OUTPUT + + CHARACTER*(*) LIBRARY,PARAMETER + + CHARACTER*80 PROMPT + + DATA DISPLAY_ID/0/,KEYBOARD_ID/0/ + + IER = SMG$CREATE_PASTEBOARD(PASTEBOARD_ID) ! Initialize terminal + IF (DISPLAY_ID.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_DISPLAY(PAGE_LENGTH, + & PAGE_WIDTH,DISPLAY_ID) + END IF + IER = SMG$PASTE_VIRTUAL_DISPLAY(DISPLAY_ID,PASTEBOARD_ID,1,1) + + IF (KEYBOARD_ID.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + END IF + + CALL STR$TRIM(HELP_INPUT,PARAMETER,HELP_INPUT_LEN) ! Trim input + + CALL LBR$INI_CONTROL(LINDEX,LBR$C_READ) ! Init library read + CALL LBR$OPEN(LINDEX,LIBRARY) ! Specify library name + + DO I=1,10 ! Initialize key lengths + KEYL(I) = 0 + END DO + + NKEY = 0 ! Number of help keys + + DO WHILE (1) ! Do until CTRL-Z entered or no more keys + + HELP_PAGE = 0 ! Init line counter + NEED_ERASE = .TRUE. ! Need to erase screen + + OLD_NKEY = NKEY ! Save old key count + EXACT = .TRUE. ! Exact key match + + DO WHILE (NKEY.LT.10.AND.HELP_INPUT_LEN.GT.0.AND. + & HELP_INPUT(:1).NE.'?') + ! Break input into keys + NKEY = NKEY + 1 ! Increment key counter + + DO WHILE (HELP_INPUT(1:1).EQ.' '.AND.HELP_INPUT_LEN.GT.0) + HELP_INPUT = HELP_INPUT(2:HELP_INPUT_LEN) ! Strip spaces + HELP_INPUT_LEN = HELP_INPUT_LEN - 1 ! at start of input + END DO + + NEXT_KEY = 2 + + DO WHILE (NEXT_KEY.LE.HELP_INPUT_LEN ! Search for + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.' ' ! space or + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.'/') ! backslash + NEXT_KEY = NEXT_KEY + 1 ! indicating start of next key + END DO + + IF (NEXT_KEY.GT.HELP_INPUT_LEN) THEN ! Found the last key + KEY(NKEY) = HELP_INPUT(:HELP_INPUT_LEN) ! Key string + KEYL(NKEY) = HELP_INPUT_LEN ! Key length + HELP_INPUT_LEN = 0 + ELSE ! Found the next key + KEY(NKEY) = HELP_INPUT(:NEXT_KEY-1) + HELP_INPUT = HELP_INPUT(NEXT_KEY:HELP_INPUT_LEN) + KEYL(NKEY) = NEXT_KEY - 1 + HELP_INPUT_LEN = HELP_INPUT_LEN - NEXT_KEY + 1 + END IF + END DO + HELP_INPUT_LEN = 0 + IER = LBR$GET_HELP(LINDEX,,PUT_OUTPUT,, ! Display help + & KEY(1)(:KEYL(1)),KEY(2)(:KEYL(2)), + & KEY(3)(:KEYL(3)),KEY(4)(:KEYL(4)),KEY(5)(:KEYL(5)), + & KEY(6)(:KEYL(6)),KEY(7)(:KEYL(7)),KEY(8)(:KEYL(8)), + & KEY(9)(:KEYL(9)),KEY(10)(:KEYL(10))) + + IF (IER.EQ.0.AND.HELP_INPUT_LEN.GT.0) IER = 1 + ! IER = 0 special case means input given to full screen prompt + + IF (KEY(NKEY).EQ.'*'.OR..NOT.EXACT) THEN ! If not exact match + DO I=OLD_NKEY+1,NKEY ! then don't update + KEYL(I) = 0 ! new keys + END DO + NKEY = OLD_NKEY + END IF + + DO WHILE (HELP_INPUT_LEN.EQ.0.AND.IER.AND.NKEY.GE.0) + IF (NKEY.EQ.0) THEN ! If top level, prompt for topic + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Topic? ',HELP_INPUT_LEN) + ELSE ! If not top level, prompt for subtopic + LPROMPT = 0 ! Create subtopic prompt line + DO I=1,NKEY ! Put spaces in between keys + PROMPT = PROMPT(:LPROMPT)//KEY(I)(:KEYL(I))//' ' + LPROMPT = LPROMPT + KEYL(I) + 1 + END DO + PROMPT = PROMPT(:LPROMPT)//'Subtopic? ' + LPROMPT = LPROMPT + 10 + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,PROMPT(:LPROMPT),HELP_INPUT_LEN) + END IF + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) + IF (IER.AND.HELP_INPUT_LEN.EQ.0) THEN ! If RETURN entered + KEYL(NKEY) = 0 ! Back up one key level + NKEY = NKEY - 1 + END IF + END DO + + IF (.NOT.IER.OR.NKEY.LT.0) THEN ! If CTRL-Z above top level, + CALL LBR$CLOSE(LINDEX) ! then close library, + CALL SMG$UNPASTE_VIRTUAL_DISPLAY(DISPLAY_ID,PASTEBOARD_ID) + ! remove virtual display + RETURN ! and end help session. + END IF + + END DO + + END + + + + INTEGER FUNCTION PUT_OUTPUT(INPUT,INFO,DATA,LEVEL) +C +C FUNCTION PUT_OUTPUT +C +C FUNCTION: +C Output routine for input from LBR$GET_HELP. Displays +C help text on terminal with full screen prompting. +C INPUTS: +C INPUT - Character string. Line of input text. +C INFO - Longword. Contains help flag bits. +C DATA - Longword. Not presently used. +C LEVEL - Longword. Contains current key level. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($HLPDEF)' + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + COMMON /HELP/ HELP_PAGE,DISPLAY_ID,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID + CHARACTER*80 HELP_INPUT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + + CHARACTER INPUT*(*) + + CHARACTER SPACES*20 + DATA SPACES /' '/ + + IF ((INFO.AND.HLP$M_NOHLPTXT).NE.0) THEN ! Key cannot be found + NEED_ERASE = .FALSE. ! Don't erase screen + IF (HELP_PAGE.EQ.0) THEN ! If first line of help text + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were inputted, as they are + END DO ! not valid, as no match + NKEY = OLD_NKEY ! could be found. + END IF + ELSE IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0.AND.NKEY.GT.0.AND. + & LEVEL.GT.OLD_NKEY.AND.KEY(NKEY)(:KEYL(NKEY)).NE.'*'.AND. + & %LOC(INPUT).NE.0) THEN ! If text contains key names + ! Update if not wildcard search and they are new keys + IF (KEYL(LEVEL).GT.0) THEN ! If key already updated + EXACT = .FALSE. ! Must be more than one match possible + END IF ! so indicate not exact match. + START_KEY = 1 ! String preceeding spaces. + DO WHILE (INPUT(START_KEY:START_KEY).EQ.' ') + START_KEY = START_KEY + 1 + END DO + KEY(LEVEL) = INPUT(START_KEY:) ! Store new key + CALL STR$TRIM(KEY(LEVEL),KEY(LEVEL),KEYL(LEVEL)) ! & key length + ELSE IF (HELP_PAGE.EQ.0) THEN ! If first line of text, + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were just inputted, allowing + END DO ! this routine to fill them. + END IF + + IF (NEED_ERASE) THEN ! Need to erase screen? + IER = SMG$ERASE_DISPLAY(DISPLAY_ID) ! i.e. start of new topic. + NEED_ERASE = .FALSE. + END IF + + HELP_PAGE = HELP_PAGE + 1 ! Increment screen counter + IF (PAGING.AND.HELP_PAGE.GT.PAGE_LENGTH-2) THEN ! End of page? + HELP_PAGE = 0 ! Reinitialize screen counter + CALL LIB$PUT_OUTPUT(' ') ! Skip line and prompt for next screen + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Press RETURN to continue ... ',HELP_INPUT_LEN) + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) ! Trim input + IF (.NOT.IER.OR.HELP_INPUT_LEN.GT.0) THEN ! CTRL-Z or Text input? + EXACT = .TRUE. ! If more than one match was found and being + ! displayed, text input specifies that the + ! current displayed match is desired. + PUT_OUTPUT = 0 ! Stop any more of current help display. + ELSE ! Else if RETURN entered + IER = SMG$ERASE_DISPLAY(DISPLAY_ID) ! Erase display + NSPACES = LEVEL*2 ! Number of spaces to indent output + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + ! Key name lines are indented 2 less than help description. + IF (NSPACES.GT.0) THEN ! Add spaces if present to output + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE ! Else just output text. + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + HELP_PAGE = 1 ! Increment page counter. + END IF + ELSE ! Else if not end of page + NSPACES = LEVEL*2 ! Just output text line + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + IF (NSPACES.GT.0) THEN + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_VERSION + + IMPLICIT INTEGER (A-Z) + + CHARACTER VERSION*10,DATE*23 + + CALL READ_HEADER(VERSION,DATE) + + WRITE (6,'(A)') ' BULLETIN Version '//VERSION(:TRIM(VERSION)) + + WRITE (6,'(A)') ' Linked on '//DATE(:TRIM(DATE)) + + RETURN + END + + + + + + + SUBROUTINE TAG(ADD_OR_DEL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + DATA BULL_TAG /.FALSE./,READ_TAG /.FALSE./ + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + IF (.NOT.BULL_TAG) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + IF (.NOT.CLI$PRESENT('NUMBER')) THEN + IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER) + ELSE + CALL DEL_TAG(IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Message was not marked.'')') + END IF + END IF + RETURN + END IF + + CALL OPEN_BULLDIR_SHARED + + IER1 = 0 + DO WHILE (CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + & .NE.%LOC(CLI$_ABSENT).AND.IER1.EQ.0) ! Get the specified messages + + DECODE(LEN_P,'(I)',BULL_PARAMETER) MESSAGE_NUMBER + + CALL READDIR(MESSAGE_NUMBER,IER) ! Get info for bulletin + + IF (IER.NE.MESSAGE_NUMBER+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER1) + ELSE + CALL DEL_TAG(IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Message '',I, + & '' was not marked.'')') MESSAGE_NUMBER + END IF + END IF + END DO + + CALL CLOSE_BULLDIR + + RETURN + +1010 FORMAT(' ERROR: You have not read any message.') +1030 FORMAT(' ERROR: Message was not found.') + + END + + + + SUBROUTINE ADD_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER*12 TAG_KEY + + WRITE (13,IOSTAT=IER) TAG_KEY(FOLDER_NUMBER,MSG_KEY) + + IF (IER.EQ.FOR$IOS_INCKEYCHG) THEN + WRITE (6,'('' Message was already marked.'')') + ELSE IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Unable to add mark.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + END IF + + RETURN + END + + + + + SUBROUTINE DEL_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER*12 TAG_KEY + + DO WHILE (REC_LOCK(IER)) + READ (13,KEYEQ=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) + END DO + IF (IER.NE.0) RETURN + + DELETE (UNIT=13,IOSTAT=IER) + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Unable to delete mark.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + END IF + + RETURN + END + + + + + + SUBROUTINE OPEN_OLD_TAG + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + IF (.NOT.IER) RETURN + + NTRIES = 0 + + DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) + OPEN (UNIT=13,FILE='BULL_MARK:'// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + NTRIES = NTRIES + 1 + END DO + + IF (IER.NE.0.AND.IER.NE.FOR$IOS_FILNOTFOU) THEN + WRITE (6,'('' Unable to open mark file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + RETURN + END IF + + IF (IER.EQ.0) BULL_TAG = .TRUE. + + RETURN + END + + + + + SUBROUTINE OPEN_NEW_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*64 BULL_MARK + + IER = SYS_TRNLNM('BULL_MARK',BULL_MARK) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: BULL_MARK must be defined.'', + & '' See HELP MARK.'')') + RETURN + ELSE + IER1 = SYS_TRNLNM_SYSTEM('BULL_MARK',BULL_PARAMETER) + IF (.NOT.IER1.OR.BULL_MARK.NE.BULL_PARAMETER) THEN + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + CALL DISABLE_PRIVS + IER1 = 0 + END IF + OPEN (UNIT=13,FILE='BULL_MARK:'// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & RECORDSIZE=3, + & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + IF (.NOT.IER1) CALL ENABLE_PRIVS + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot create mark file.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + IER = 0 + ELSE + CALL SYS_GETMSG(IER1) + IER = IER1 + END IF + ELSE + BULL_TAG = .TRUE. + IER = 1 + END IF + END IF + + RETURN + END + + + + CHARACTER*12 FUNCTION TAG_KEY(FOLDER_NUMBER,MSG_KEY) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) MSG_KEY + + CALL LIB$MOVC3(4,FOLDER_NUMBER,%REF(TAG_KEY)) + + CALL GET_MSGKEY(%REF(MSG_KEY),TAG_KEY(5:)) + + RETURN + END + + + + + SUBROUTINE GET_FIRST_TAG(FOLDER_NUMBER,IER,MESSAGE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + CHARACTER*12 TAG_KEY,INPUT_KEY + + IF (.NOT.BULL_TAG) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + MSG_KEY = BULLDIR_HEADER + + HEADER = .TRUE. + GO TO 10 + + ENTRY GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) + + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + + ENTRY GET_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) + + HEADER = .FALSE. + +10 DO WHILE (1) + DO WHILE (REC_LOCK(IER)) + READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) + & INPUT_KEY + END DO + + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),MSG_KEY) + CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER) + END IF + + IF (FOLDER1_NUMBER.NE.FOLDER_NUMBER.OR.IER.NE.0) THEN + IER = 1 + UNLOCK 13 + RETURN + ELSE + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL OPEN_BULLDIR + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),INPUT_KEY(5:)) + IF (IER.NE.0.AND.MSG_KEY.EQ.INPUT_KEY(5:)) THEN + UNLOCK 13 + MESSAGE = MSG_NUM + IF (HEADER) THEN + MESSAGE = MESSAGE - 1 + MSG_KEY = BULLDIR_HEADER + END IF + IER = 0 + RETURN + ELSE + DELETE (UNIT=13) + IER = 1 + END IF + END IF + + END DO + + END + + + + + + + SUBROUTINE FULL_DIR(INDEX_COUNT) +C +C Add INDEX command to BULLETIN, display directories of ALL +C folders. Added per request of a faculty member for his private +C board. Changes to BULLETIN.FOR should be fairly obvious. +C +C Brian Nelson, Brian@uoft02.bitnet (or .ccnet, node 8.2) +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + INCLUDE 'BULLFILES.INC' + INCLUDE 'BULLFOLDER.INC' + INCLUDE 'BULLUSER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /TAGS/ BULL_TAG,READ_TAG + + DATA FOLDER_Q1/0/ + + BULL_POINT = 0 + + IF (NUM_FOLDERS.GT.0.AND..NOT.CLI$PRESENT('RESTART') + & .AND.INDEX_COUNT.EQ.1) THEN + INDEX_COUNT = 2 + DIR_COUNT = 0 + END IF + + IF (INDEX_COUNT.EQ.1) THEN + CALL INIT_QUEUE(FOLDER_Q1,FOLDER1_COM) + + FOLDER_Q = FOLDER_Q1 + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0) THEN + IF (BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + WRITE (6,1000) + WRITE (6,1020) + DO J = 1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + WRITE (6,1030) FOLDER1(:15),F1_NBULL, + & FOLDER1_DESCRIP(:MIN(TRIM(FOLDER1_DESCRIP),59)) + END DO + WRITE (6,1060) + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + INDEX_COUNT = 2 + DIR_COUNT = 0 + READ_TAG = .FALSE. + IF (CLI$PRESENT('MARKED')) READ_TAG = .TRUE. + RETURN + ELSE IF (INDEX_COUNT.EQ.2) THEN + IF (DIR_COUNT.EQ.0) THEN + F1_NBULL = 0 + DO WHILE (NUM_FOLDERS.GT.0.AND.F1_NBULL.EQ.0) + NUM_FOLDERS = NUM_FOLDERS - 1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + IF (F1_NBULL.GT.0) THEN + FOLDER_NUMBER = -1 + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) F1_NBULL = 0 + END IF + END DO + + IF (F1_NBULL.EQ.0) THEN + WRITE (6,1050) + INDEX_COUNT = 0 + RETURN + END IF + END IF + + IF (READ_TAG) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + END IF + + CALL DIRECTORY(DIR_COUNT) + IF (DIR_COUNT.GT.0) RETURN + + IF (NUM_FOLDERS.GT.0) THEN + WRITE (6,1040) + ELSE + INDEX_COUNT = 0 + END IF + END IF + + RETURN + +1000 FORMAT (' The following folders are present'/) +1020 FORMAT (' Name Count Description'/) +1030 FORMAT (1X,A15,I5,1X,A) +1040 FORMAT (' Type Return to continue to the next folder...') +1050 FORMAT (' End of folder search.') +1060 FORMAT (' Type Return to continue...') + + END + + + + + SUBROUTINE SHOW_USER +C +C SUBROUTINE SHOW_USER +C +C FUNCTION: Shows information for specified users. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + DIMENSION NOLOGIN_BTIM(2) + + CHARACTER*17 DATETIME + + ALL = CLI$PRESENT('NOLOGIN').OR.CLI$PRESENT('ALL') + & .OR.CLI$PRESENT('LOGIN') + IF (.NOT.ALL) THEN + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + IF (.NOT.IER) TEMP_USER = USERNAME + END IF + + IF (.NOT.SETPRV_PRIV().AND.(ALL.OR.USERNAME.NE.TEMP_USER)) THEN + WRITE (6,'('' ERROR: No privs to user command.'')') + RETURN + END IF + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + + CALL OPEN_BULLUSER_SHARED + + IF (.NOT.ALL) THEN + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + IF (IER.EQ.0) THEN + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + WRITE (6,'('' NOLOGIN set for specified user.'')') + ELSE + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'('' User last logged in at '',A,''.'')') + & DATETIME + END IF + ELSE + WRITE (6,'('' Entry for specified user not found.'')') + END IF + ELSE + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + CALL READ_USER_FILE(IER) + IF (IER.EQ.0.AND.TEMP_USER(:1).NE.':'.AND. + & TEMP_USER(:1).NE.'*') THEN + IER1 = COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM) + IF (.NOT.CLI$PRESENT('LOGIN').AND.IER1.GE.0) THEN + WRITE (6,'('' NOLOGIN set for '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)) + ELSE IF (.NOT.CLI$PRESENT('NOLOGIN').AND.IER1.LT.0) THEN + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'(1X,A,'' last logged in at '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)),DATETIME + END IF + END IF + END DO + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + SUBROUTINE INIT_MESSAGE_ADD(IN_FOLDER,IN_FROM,IN_DESCRIP,IER) +C +C SUBROUTINE INIT_MESSAGE_ADD +C +C FUNCTION: Opens specified folder in order to add message. +C +C INPUTS: +C IN_FOLDER - Character string containing folder name +C IN_FROM - Character string containing name of owner of message. +C If empty, the default is the owner of the process. +C IN_DESCRIP - Character string containing subject of message. +C If empty, the message is searched for a line +C which starts with "Subj:" or "Subject:". +C OUTPUTS: +C IER - Error status. True if properly connected to folder. +C False if folder not found. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + DATA LPRO/0/ + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + CHARACTER*(*) IN_FOLDER,IN_FROM,IN_DESCRIP + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /TEXT_PRESENT/ TEXT + + BULLCP = 1 ! Inhibit folder cleanup subprocess + + CALL OPEN_BULLFOLDER ! Get folder file + + CALL READ_FOLDER_FILE_KEYNAME(IN_FOLDER(:TRIM(IN_FOLDER)),IER) + + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + RETURN + ELSE + IER = 1 + END IF + + ENTRY INIT_MESSAGE_ADD_BBOARD(IN_FROM,IN_DESCRIP,IER) + + TEXT = .FALSE. ! No text written, as of yet + + FIRST_BREAK = .TRUE. + + IF (FOLDER_NUMBER.EQ.0) THEN ! If GENERAL folder + FOLDER_SET = .FALSE. ! indicate it + ELSE ! Else it's another folder + FOLDER_SET = .TRUE. ! indicate it + END IF + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER ! set folder file names + + ENTRY INIT_MESSAGE_ADD_DIGEST(IN_FROM,IN_DESCRIP,IER) + + CALL OPEN_BULLDIR ! Open directory file + + CALL OPEN_BULLFIL ! Open data file + + CALL READDIR(0,IER1) ! Get NBLOCK + IF (IER1.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + NBLOCK = NBLOCK + 1 + LENGTH = NBLOCK ! Initialize line count + + LEN_FROM = TRIM(IN_FROM) + IF (LEN_FROM.EQ.0) THEN + CALL GETUSER(FROM) + INFROM = FROM + LEN_FROM = TRIM(INFROM) + ELSE + INFROM = IN_FROM + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_FROM(INFROM,LEN_FROM) + ELSE IF (INDEX(INFROM,'%"').GT.0) THEN ! Store any protocol + LPRO = INDEX(INFROM,'%"') + 1 + PROTOCOL = INFROM(:LPRO) + END IF + END IF + + LEN_DESCRP = TRIM(IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + + CALL STRIP_HEADER(INPUT,0,IER1) + + RETURN + END + + + + + SUBROUTINE WRITE_MESSAGE_LINE(BUFFER) +C +C SUBROUTINE WRITE_MESSAGE_LINE +C +C FUNCTION: Writes one line of message into folder. +C +C INPUTS: +C BUFFER - Character string containing line to be put into message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + DATA FIRST_BREAK/.TRUE./ + + COMMON /STRIP_HEADER/ STRIP + DATA STRIP/.TRUE./ + + COMMON /TEXT_PRESENT/ TEXT + + CHARACTER*(*) BUFFER + + LEN_BUFFER = TRIM(BUFFER) + + IF (BTEST(FOLDER_FLAG,5)) THEN + IF (INDEX(BUFFER,'-------------').EQ.1) THEN + BREAK = .TRUE. + DO I=1,LEN_BUFFER + IF (BUFFER(I:I).NE.'-') BREAK = .FALSE. + END DO + ELSE + BREAK = .FALSE. + END IF + IF (BREAK) THEN + IF (.NOT.FIRST_BREAK) THEN + CALL FINISH_MESSAGE_ADD + CALL INIT_MESSAGE_ADD_DIGEST(INFROM,INDESCRIP,IER) + ELSE + FIRST_BREAK = .FALSE. + END IF + LFROM = 0 + LDESCR = 0 + RETURN + ELSE IF (.NOT.FIRST_BREAK) THEN + IF (LDESCR.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + LDESCR = LEN_BUFFER - 9 + CALL STORE_DESCRP(BUFFER(10:),LDESCR) + IF (LFROM.EQ.0) THEN + LFROM = LEN_FROM + CALL STORE_FROM(INFROM,LFROM) + END IF + ELSE IF (BUFFER(:6).EQ.'From: ') THEN + LFROM = LEN_BUFFER - 6 + IF (LPRO.GT.0) THEN + LFROM = LFROM + LPRO + 1 + CALL STORE_FROM(PROTOCOL(:LPRO)// + & BUFFER(7:LEN_BUFFER)//'"',LFROM) + ELSE + CALL STORE_FROM(BUFFER(7:),LFROM) + END IF + END IF + RETURN + END IF + ELSE + RETURN + END IF + END IF + + IF (LEN_BUFFER.EQ.0) THEN ! If empty line + IF (.NOT.STRIP) THEN + CALL STORE_BULL(1,' ',NBLOCK) ! just store one space + ELSE + STRIP = .FALSE. + END IF + ELSE + IF (LEN_DESCRP.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + DESCRIP = BUFFER(INDEX(BUFFER,' ')+1:) + LEN_DESCRP = LEN_BUFFER + END IF + END IF + IF (STRIP) THEN + CALL STRIP_HEADER(BUFFER,LEN_BUFFER,IER) + IF (IER) THEN + RETURN + ELSE + STRIP = .FALSE. + END IF + END IF + CALL STORE_BULL(MIN(LEN_BUFFER,LINE_LENGTH),BUFFER,NBLOCK) + TEXT = .TRUE. + END IF + + RETURN + END + + + + + SUBROUTINE FINISH_MESSAGE_ADD +C +C SUBROUTINE FINISH_MESSAGE_ADD +C +C FUNCTION: Writes message entry into directory file and closes folder +C +C NOTE: Only should be run if INIT_MESSAGE_ADD was successful. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + COMMON /STRIP_HEADER/ STRIP + + COMMON /TEXT_PRESENT/ TEXT + + STRIP = .TRUE. ! Reset strip flag + + CALL FLUSH_BULL(NBLOCK) + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + IF ((BTEST(FOLDER_FLAG,5).AND.LDESCR.EQ.0).OR. ! End of digest msg + & .NOT.TEXT) THEN ! or no message text found + CALL CLOSE_BULLDIR ! then don't add message entry + RETURN + END IF + + IF (FOLDER_BBEXPIRE.EQ.-1) THEN ! Folder has expiration time? + EXDATE = '5-NOV-2000' ! no, so set date far in future + SYSTEM = 2 ! indicate permanent message + ELSE ! Else set expiration date + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + SYSTEM = 0 + END IF + EXTIME = '00:00:00.00' + + LENGTH = NBLOCK - LENGTH + 1 ! Number of records + + CALL ADD_ENTRY ! Add the new directory entry + + CALL CLOSE_BULLDIR ! Totally finished with add + + CALL UPDATE_FOLDER + + RETURN + END + + + + SUBROUTINE STORE_FROM(IFROM,LEN_INFROM) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) IFROM + + CHARACTER*(LINE_LENGTH) INFROM + + INFROM = IFROM + + CALL STORE_BULL(6+LEN_INFROM,'From: '//INFROM(:LEN_INFROM), + & NBLOCK) + + IF (INDEX(INFROM,'%"').GT.0) ! Strip off protocol program + & INFROM = INFROM(INDEX(INFROM,'%"')+2:) + + IF (INDEX(INFROM,'::').GT.0) ! Strip off node name + & INFROM = INFROM(INDEX(INFROM,'::')+2:) ! I.e. HOST::USER + + DO WHILE (INDEX(INFROM,'!').GT.0.AND. ! Unix address go backwards. + & INDEX(INFROM,'!').LT.INDEX(INFROM,'@')) + INFROM = INFROM(INDEX(INFROM,'!')+1:) ! I.e. host!user + END DO + + IF (INDEX(INFROM,'<').GT.0) THEN ! Name may be of form + INFROM = INFROM(INDEX(INFROM,'<'):) ! personal-name + END IF + + IF (INDEX(INFROM,'(').GT.0.AND. ! personal-name (net-name) + & INDEX(INFROM,'@').GT.INDEX(INFROM,'(')) THEN + INFROM = INFROM(INDEX(INFROM,'(')+1:) + END IF + + I = 1 ! Trim username to start at first alpha character + DO WHILE (I.LE.LEN_INFROM.AND.(INFROM(I:I).EQ.' '.OR. + & INFROM(I:I).EQ.'%'.OR.INFROM(I:I).EQ.'.'.OR. + & INFROM(I:I).EQ.'@'.OR.INFROM(I:I).EQ.'<'.OR. + & INFROM(I:I).EQ.'"')) + I = I + 1 + END DO + INFROM = INFROM(I:) + + I = 1 ! Trim username to end at a alpha character + DO WHILE (I.LE.12.AND.INFROM(I:I).NE.' '.AND. + & INFROM(I:I).NE.'%'.AND.INFROM(I:I).NE.'.'.AND. + & INFROM(I:I).NE.'@'.AND.INFROM(I:I).NE.'<'.AND. + & INFROM(I:I).NE.'"') + I = I + 1 + END DO + FROM = INFROM(:I-1) + + DO J=2,I-1 + IF ((FROM(J:J).GE.'A'.AND.FROM(J:J).LE.'Z').AND. + & ((FROM(J-1:J-1).GE.'A'.AND.FROM(J-1:J-1).LE.'Z').OR. + & (FROM(J-1:J-1).GE.'a'.AND.FROM(J-1:J-1).LE.'z'))) THEN + FROM(J:J) = CHAR(ICHAR(FROM(J:J))-ICHAR('A')+ICHAR('a')) + END IF + END DO + + RETURN + END + + + + + SUBROUTINE STORE_DESCRP(INDESCRIP,LEN_DESCRP) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) INDESCRIP + + DO WHILE (LEN_DESCRP.GT.0.AND.INDESCRIP(:1).EQ.' ') + INDESCRIP = INDESCRIP(2:) + LEN_DESCRP = LEN_DESCRP - 1 + END DO + + DO I=1,LEN_DESCRP ! Remove control characters + IF (INDESCRIP(I:I).LT.' ') INDESCRIP(I:I) = ' ' + END DO + IF (LEN_DESCRP.GT.LEN(DESCRIP)) THEN + ! Is length > allowable subject length? + CALL STORE_BULL(6+LEN_DESCRP,'Subj: '// + & INDESCRIP(:LEN_DESCRP),NBLOCK) + END IF + + DESCRIP = INDESCRIP(:MIN(LEN_DESCRP,LEN(DESCRIP))) + + RETURN + END + + + + + SUBROUTINE STRIP_HEADER(BUFFER,BLEN,IER) +C +C SUBROUTINE STRIP_HEADER +C +C FUNCTION: Indicates whether line is part of mail message header. +C +C INPUTS: +C BUFFER - Character string containing input line of message. +C BLEN - Length of character string. If = 0, initialize subroutine. +C +C OUTPUTS: +C IER - If true, line should be stripped. Else, end of header. +C + IMPLICIT INTEGER (A - Z) + + CHARACTER*(*) BUFFER + + INCLUDE 'BULLFOLDER.INC' + + IF (.NOT.BTEST(FOLDER_FLAG,4).OR.TRIM(BUFFER).EQ.0) THEN + ! If STRIP not set for folder or empty line + IER = .FALSE. + CONT_LINE = .FALSE. + RETURN + END IF + + IF (BLEN.EQ.0) CONT_LINE = .FALSE. + + IER = .TRUE. + + IF (CONT_LINE.AND.(BUFFER(:1).EQ.' '.OR. ! If line is continuation + & BUFFER(:1).EQ.CHAR(9))) RETURN ! of previous header line + + I = 1 + DO WHILE (I.LE.BLEN.AND.BUFFER(I:I).NE.' ') + IF (BUFFER(I:I).EQ.':') THEN ! Header line found + CONT_LINE = .TRUE. ! Next line might be continuation + RETURN + ELSE + I = I + 1 + END IF + END DO + + IER = .FALSE. + CONT_LINE = .FALSE. + + RETURN + END diff --git a/decus/vax89a2/nieland/bulletin/bullfiles.inc b/decus/vax89a2/nieland/bulletin/bullfiles.inc new file mode 100644 index 0000000..5a169eb --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bullfiles.inc @@ -0,0 +1,28 @@ +C +C FOLDER_DIRECTORY IS THE DIRECTORY THAT FILES FOR FOLDERS THAT +C ARE CREATED ARE KEPT IN. IF YOU WISH TO PREVENT FOLDER CREATION, +C YOU SHOULD MODIFY BULLCOM.CLD TO MAKE THE CREATE COMMAND A PRIVILEGED +C COMMAND (OR SIMPLY REMOVE THE LINES WHICH DEFINE THE CREATE COMMAND). +C +C BBOARD_DIRECTORY IS THE SCRATCH AREA USED BY BBOARD WHEN EXTRACTING +C MAIL. IF IT IS UNDEFINED, BBOARD WILL NOT BE ABLE TO BE USED. +C NOTE THAT EITHER THE BBOARD ACCOUNTS MUST HAVE ACCESS TO THIS DIRECTORY, +C OR THE BBOARD ACCOUNTS MUST BE GIVEN SYSPRV PRIVILEGES TO BE ABLE +C TO WRITE INTO THIS DIRECTORY. ALSO, FOR BBOARD TO WORK, MAKE SURE +C THAT THE SUBPROCESS LIMIT FOR USERS IS AT LEAST 2. YOU WILL ALSO HAVE +C TO INCREASE THE FOLLOWING SYSTEM PARAMETERS WHICH AFFECT DETACHED PROCESES: +C PQL_DPGFLQUOTA = 10000, PQL_DWSQUOTA = 500, & PQL_DFILLM = 30. +C (NOTE: ACCESS CAN BE GIVEN TO THE DIRECTORY FOR THE BBOARD ACCOUNTS USING +C ACLS, I.E. " SET ACL/ACL=(ID=bboard,ACCESS=R+W)/OBJ=FILE directory.DIR") +C + COMMON /FILES/ BULLFOLDER_FILE,FOLDER_DIRECTORY,BBOARD_DIRECTORY + COMMON /FILES/ BULLUSER_FILE,BULLINF_FILE + CHARACTER*80 FOLDER_DIRECTORY /'BULL_DIR:'/ + CHARACTER*80 BBOARD_DIRECTORY /'BULL_DIR:'/ +C +C NOTE: THE FOLLOWING DEFINITIONS ASSUME THAT BULL_DIR IS USED. IF IT +C IS NOT, THEN THEY SHOULD ALSO BE CHANGED. +C + CHARACTER*80 BULLUSER_FILE /'BULL_DIR:BULLUSER.DAT'/ + CHARACTER*80 BULLFOLDER_FILE /'BULL_DIR:BULLFOLDER.DAT'/ + CHARACTER*80 BULLINF_FILE /'BULL_DIR:BULLINF.DAT'/ diff --git a/decus/vax89a2/nieland/bulletin/bullfolder.inc b/decus/vax89a2/nieland/bulletin/bullfolder.inc new file mode 100644 index 0000000..d5e4900 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bullfolder.inc @@ -0,0 +1,46 @@ +! +! The following 2 parameters can be modified if desired before compilation. +! + PARAMETER BBEXPIRE_LIMIT = 30 ! Maxmimum time limit in days that + ! BBOARDS can be set to. + PARAMETER BBOARD_UPDATE = 15 ! Number of minutes between checks + ! for new BBOARD mail. (Note: Check + ! only occurs via BULLETIN/LOGIN. + ! Check is forced via BULLETIN/BBOARD). + ! NOT APPLICABLE IF BULLCP IS RUNNING. + PARAMETER ADDID = .TRUE. ! Allows users who are not in the + ! rights data base to be added + ! according to uic number. + + PARAMETER FOLDER_FMT = '(A25,A4,A12,A80,A12,3A4,A8,7A4)' + PARAMETER FOLDER_RECORD = 184 ! Must be multiple of 4 + + COMMON /BULL_FOLDER/ FOLDER,FOLDER_NUMBER,FOLDER_OWNER, + & FOLDER_DESCRIP,FOLDER_BBOARD,FOLDER_BBEXPIRE, + & USERB,GROUPB,ACCOUNTB, + & F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,F_EXPIRE_LIMIT, + & F_NEWEST_NOSYS_BTIM,FILLER, + & FOLDER_FILE,FOLDER_SET + INTEGER F_NEWEST_BTIM(2) + INTEGER F_NEWEST_NOSYS_BTIM(2) + LOGICAL FOLDER_SET + DATA FOLDER_SET /.FALSE./, FOLDER/'GENERAL'/ + CHARACTER FOLDER_OWNER*12,FOLDER*25,ACCOUNTB*8 + CHARACTER FOLDER_FILE*80,FOLDER_DESCRIP*80,FOLDER_BBOARD*12 + + CHARACTER*(FOLDER_RECORD) FOLDER_COM + EQUIVALENCE (FOLDER,FOLDER_COM) + + COMMON /BULL_FOLDER1/ FOLDER1,FOLDER1_NUMBER,FOLDER1_OWNER, + & FOLDER1_DESCRIP,FOLDER1_BBOARD,FOLDER1_BBEXPIRE, + & USERB1,GROUPB1,ACCOUNTB1, + & F1_NBULL,F1_NEWEST_BTIM,FOLDER1_FLAG,F1_EXPIRE_LIMIT, + & F1_NEWEST_NOSYS_BTIM,FILLER1, + & FOLDER1_FILE + CHARACTER FOLDER1_OWNER*12,FOLDER1*25,ACCOUNTB1*8 + CHARACTER FOLDER1_FILE*80,FOLDER1_DESCRIP*80,FOLDER1_BBOARD*12 + INTEGER F1_NEWEST_BTIM(2) + INTEGER F1_NEWEST_NOSYS_BTIM(2) + + CHARACTER*(FOLDER_RECORD) FOLDER1_COM + EQUIVALENCE (FOLDER1,FOLDER1_COM) diff --git a/decus/vax89a2/nieland/bulletin/bulluser.inc b/decus/vax89a2/nieland/bulletin/bulluser.inc new file mode 100644 index 0000000..b0cbcf8 --- /dev/null +++ b/decus/vax89a2/nieland/bulletin/bulluser.inc @@ -0,0 +1,42 @@ +! +! The parameter FOLDER_MAX should be changed to increase the maximum number +! of folders available. Due to storage via longwords, the maximum number +! available is always a multiple of 32. Thus, it will probably make sense +! to specify a multiple of 32 for FOLDER_MAX, as that it what really will be +! the capacity. Note that the default general folder counts as a folder also, +! so that if you specify 64, you will be able to create 63 folders on your own. +! + PARAMETER FOLDER_MAX = 96 + PARAMETER FLONG = (FOLDER_MAX + 31)/ 32 + + PARAMETER USER_RECORD_LENGTH = 28 + FLONG*16 + PARAMETER USER_FMT = '(A12,<4+FLONG*4>A4)' + PARAMETER USER_HEADER_KEY = ' ' + + COMMON /HEADER_INFO/ TEMP_USER,BBOARD_BTIM,NEWEST_BTIM,USERPRIV + COMMON /HEADER_INFO/ SET_FLAG_DEF,BRIEF_FLAG_DEF + COMMON /HEADER_INFO/ NOTIFY_FLAG_DEF + CHARACTER TEMP_USER*12 + DIMENSION BBOARD_BTIM(2),NEWEST_BTIM(2),USERPRIV(FLONG) + DIMENSION SET_FLAG_DEF(FLONG),BRIEF_FLAG_DEF(FLONG) + DIMENSION NOTIFY_FLAG_DEF(FLONG) + + COMMON /BULL_USER/ USERNAME,LOGIN_BTIM,READ_BTIM, + & NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + CHARACTER*12 USERNAME + DIMENSION LOGIN_BTIM(2),READ_BTIM(2) + DIMENSION NEW_FLAG(FLONG) ! Bit set indicates new message in folder + DIMENSION SET_FLAG(FLONG) ! Bit set indicates READNEW set for folder + DIMENSION BRIEF_FLAG(FLONG) ! Bit set indicates READNEW/BRIEF set + DIMENSION NOTIFY_FLAG(FLONG)! Bit set indicates to broadcast + ! notification when new bulletin is added. + + CHARACTER*(USER_RECORD_LENGTH) USER_ENTRY,USER_HEADER + EQUIVALENCE (USER_ENTRY,USERNAME) + EQUIVALENCE (USER_HEADER,TEMP_USER) + + COMMON /FOLDER_TIMES/ LAST_READ_BTIM(2,0:FOLDER_MAX) + ! Last read times for each folder as stored in BULL_DIR:BULLINF.DAT + + COMMON /NEW_MESSAGES/ NEW_MSG + DIMENSION NEW_MSG(FLONG) ! Flag showing new messages detected diff --git a/decus/vax90a/bulletin/allmacs.mar b/decus/vax90a/bulletin/allmacs.mar new file mode 100644 index 0000000..f8a6793 --- /dev/null +++ b/decus/vax90a/bulletin/allmacs.mar @@ -0,0 +1,270 @@ +; +; Name: SETACC.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: Jan 26, 1983 +; +; Purpose: To set the account name of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETACC(account) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; account - Character string containing account name +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETACC + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF + $JIBDEF +; +; local variables: +; + + .PSECT DATA,NOEXE + +NEWACC: .BLKB 12 ; Contains new account name +; +; Executable: +; + .PSECT CODE,EXE,NOWRT ; Executable code + + .ENTRY SETACC,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R6 ; Get number of arguments + CMPL R6,#1 ; Correct number of arguments? + BNEQ 5$ ; If not, return + MOVZBL @4(AP),R6 ; Get size of string + MOVL 4(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#8,NEWACC ; Get new account name string + $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R6 ; Address of current process + MOVL PCB$L_JIB(R6),R6 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + MOVC3 #8,NEWACC,JIB$T_ACCOUNT(R6) ; change account JIB + MOVC3 #8,NEWACC,CTL$T_ACCOUNT ; change account in P1 + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +; +; Name: SETUIC.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: May 31, 1983 +; +; Purpose: To set the UIC of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETUIC(group number, user number) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; group number - longword containing UIC group number +; user number - longword containing UIC user number +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETUIC Set uic + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF +; +; Executable: +; + .PSECT SETUIC_CODE,EXE,NOWRT ; Executable code + + .ENTRY SETUIC,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R2 ; Get number of arguments + CMPL R2,#2 ; Are there 2 arguments + BNEQ 5$ ; If not, return + MOVL @4(AP),R3 ; Group number into R3 + ROTL #16,R3,R3 ; Move to upper half of R3 + ADDL2 @8(AP),R3 ; User number to top half of R3 + $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R2 ; Address of current process + MOVL R3,PCB$L_UIC(R2) ; Set UIC to specified + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +; +; Name: SETUSER.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: Jan 26, 1983 +; +; Purpose: To set the Username of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETUSER(username) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; username - Character string containing username +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETUSER Set uic + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF + $JIBDEF +; +; local variables: +; + + .PSECT SETUSER_DATA,NOEXE + +NEWUSE: .BLKB 12 ; Contains new username +OLDUSE: .BLKB 12 ; Contains old username +; +; Executable: +; + .PSECT SETUSER_CODE,EXE,NOWRT ; Executable code + + .ENTRY SETUSER,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R8 ; Get number of arguments + CMPL R8,#1 ; Correct number of arguments + BLSS 5$ ; If not, return + MOVZBL @4(AP),R6 ; Get size of string + MOVL 4(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#12,NEWUSE ; Get new username string + CMPL R8,#2 ; Old username given? + BLSS 2$ ; No + MOVZBL @8(AP),R6 ; Get size of string + MOVL 8(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#12,OLDUSE ; Get old username string + $CMKRNL_S ROUTIN=20$ ; Must run in kernel mode + TSTL R0 ; If old username is checks with + BEQL 2$ ; present process name, change + MOVL #2,R0 ; to new username, else flag + RET ; error and return +2$: $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R7 ; Address of current process + MOVL PCB$L_JIB(R7),R7 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + MOVC3 #12,NEWUSE,JIB$T_USERNAME(R7) ; change username JIB + MOVC3 #12,NEWUSE,CTL$T_USERNAME ; change username in P1 + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +20$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R7 ; Address of current process + MOVL PCB$L_JIB(R7),R7 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + CMPC R6,OLDUSE,JIB$T_USERNAME(R7) ; change username JIB + RET + + + .TITLE READ_HEADER - Read Image Header + .IDENT /1-001/ + +; This subroutine returns the image identification and link time. +; +; Format: +; +; status.wlc.v = READ_HEADER( ident.wt.ds [,time.wt.ds] ) +; +; Parameters: +; +; ident The image identification text. +; +; time The image link time (text format). + + +; Date By Comments +; 4/10/87 D.E. Greenwood Originally written by John Miano, 24-June-1986 - +; obtained from April 87 DECUS L&T Sig Newsletter + .LIBRARY "SYS$LIBRARY:LIB" + + $DSCDEF + $IHDDEF + $IHIDEF + $SSDEF + +; Argument pointer offsets + + $OFFSET 4,POSITIVE, + + .PSECT READ_HEADER, RD, NOWRT, EXE, LONG + .ENTRY READ_HEADER, ^M< R2, R3, R4, R5, R6, R7, R8, R11 > + + CMPL (AP),#1 ; Make sure that there is at least + BGEQ ENOUGH_ARGUMENTS ; one argument to this routine + MOVL #SS$_INSFARG, R0 + RET + +ENOUGH_ARGUMENTS: + +; Get the identification of the image. + + MOVL @#CTL$GL_IMGHDRBF, R11 ; R11 - Address of image buffer + MOVL (R11), R6 ; R6 - Address of image header + + CVTWL IHD$W_IMGIDOFF(R6), R7 + MOVAB (R6)[R7], R7 ; R7 - Address of ID Block + + CVTBL IHI$T_IMGID(R7),R0 ; Length of the ID string + MOVL IDENT(AP), R8 + MOVC5 R0, (R7), #32, - + DSC$W_LENGTH(R8), @DSC$A_POINTER(R8) + + CMPL (AP), #2 + BGEQ RETURN_TIME + MOVZBL #1, R0 + RET + +RETURN_TIME: + +; Get the time the image was linked and convert it to ASCII + + $ASCTIM_S - + TIMBUF=@TIME(AP), - + TIMADR=IHI$Q_LINKTIME(R7) + + RET + + .END diff --git a/decus/vax90a/bulletin/bullcom.cld b/decus/vax90a/bulletin/bullcom.cld new file mode 100644 index 0000000..f605e80 --- /dev/null +++ b/decus/vax90a/bulletin/bullcom.cld @@ -0,0 +1,419 @@ +! +! BULLCOM.CLD +! +! VERSION 2/16/90 +! + MODULE BULLETIN_SUBCOMMANDS + + DEFINE VERB ADD + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER ALL, NONNEGATABLE + QUALIFIER BELL, NONNEGATABLE + QUALIFIER BROADCAST, NONNEGATABLE + DISALLOW NOT BROADCAST AND ALL + DISALLOW NOT BROADCAST AND BELL + QUALIFIER CLUSTER, DEFAULT + QUALIFIER EDIT, NEGATABLE + QUALIFIER EXPIRATION, NONNEGATABLE, VALUE + QUALIFIER EXTRACT, NONNEGATABLE + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER NODES, LABEL=NODES, VALUE(REQUIRED,LIST) + NONNEGATABLE + QUALIFIER LOCAL, NONNEGATABLE + DISALLOW LOCAL AND NOT BROADCAST + DISALLOW NODES AND SELECT_FOLDER + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT TEXT AND NOT EXTRACT + QUALIFIER PERMANENT, NONNEGATABLE + QUALIFIER SHUTDOWN, NONNEGATABLE, VALUE + DISALLOW PERMANENT AND SHUTDOWN + QUALIFIER SUBJECT, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER SYSTEM, NONNEGATABLE + QUALIFIER TEXT, NONNEGATABLE + DISALLOW (TEXT OR EXTRACT) AND FILESPEC + QUALIFIER USERNAME, LABEL=USERNAME, VALUE(REQUIRED) + NONNEGATABLE + DEFINE VERB BACK + DEFINE VERB CHANGE + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER EDIT, NEGATABLE + QUALIFIER EXPIRATION, NONNEGATABLE, VALUE + QUALIFIER EXTRACT, NONNEGATABLE + QUALIFIER GENERAL, NONNEGATABLE + QUALIFIER HEADER, NONNEGATABLE + QUALIFIER SUBJECT, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER NEW,NONNEGATABLE + QUALIFIER NUMBER, VALUE(TYPE=$NUMBER,REQUIRED) + QUALIFIER PERMANENT, NONNEGATABLE + QUALIFIER SHUTDOWN, NONNEGATABLE, VALUE + QUALIFIER SYSTEM,NONNEGATABLE + QUALIFIER TEXT, NONNEGATABLE + DISALLOW NEW AND NOT EDIT + DISALLOW SYSTEM AND GENERAL + DISALLOW PERMANENT AND SHUTDOWN + DISALLOW PERMANENT AND EXPIRATION + DISALLOW SHUTDOWN AND EXPIRATION + DISALLOW SUBJECT AND HEADER + DEFINE VERB COPY + PARAMETER P1, LABEL=FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER MERGE + QUALIFIER ORIGINAL + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB CREATE + QUALIFIER BRIEF, NONNEGATABLE + QUALIFIER DESCRIPTION, NONNEGATABLE, VALUE(REQUIRED) +! +! Make the following qualifier DEFAULT if you want CREATE to be +! a privileged command. NOTE: Make sure that BULL_DIR:BULLUSER.DAT +! has the following protection: (RWED,RWED,,) +! + QUALIFIER NEEDPRIV, NONNEGATABLE + QUALIFIER NODE, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER NOTIFY, NONNEGATABLE + QUALIFIER OWNER, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER PRIVATE, NONNEGATABLE + QUALIFIER READNEW, NONNEGATABLE + QUALIFIER REMOTENAME, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER SEMIPRIVATE, NONNEGATABLE + QUALIFIER SHOWNEW, NONNEGATABLE + QUALIFIER SYSTEM, NONNEGATABLE + PARAMETER P1, LABEL=CREATE_FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + DISALLOW PRIVATE AND SEMIPRIVATE + DISALLOW BRIEF AND READNEW + DISALLOW SHOWNEW AND READNEW + DISALLOW BRIEF AND SHOWNEW + DISALLOW NODE AND (NOTIFY OR PRIVATE OR SEMIPRIVATE) + DISALLOW REMOTENAME AND NOT NODE + DEFINE VERB CURRENT + QUALIFIER EDIT + DEFINE VERB DELETE + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER IMMEDIATE,NONNEGATABLE + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER NODES, LABEL=NODES, VALUE(REQUIRED,LIST) + QUALIFIER USERNAME, LABEL=USERNAME, VALUE(REQUIRED) + QUALIFIER SUBJECT, VALUE(REQUIRED) + DISALLOW NOT SUBJECT AND (NODES OR SELECT_FOLDER) + DISALLOW NODES AND SELECT_FOLDER + DEFINE VERB DIRECTORY + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER FOLDER, SYNTAX=DIRECTORY_FOLDER, NONNEGATABLE + QUALIFIER NEW + QUALIFIER START, VALUE(REQUIRED,TYPE=$NUMBER), NONNEGATABLE + QUALIFIER SINCE,VALUE(DEFAULT="TODAY",TYPE=$DATETIME) + QUALIFIER MARKED, NONNEGATABLE + DISALLOW (NEW AND SINCE) OR (START AND NEW) OR (START AND SINCE) + DEFINE SYNTAX DIRECTORY_FOLDER + QUALIFIER DESCRIBE + QUALIFIER FOLDER, DEFAULT + DEFINE VERB E ! EXIT command. + DEFINE VERB EX ! EXIT command. + DEFINE VERB EXIT ! EXIT command. + DEFINE VERB EXTRACT + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE,REQUIRED), + PROMPT="File" + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER HEADER, DEFAULT + QUALIFIER NEW, NONNEGATABLE + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB FILE + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE,REQUIRED), + PROMPT="File" + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER HEADER, DEFAULT + QUALIFIER NEW, NONNEGATABLE + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB HELP + PARAMETER P1, LABEL=HELP_FOLDER, VALUE(TYPE=$REST_OF_LINE) + DEFINE VERB INDEX + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER MARKED + QUALIFIER FOLDER, SYNTAX=DIRECTORY_FOLDER, NONNEGATABLE + QUALIFIER NEW + QUALIFIER RESTART + QUALIFIER START, VALUE(REQUIRED,TYPE=$NUMBER), NONNEGATABLE + QUALIFIER SINCE,VALUE(DEFAULT="TODAY",TYPE=$DATETIME) + DISALLOW (NEW AND SINCE) OR (START AND NEW) OR (START AND SINCE) + DEFINE VERB LAST + DEFINE VERB MAIL + PARAMETER P1, LABEL=RECIPIENTS, PROMPT="Recipients" + VALUE(REQUIRED,IMPCAT,LIST) + QUALIFIER HEADER, DEFAULT + QUALIFIER SUBJECT, VALUE(REQUIRED) + DEFINE VERB MODIFY + QUALIFIER DESCRIPTION + QUALIFIER NAME, VALUE(REQUIRED) + QUALIFIER OWNER, VALUE(REQUIRED) + DEFINE VERB MOVE + PARAMETER P1, LABEL=FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER MERGE + QUALIFIER NODES + QUALIFIER ORIGINAL + QUALIFIER IMMEDIATE,NONNEGATABLE,DEFAULT + DISALLOW ALL AND BULLETIN_NUMBER + DISALLOW FOLDER AND NODES + DEFINE VERB NEXT + DEFINE VERB POST + QUALIFIER CC, VALUE(LIST,REQUIRED) + QUALIFIER EXTRACT + QUALIFIER LIST, DEFAULT + QUALIFIER SUBJECT, VALUE(REQUIRED) + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT TEXT AND NOT EXTRACT + QUALIFIER TEXT + QUALIFIER EDIT + DEFINE VERB PRINT + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER HEADER, DEFAULT + QUALIFIER NOTIFY, DEFAULT + QUALIFIER QUEUE, VALUE(DEFAULT=SYS$PRINT), NONNEGATABLE + QUALIFIER FORM, VALUE, NONNEGATABLE + QUALIFIER ALL + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB QUIT + DEFINE VERB READ + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$NUMBER) + QUALIFIER EDIT + QUALIFIER MARKED, NONNEGATABLE + QUALIFIER NEW + QUALIFIER PAGE, DEFAULT + QUALIFIER SINCE,VALUE(DEFAULT="TODAY",TYPE=$DATETIME) + DISALLOW NEW AND SINCE + DEFINE VERB REPLY + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER ALL, NONNEGATABLE + QUALIFIER BELL, NONNEGATABLE + QUALIFIER BROADCAST, NONNEGATABLE + DISALLOW NOT BROADCAST AND ALL + DISALLOW NOT BROADCAST AND BELL + QUALIFIER CLUSTER, DEFAULT + QUALIFIER EDIT, NEGATABLE + QUALIFIER EXPIRATION, NONNEGATABLE, VALUE + QUALIFIER EXTRACT, NONNEGATABLE + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER NODES, LABEL=NODES, VALUE(REQUIRED,LIST) + NONNEGATABLE + QUALIFIER LOCAL + DISALLOW LOCAL AND NOT BROADCAST + DISALLOW NODES AND SELECT_FOLDER + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT TEXT AND NOT EXTRACT + QUALIFIER PERMANENT, NONNEGATABLE + QUALIFIER SHUTDOWN, NONNEGATABLE, VALUE + DISALLOW PERMANENT AND SHUTDOWN + QUALIFIER SUBJECT, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER SYSTEM, NONNEGATABLE + QUALIFIER TEXT, NONNEGATABLE + DISALLOW (EXTRACT OR TEXT) AND FILESPEC + QUALIFIER USERNAME, LABEL=USERNAME, VALUE(REQUIRED) + NONNEGATABLE + DEFINE VERB REMOVE + PARAMETER P1, LABEL=REMOVE_FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + DEFINE VERB RESPOND + QUALIFIER CC, VALUE(LIST,REQUIRED) + QUALIFIER EXTRACT + QUALIFIER LIST + QUALIFIER SUBJECT, VALUE(REQUIRED) + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT TEXT AND NOT EXTRACT + QUALIFIER TEXT + QUALIFIER EDIT + DEFINE VERB SEARCH + PARAMETER P1, LABEL=SEARCH_STRING + QUALIFIER START, VALUE(TYPE=$NUMBER,REQUIRED) + QUALIFIER REVERSE + QUALIFIER SUBJECT + DEFINE VERB SELECT + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER MARKED, NONNEGATABLE + DEFINE VERB SET + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + QUALIFIER ID + DEFINE TYPE SET_OPTIONS + KEYWORD NODE, SYNTAX=SET_NODE + KEYWORD NONODE, SYNTAX = SET_NONODE + KEYWORD EXPIRE_LIMIT, SYNTAX=SET_EXPIRE + KEYWORD NOEXPIRE_LIMIT + KEYWORD GENERIC, SYNTAX=SET_GENERIC + KEYWORD NOGENERIC, SYNTAX=SET_GENERIC + KEYWORD LOGIN, SYNTAX=SET_LOGIN + KEYWORD NOLOGIN, SYNTAX=SET_LOGIN + KEYWORD NOBBOARD + KEYWORD BBOARD, SYNTAX=SET_BBOARD + KEYWORD NOBRIEF, SYNTAX=SET_NOFLAGS + KEYWORD BRIEF, SYNTAX=SET_FLAGS + KEYWORD NOSHOWNEW, SYNTAX=SET_NOFLAGS + KEYWORD SHOWNEW, SYNTAX=SET_FLAGS + KEYWORD NOREADNEW, SYNTAX=SET_NOFLAGS + KEYWORD READNEW, SYNTAX=SET_FLAGS + KEYWORD ACCESS, SYNTAX=SET_ACCESS + KEYWORD NOACCESS, SYNTAX=SET_NOACCESS + KEYWORD FOLDER, SYNTAX=SET_FOLDER + KEYWORD NOTIFY, SYNTAX=SET_FLAGS + KEYWORD NONOTIFY, SYNTAX=SET_NOFLAGS + KEYWORD PRIVILEGES, SYNTAX=SET_PRIVILEGES + KEYWORD DUMP + KEYWORD NODUMP + KEYWORD PAGE + KEYWORD NOPAGE + KEYWORD SYSTEM + KEYWORD NOSYSTEM + KEYWORD KEYPAD + KEYWORD NOKEYPAD + KEYWORD PROMPT_EXPIRE + KEYWORD NOPROMPT_EXPIRE + KEYWORD DEFAULT_EXPIRE, SYNTAX=SET_DEFAULT_EXPIRE + KEYWORD STRIP + KEYWORD NOSTRIP + KEYWORD DIGEST + KEYWORD NODIGEST + DEFINE SYNTAX SET_NODE + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=NODENAME, VALUE(REQUIRED) + PARAMETER P3, LABEL=REMOTENAME + QUALIFIER FOLDER, VALUE(REQUIRED) + DEFINE SYNTAX SET_NONODE + QUALIFIER FOLDER, VALUE(REQUIRED) + DEFINE SYNTAX SET_EXPIRE + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=EXPIRATION, VALUE(TYPE=$NUMBER,REQUIRED) + DEFINE SYNTAX SET_GENERIC + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=USERNAME, VALUE(REQUIRED) + QUALIFIER DAYS,VALUE(TYPE=$NUMBER,DEFAULT="7"),DEFAULT + DEFINE SYNTAX SET_LOGIN + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=USERNAME, VALUE(REQUIRED) + DEFINE SYNTAX SET_FLAGS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + QUALIFIER DEFAULT, NONNEGATABLE + QUALIFIER ALL, NONNEGATABLE + QUALIFIER CLUSTER, DEFAULT + QUALIFIER FOLDER, VALUE(REQUIRED) + DISALLOW NOT ALL AND NOT DEFAULT AND CLUSTER + DISALLOW ALL AND DEFAULT + DEFINE SYNTAX SET_NOFLAGS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + QUALIFIER DEFAULT, NONNEGATABLE + QUALIFIER ALL, NONNEGATABLE + QUALIFIER FOLDER, VALUE(REQUIRED) + DISALLOW ALL AND DEFAULT + DEFINE SYNTAX SET_BBOARD + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=BB_USERNAME + QUALIFIER EXPIRATION, VALUE(TYPE=$NUMBER) + LABEL=EXPIRATION, DEFAULT + QUALIFIER SPECIAL, NONNEGATABLE + QUALIFIER VMSMAIL, NONNEGATABLE + DISALLOW VMSMAIL AND NOT SPECIAL + DISALLOW VMSMAIL AND NOT BB_USERNAME + DEFINE SYNTAX SET_FOLDER + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=SELECT_FOLDER + QUALIFIER MARKED, NONNEGATABLE + DEFINE SYNTAX SET_NOACCESS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=ACCESS_ID, VALUE(LIST) + PARAMETER P3, LABEL=ACCESS_FOLDER + QUALIFIER ALL, NONNEGATABLE + QUALIFIER READONLY, NONNEGATABLE + DISALLOW NOT ALL AND NOT ACCESS_ID + DISALLOW ALL AND NOT READONLY + DEFINE SYNTAX SET_ACCESS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=ACCESS_ID, VALUE(LIST) + PARAMETER P3, LABEL=ACCESS_FOLDER + QUALIFIER READONLY, NONNEGATABLE + QUALIFIER ALL, NONNEGATABLE + DISALLOW NOT ALL AND NOT ACCESS_ID + DEFINE SYNTAX SET_PRIVILEGES + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=PRIVILEGES, PROMPT="Privileges" + VALUE (REQUIRED,LIST) + DEFINE SYNTAX SET_DEFAULT_EXPIRE + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=DEFAULT_EXPIRE, VALUE(TYPE=$NUMBER,REQUIRED) + DEFINE VERB SHOW + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) +! +! The following are defined to allow qualifiers to be specified +! directly after the SHOW command, i.e. SHOW/FULL FOLDER. +! Otherwise, the CLI routines will reject the command, because it +! first attempts to process the qualifier before process the parameter, +! so it has no information the qualifiers are valid. +! + QUALIFIER FULL, SYNTAX=SHOW_FOLDER_FULL, NONNEGATABLE + QUALIFIER ALL, SYNTAX=SHOW_USER + QUALIFIER LOGIN, SYNTAX=SHOW_USER + QUALIFIER NOLOGIN, SYNTAX=SHOW_USER + QUALIFIER PRINT, SYNTAX=SHOW_KEYPAD_PRINT + DEFINE TYPE SHOW_OPTIONS + KEYWORD FOLDER, SYNTAX=SHOW_FOLDER + KEYWORD NEW, SYNTAX=SHOW_FLAGS + KEYWORD PRIVILEGES, SYNTAX=SHOW_FLAGS + KEYWORD FLAGS, SYNTAX=SHOW_FLAGS + KEYWORD KEYPAD, SYNTAX=SHOW_KEYPAD + KEYWORD USER, SYNTAX=SHOW_USER + KEYWORD VERSION + DEFINE SYNTAX SHOW_FLAGS + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + DEFINE SYNTAX SHOW_KEYPAD + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + QUALIFIER PRINT + DEFINE SYNTAX SHOW_KEYPAD_PRINT + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + QUALIFIER PRINT,DEFAULT + DEFINE SYNTAX SHOW_FOLDER + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + PARAMETER P2, LABEL=SHOW_FOLDER + DEFINE SYNTAX SHOW_USER + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + PARAMETER P2, LABEL=USERNAME + QUALIFIER ALL + QUALIFIER LOGIN + QUALIFIER NOLOGIN + DISALLOW (NOLOGIN OR LOGIN OR ALL) AND USERNAME + DISALLOW (LOGIN AND NOLOGIN) + DEFINE SYNTAX SHOW_FOLDER_FULL + QUALIFIER FULL, DEFAULT + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + PARAMETER P2, LABEL=SHOW_FOLDER + DEFINE VERB MARK + PARAMETER P1, LABEL=NUMBER, VALUE(LIST,TYPE=$NUMBER) + DEFINE VERB SPAWN + PARAMETER P1, LABEL=COMMAND, VALUE(TYPE=$REST_OF_LINE) + DEFINE VERB UNMARK + PARAMETER P1, LABEL=NUMBER, VALUE(LIST,TYPE=$NUMBER) + DEFINE VERB UNDELETE + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) diff --git a/decus/vax90a/bulletin/bulletin.for b/decus/vax90a/bulletin/bulletin.for new file mode 100644 index 0000000..a1836a4 --- /dev/null +++ b/decus/vax90a/bulletin/bulletin.for @@ -0,0 +1,1436 @@ +C +C BULLETIN.FOR, Version 5/17/90 +C Purpose: Bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /POINT/ BULL_POINT + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING /.FALSE./ + + COMMON /CTRLY/ CTRLY + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + EXTERNAL ERROR_TRAP + EXTERNAL BULLETIN_SUBCOMMANDS,LIB$GET_INPUT + EXTERNAL BULLETIN_MAINCOMMANDS,ENABLE_CTRL_EXIT + EXTERNAL CLI$_ABSENT,CLI$_NOCOMD + + PARAMETER PCB$M_BATCH = '4000'X + PARAMETER PCB$M_NETWRK = '200000'X + PARAMETER LIB$M_CLI_CTRLY = '2000000'X + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER HELP_DIRECTORY*64,SAVE_FOLDER*25 + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + CALL LIB$ESTABLISH(ERROR_TRAP) + IF (.NOT.CLI$GET_VALUE('PROMPT',COMMAND_PROMPT,ILEN)) THEN + CALL LIB$GET_FOREIGN(INCMD) + CALL CLI$DCL_PARSE('BULLETIN '//INCMD,BULLETIN_MAINCOMMANDS) + CALL CLI$GET_VALUE('$LINE',COMMAND_PROMPT,ILEN) + END IF + CALL LIB$REVERT + + READIT = 0 + LOGIN_SWITCH = CLI$PRESENT('LOGIN') + SYSTEM_SWITCH = CLI$PRESENT('SYSTEM') + REVERSE_SWITCH = CLI$PRESENT('REVERSE') + + IER = LIB$SYS_TRNLOG('BULL_DISABLE',LEN_P,BULL_PARAMETER) + IF (IER.EQ.1.AND.LEN_P.GT.0.AND..NOT.CLI$PRESENT('STOP')) THEN + IF (.NOT.LOGIN_SWITCH) THEN + WRITE (6,'('' BULLETIN temporarily disabled. Try later.'')') + END IF + CALL EXIT + END IF + + CALL SYS$SETDFPROT(,ORIGINAL_DEF_PROT) + ! Save original default protection in case it gets changed + + CALL DCLEXH(%LOC(ENABLE_CTRL_EXIT)) ! Declare exit handler + +C +C Check to see if CONTROL Y disabled. If so, then never disable CONTROL Y. +C Disabling and enabling CONTROL Y is done so that a person can not break +C while one of the data files is opened, as that would not allow anyone +C else to modify the files. However, if CONTROL Y is already disabled, +C this is not necessary, and should not be done! +C + + CALL LIB$DISABLE_CTRL(LIB$M_CLI_CTRLY,CTRLY) ! Disable CTRL-Y & -C + CTRLY = CTRLY .AND. LIB$M_CLI_CTRLY + CALL GETPRIV ! Check privileges + CALL CHECK_PRIV_IO(ERR) ! Check privileges on output I/O + CALL LIB$ENABLE_CTRL(CTRLY,) ! Renable CTRLY-Y & -C + + IF (ERR.EQ.1) CALL EXIT ! I/O privilege error, so exit + + CALL GETUSER(USERNAME) ! Get the process's username + IF (.NOT.LOGIN_SWITCH) CALL CHECK_BULLETIN_PRIV(USERNAME) + ! Check if has bulletin privileges + + I = 1 ! Strip off folder name if specified + DO WHILE (I.LE.ILEN) + IF (COMMAND_PROMPT(I:I).EQ.' ') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + I = ILEN + 1 + ELSE + I = I + 1 + END IF + END DO + ILEN = 1 ! Get executable name to use as prompt + DO WHILE (ILEN.GT.0) + ILEN = MAX(INDEX(COMMAND_PROMPT,':'),INDEX(COMMAND_PROMPT,']')) + IF (ILEN.GT.0) THEN + COMMAND_PROMPT = COMMAND_PROMPT(ILEN+1:) + ELSE + DO I=TRIM(COMMAND_PROMPT),1,-1 + IF (COMMAND_PROMPT(I:I).LT.'A'.OR. + & COMMAND_PROMPT(I:I).GT.'Z') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + END IF + END DO + END IF + END DO + COMMAND_PROMPT = COMMAND_PROMPT(:TRIM(COMMAND_PROMPT))//'> ' + IF (COMMAND_PROMPT.EQ.'RUN> ') COMMAND_PROMPT = 'BULLETIN> ' + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + + CALL CLI$GET_VALUE('SEPARATE',SEPARATE) + + IF (CLI$PRESENT('EDIT')) EDIT_DEFAULT = .TRUE. ! /EDIT switch test + + CALL FIND_BULLCP ! See if BULLCP is running + + IF (CLI$PRESENT('CLEANUP')) THEN ! Test for /CLEANUP switch + CALL CLI$GET_VALUE('CLEANUP',BULL_PARAMETER,LEN_P) ! Get folder # + READ (BULL_PARAMETER,'(I)') FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + CALL EXIT ! all done with cleanup + ELSE IF (CLI$PRESENT('BBOARD')) THEN ! Test for /BBOARD switch + CALL BBOARD ! look for BBOARD mail + CALL EXIT ! all done with BBOARD + ELSE IF (CLI$PRESENT('STARTUP').OR. ! BULLCP process control + & CLI$PRESENT('STOP')) THEN + CALL CREATE_BULLCP + ELSE IF (CLI$PRESENT('BULLCP')) THEN ! This is BULLCP, so start + CALL RUN_BULLCP ! doing what BULLCP does! + END IF + + CALL GETSTS(STS) ! Get process status word + + IF (SYSTEM_SWITCH.OR.LOGIN_SWITCH) THEN ! If BULLETIN/LOGIN or /SYSTEM + IF ((STS.AND.PCB$M_BATCH).GT.0) CALL EXIT ! If BATCH, exit + CALL CRELNM('SYS$INPUT','TT') ! Take input from terminal + END IF + + IF ((STS.AND.PCB$M_NETWRK).EQ.0) THEN + DECNET_PROC = .FALSE. + ERROR_UNIT = 6 + + CALL ASSIGN_TERMINAL ! Assign terminal + + IF (.NOT.LOGIN_SWITCH) THEN + INCMD = 'SELECT' ! Causes nearest folder name to be selected + CALL SELECT_FOLDER(.FALSE.,IER) ! Select GENERAL folder + IF (.NOT.IER) RETURN ! If can't access, exit + + IF (.NOT.TEST_BULLCP()) CALL DELETE_EXPIRED + ! Delete expired messages + END IF + +C +C Get page size for the terminal. +C + + CALL GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) + + IF (CLI$PRESENT('PAGE')) PAGING = .TRUE. + + IF (SYSTEM_SWITCH) THEN + IER = CLI$GET_VALUE('SYSTEM',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Days specified? + CALL SUBTIME(SYSTEM_LOGIN_BTIM,BULL_PARAMETER(:LEN_P),IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Invalid parameter in /SYSTEM.'')') + CALL EXIT + END IF + END IF + IF (.NOT.LOGIN_SWITCH) THEN + CALL MODIFY_SYSTEM_LIST(0) + CALL SHOW_SYSTEM + CALL EXIT + END IF + END IF + +C +C Get user info stored in SYS$LOGIN. Currently, this simply stores +C the time of the latest message read for each folder. +C + + CALL OPEN_USERINFO + +C +C If /LOGIN, display SYSTEM bulletins and subject of non-SYSTEM bulletins. +C + + IF (LOGIN_SWITCH.OR.SYSTEM_SWITCH) THEN ! Is /LOGIN present? + CALL LOGIN ! Display SYSTEM bulletins + IF (READIT.EQ.0) CALL EXIT ! If no READNEWs not set, exit + END IF + +C +C If new bulletins have been added since the last time bulletins have been +C read, position bulletin pointer so that next bulletin read is the first new +C bulletin, and alert user. If READNEW set and no new bulletins, just exit. +C + + CALL NEW_MESSAGE_NOTIFICATION + + CALL OPEN_OLD_TAG + + ELSE + IF (TEST_BULLCP()) CALL EXIT + DECNET_PROC = .TRUE. + ERROR_UNIT = 5 + END IF + +C +C The MAIN loop for processing bulletin commands. +C + + DIR_COUNT = 0 ! # directory entry to continue bulletin read from + READ_COUNT = 0 ! # block that bulletin READ is to continue from + FOLDER_COUNT = 0 ! # folder entry to continue SHOW/ALL folder from + INDEX_COUNT = 0 + + IER = LIB$SYS_TRNLOG('BULL_HELP',HLEN,HELP_DIRECTORY) + IF (IER.NE.1) THEN + HELP_DIRECTORY = 'SYS$HELP:' + HLEN = 9 + ELSE IF (HELP_DIRECTORY(HLEN:HLEN).NE.':'.AND. + & HELP_DIRECTORY(HLEN:HLEN).NE.']') THEN + HELP_DIRECTORY = HELP_DIRECTORY(:HLEN)//':' + HLEN = HLEN + 1 + END IF + + DO WHILE (1) + + CALL GET_INPUT_PROMPT(INCMD,IER, + & CHAR(10)//COMMAND_PROMPT(:TRIM(COMMAND_PROMPT)+1)) + + IF (IER.EQ.-2) THEN + IER = RMS$_EOF + ELSE IF (IER.LE.0) THEN + IER = %LOC(CLI$_NOCOMD) + ELSE + DO WHILE (IER.GT.0.AND.INCMD(:1).EQ.' ') + INCMD = INCMD(2:IER) + IER = IER - 1 + END DO + DO WHILE (IER.GT.0.AND. + & INCMD(IER:IER).GE.'0'.AND.INCMD(IER:IER).LE.'9') + IER = IER - 1 + END DO + IF (IER.EQ.0) INCMD = 'READ '//INCMD + IER=CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS,LIB$GET_INPUT) + END IF + + IF (IER.EQ.RMS$_EOF) THEN + GO TO 999 ! If no command, exit + ELSE IF (IER.EQ.%LOC(CLI$_NOCOMD)) THEN ! If just RETURN entered + LEN_P = 0 ! Indicate no parameter in command + IF (DIR_COUNT.GT.0) THEN ! If still more dir entries + CALL DIRECTORY(DIR_COUNT) ! continue outputting them + ELSE IF (INDEX_COUNT.GT.0) THEN + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (FOLDER_COUNT.GT.0) THEN ! If more folder entries + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! continue outputting them + ELSE ! Else try to read next bulletin + CALL READ(READ_COUNT,BULL_POINT+1) ! or finish old one + END IF + GO TO 100 ! Loop to read new command + ELSE IF (.NOT.IER) THEN ! If command has error + GO TO 100 ! ask for new command + END IF + + DIR_COUNT = 0 ! Reinit display pointers + READ_COUNT = 0 + FOLDER_COUNT = 0 + INDEX_COUNT = 0 + + IER = MIN(INDEX(INCMD(:TRIM(INCMD)),' '),INDEX(INCMD,'/')) + IF (IER.GT.0) INCMD = ' '//INCMD(IER:) ! Save qualifiers + CALL CLI$GET_VALUE('$VERB',INCMD(:4)) ! Get user's command. + IF (READ_ONLY.AND.(INCMD(:3).EQ.'ADD'.OR.INCMD(:3).EQ.'DEL' + & .OR.INCMD(:3).EQ.'CHA'.OR.INCMD(:3).EQ.'REP')) THEN + ! FOLDER can only be read? + WRITE (6,'('' ERROR: Access to folder limited to reading.'')') + ELSE IF (INCMD(:3).EQ.'ADD') THEN ! ADD? + CALL ADD + ELSE IF (INCMD(:4).EQ.'BACK') THEN ! BACK? + IF (BULL_POINT.LE.1) THEN + WRITE(6,1060) + ELSE + CALL READ(READ_COUNT,BULL_POINT-1) ! Try to read previous bull + END IF + ELSE IF (INCMD(:4).EQ.'CHAN') THEN ! CHANGE? + CALL REPLACE ! Replace old bulletin + ELSE IF (INCMD(:4).EQ.'COPY') THEN ! COPY? + CALL MOVE(.FALSE.) + ELSE IF (INCMD(:4).EQ.'CREA') THEN ! CREATE? + CALL CREATE_FOLDER ! Go create the folder + ELSE IF (INCMD(:4).EQ.'CURR') THEN ! CURRENT? + READ_COUNT = -1 ! Reread current message from beginning. + CALL READ(READ_COUNT,BULL_POINT) + ELSE IF (INCMD(:4).EQ.'DELE') THEN ! DELETE? + CALL DELETE ! Go delete bulletin + ELSE IF (INCMD(:4).EQ.'DIRE') THEN ! DIRECTORY? + IF (CLI$PRESENT('FOLDER')) THEN ! /FOLDER specified? + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! Show all folders + ELSE IF (CLI$PRESENT('SELECT_FOLDER')) THEN! Folder specified? + CALL SELECT_FOLDER(.TRUE.,IER) ! Try to select folder + IF (IER) THEN ! If successful + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE IF (INCMD(:4).EQ.'FILE'.OR. + & INCMD(:4).EQ.'EXTR') THEN ! FILE? + CALL FILE ! Copy bulletin to file + ELSE IF (INCMD(:1).EQ.'E'.OR. + & INCMD(:4).EQ.'QUIT') THEN ! EXIT? + GO TO 999 ! Exit from program + ELSE IF (INCMD(:4).EQ.'HELP') THEN ! HELP? + CALL HELP(HELP_DIRECTORY(:HLEN)//'BULL.HLB') ! Get help + ELSE IF (INCMD(:3).EQ.'IND') THEN ! INDEX? + INDEX_COUNT = 1 + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (INCMD(:4).EQ.'LAST') THEN ! LAST? + READ_COUNT = -1 + BULL_READ = 99999 + CALL READ(READ_COUNT,BULL_READ) + ELSE IF (INCMD(:4).EQ.'MARK') THEN ! MARK? + CALL TAG(.TRUE.) + ELSE IF (INCMD(:4).EQ.'MAIL') THEN ! MAIL? + CALL MAIL(MAIL_STATUS) + ELSE IF (INCMD(:3).EQ.'MOD') THEN ! MODIFY? + CALL MODIFY_FOLDER + ELSE IF (INCMD(:4).EQ.'MOVE') THEN ! MOVE? + CALL MOVE(.TRUE.) + ELSE IF (INCMD(:4).EQ.'NEXT') THEN ! NEXT? + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + ELSE IF (INCMD(:4).EQ.'POST') THEN ! POST? + CALL RESPOND(MAIL_STATUS) + ELSE IF (INCMD(:4).EQ.'PRIN') THEN ! PRINT? + CALL PRINT ! Printout bulletin + ELSE IF (INCMD(:4).EQ.'READ') THEN ! READ? + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Bulletin specified? + DECODE(LEN_P,'(I)',BULL_PARAMETER) BULL_READ ! Yes + READ_COUNT = -1 + CALL READ(READ_COUNT,BULL_READ) + ELSE + CALL READ(READ_COUNT,BULL_POINT+1) + END IF + ELSE IF (INCMD(:3).EQ.'REM') THEN ! REMOVE? + CALL REMOVE_FOLDER + ELSE IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + CALL REPLY + ELSE IF (INCMD(:3).EQ.'RES') THEN ! RESPOND? + CALL RESPOND(MAIL_STATUS) + ELSE IF (INCMD(:3).EQ.'SEA') THEN ! SEARCH? + CALL SEARCH(READ_COUNT) + ELSE IF (INCMD(:3).EQ.'SEL') THEN ! SELECT? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (INCMD(:3).EQ.'SET') THEN ! SET? + CALL CLI$GET_VALUE('SET_PARAM1',BULL_PARAMETER) + IF (BULL_PARAMETER(:1).EQ.'F') THEN ! SET FOLDER? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRI') THEN ! SET PRIVS? + CALL SET_PRIV + ELSE IF (BULL_PARAMETER(:2).EQ.'PA') THEN ! SET PAGE? + PAGING = .TRUE. + WRITE (6,'('' PAGE has been set.'')') + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SET KEYPAD? + CALL SET_KEYPAD + ELSE IF (BULL_PARAMETER(:3).EQ.'NOK') THEN ! SET NOKEYPAD? + CALL SET_NOKEYPAD + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPA') THEN ! SET NOPAGE? + PAGING = .FALSE. + WRITE (6,'('' NOPAGE has been set.'')') + ELSE IF (FOLDER_NUMBER.EQ.-1) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + ELSE IF (BULL_PARAMETER(:2).EQ.'SY') THEN ! SET SYSTEM? + CALL SET_SYSTEM(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOSY') THEN ! SET NOSYSTEM? + CALL SET_SYSTEM(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'BB') THEN ! SET BBOARD? + CALL SET_BBOARD(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBB') THEN ! SET NOBBOARD? + CALL SET_BBOARD(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'DU') THEN ! SET DUMP? + CALL SET_FOLDER_FLAG(.TRUE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODU') THEN ! SET NODUMP? + CALL SET_FOLDER_FLAG(.FALSE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:2).EQ.'ST') THEN ! SET STRIP? + CALL SET_FOLDER_FLAG(.TRUE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOST') THEN ! SET NOSTRIP? + CALL SET_FOLDER_FLAG(.FALSE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:2).EQ.'DI') THEN ! SET DIGEST? + CALL SET_FOLDER_FLAG(.TRUE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODI') THEN ! SET NODIGEST? + CALL SET_FOLDER_FLAG(.FALSE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOTI') THEN ! SET NOTIFY? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(1,-1,-1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(1,-2,-2) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(1,4) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'E') THEN ! SET EXPIRE? + IER = CLI$GET_VALUE('EXPIRATION',BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.3) THEN + READ (BULL_PARAMETER,'(I)') LIMIT + CALL SET_FOLDER_EXPIRE_LIMIT(LIMIT) + ELSE + WRITE (6,'('' ERROR: Invalid expiration specified.'')') + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NODE') THEN ! SET NODE? + CALL SET_NODE(.TRUE.) + ELSE IF (BULL_PARAMETER(:6).EQ.'NONODE') THEN ! SET NONODE? + CALL SET_NODE(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOE') THEN ! SET NOEXPIRE? + CALL SET_FOLDER_EXPIRE_LIMIT(0) + ELSE IF (BULL_PARAMETER(:5).EQ.'NONOT') THEN ! SET NONOTIFY? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(0,-1,-1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(0,-2,-2) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,4) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'S') THEN ! SET SHOWNEW? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET SHOWNEW not allowed for GENERAL folder.'')') + ELSE IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,1) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(1,3) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOS') THEN ! SET NOSHOWNEW? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET NOSHOWNEW not allowed for GENERAL folder.'')') + ELSE IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(0,3) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'R') THEN ! SET READNEW? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,1,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,1,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(1,2) + CALL CHANGE_FLAG(0,3) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOR') THEN ! SET NOREADNEW? + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(0,3) + END IF + ELSE IF (BULL_PARAMETER(:2).EQ.'BR') THEN ! SET BRIEF? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET BRIEF not allowed for GENERAL folder.'')') + ELSE + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,1,1) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,1,1) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(1,2) + CALL CHANGE_FLAG(1,3) + END IF + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBR') THEN ! SET NOBRIEF? + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'( + & '' ERROR: SET NOBRIEF not allowed for GENERAL folder.'')') + ELSE + IF (CLI$PRESENT('DEFAULT')) THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE IF (CLI$PRESENT('ALL')) THEN + IF (SETPRV_PRIV()) THEN + CALL SET_FOLDER_DEFAULT(-2,0,0) + ELSE + WRITE (6,'('' ERROR: /ALL is a privileged command.'')') + END IF + ELSE + CALL CHANGE_FLAG(0,2) + CALL CHANGE_FLAG(0,3) + END IF + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'A') THEN ! SET ACCESS? + CALL SET_ACCESS(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOA') THEN ! SET NOACCESS? + CALL SET_ACCESS(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'G') THEN ! SET GENERIC? + CALL SET_GENERIC(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOG') THEN ! SET NOGENERIC? + CALL SET_GENERIC(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'L') THEN ! SET LOGIN? + CALL SET_LOGIN(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOL') THEN ! SET NOLOGIN? + CALL SET_LOGIN(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRO') THEN ! SET PROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.FALSE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPR') THEN ! SET NOPROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.TRUE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:3).EQ.'DEF') THEN ! SET DEFAULT_EXPIRE? + CALL SET_DEFAULT_EXPIRE + END IF + ELSE IF (INCMD(:4).EQ.'SHOW') THEN ! SHOW? + CALL CLI$GET_VALUE('SHOW_PARAM1',BULL_PARAMETER,LEN_P) + IF (BULL_PARAMETER(:2).EQ.'FL') THEN ! SHOW FLAGS? + CALL SHOW_FLAGS + ELSE IF (BULL_PARAMETER(:2).EQ.'FO') THEN ! SHOW FOLDER? + CALL SHOW_FOLDER + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SHOW KEYPAD + CALL SHOW_KEYPAD(HELP_DIRECTORY(:HLEN)//'BULL.HLB') + ELSE IF (BULL_PARAMETER(:1).EQ.'N') THEN ! SHOW NEW? + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + SAVE_FOLDER = FOLDER + DO FOLDER_NUMBER = 0,FOLDER_MAX-1 + IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + CALL SELECT_FOLDER(.FALSE.,IER) + IF (NBULL.GT.0) THEN + DIFF = COMPARE_BTIM( + & LAST_READ_BTIM(1,FOLDER_NUMBER+1),F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN + WRITE (6,'('' There are new messages in folder '' + & ,A,''.'')') FOLDER(:TRIM(FOLDER)) + END IF + END IF + END IF + END DO + FOLDER1 = SAVE_FOLDER + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE IF (BULL_PARAMETER(:1).EQ.'P') THEN ! SHOW PRIVILEGES? + CALL SHOW_PRIV + ELSE IF (BULL_PARAMETER(:1).EQ.'U') THEN ! SHOW USER? + CALL SHOW_USER + ELSE IF (BULL_PARAMETER(:1).EQ.'V') THEN ! SHOW VERSION? + CALL SHOW_VERSION + END IF + ELSE IF (INCMD(:4).EQ.'SPAW') THEN ! SPAWN command? + CALL SPAWN_PROCESS + ELSE IF (INCMD(:4).EQ.'UNDE') THEN ! UNDELETE? + CALL UNDELETE + ELSE IF (INCMD(:3).EQ.'UNM') THEN ! UNMARK? + CALL TAG(.FALSE.) + END IF + +100 CONTINUE + + END DO + +999 CALL EXIT + +1010 FORMAT(Q,A) +1060 FORMAT(' ERROR: There are no more messages.') + + END + + + + + + SUBROUTINE ADD +C +C SUBROUTINE ADD +C +C FUNCTION: Adds bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER INEXDATE*11,INEXTIME*11 + CHARACTER*(LINE_LENGTH) INDESCRIP + + CHARACTER INLINE*80,OLD_FOLDER*25,LOCAL_NODE*8 + CHARACTER PASSWORD*31,DEFAULT_USER*12 + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + IF (CLI$PRESENT('TEXT').OR.CLI$PRESENT('EXTRACT')) THEN + IF (.NOT.((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If no /EDIT + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)))) THEN + WRITE (6,'('' ERROR: Cannot extract text without /EDIT.'')') + RETURN + END IF + END IF + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + ALLOW = SETPRV_PRIV() + + OLD_FOLDER_NUMBER = FOLDER_NUMBER + OLD_FOLDER = FOLDER + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (.NOT.ALLOW) THEN ! If no SETPRV privileges, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD',READONLY, + & SHARED,ERR=920,FORM='FORMATTED') ! Try opening the file + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + ELSE IF (CLI$PRESENT('TEXT').OR.CLI$PRESENT('EXTRACT')) THEN + BULL_PARAMETER = 'SYS$LOGIN:BULL.SCR' + LEN_P = TRIM(BULL_PARAMETER) + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH, + & STATUS='NEW',CARRIAGECONTROL='LIST',FORM='FORMATTED') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + +90 CALL CLOSE_BULLFIL + END IF + + SELECT_FOLDERS = .FALSE. + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL GET_FOLDER_INFO(IER) + IF (.NOT.IER) GO TO 910 + SELECT_FOLDERS = .TRUE. + ELSE + NODE_NUM = 1 + NODES(1) = OLD_FOLDER + END IF + + IER = CLI$GET_VALUE('USERNAME',DEFAULT_USER) + IF (.NOT.IER) DEFAULT_USER = USERNAME + IF (DECNET_PROC) THEN ! Running via DECNET? + USERNAME = DEFAULT_USER + CALL CONFIRM_PRIV(USERNAME,ALLOW) + END IF + + IF (FOLDER_NUMBER.GT.0.AND. ! If folder set and + & CLI$PRESENT('NODES')) THEN ! Decnet nodes specified? + WRITE (6,'('' ERROR: /NODES cannot be used with folder set.'')') + GO TO 910 + END IF + + IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0.AND. + & (CLI$PRESENT('SYSTEM').OR. ! Is /SYSTEM switch present? + & CLI$PRESENT('BROADCAST').OR. ! Is /BROADCAST swtich present? + & CLI$PRESENT('SHUTDOWN'))) THEN ! Is /SHUTDOWN switch present? + WRITE (6,'('' ERROR: Folder is not a SYSTEM folder.'')') + GO TO 910 + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN ! Is /SYSTEM switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1070) ! Tell user + GO TO 910 ! and abort + END IF + SYSTEM = 1 ! Set system bit + ELSE + SYSTEM = 0 ! Clear system bit + END IF + + IF (CLI$PRESENT('BROADCAST')) THEN ! Is /BROADCAST switch present? + IF (.NOT.(ALLOW.OR.OPER_PRIV())) THEN ! If no privileges + WRITE(ERROR_UNIT,1080) ! Tell user + GO TO 910 ! and abort + END IF + END IF + + IF (CLI$PRESENT('PERMANENT')) THEN ! Is /PERMANENT switch present? + IF (.NOT.ALLOW.AND..NOT.FOLDER_SET) THEN ! If no privileges + WRITE(ERROR_UNIT,1081) ! Tell user + GO TO 910 ! and abort + ELSE IF (F_EXPIRE_LIMIT.GT.0.AND..NOT.ALLOW ! Expiration limit + & .AND.USERNAME.NE.FOLDER_OWNER) THEN ! is present + WRITE(ERROR_UNIT,1083) + GO TO 910 + ELSE + SYSTEM = SYSTEM.OR.2 ! Set permanent bit + INEXDATE = '5-NOV-2000' + INEXTIME = '00:00:00.00' + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN ! Is /SHUTDOWN switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1082) ! Tell user + GO TO 910 ! and abort + ELSE + IER = CLI$GET_VALUE('SHUTDOWN',INLINE) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (REMOTE_SET) THEN ! Can't specify node name if + WRITE (6,1090) ! remote folder, as no code + GO TO 910 ! present to send the name. + END IF + CALL GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,INLINE) + IF (NODE_AREA.EQ.0) GO TO 910 ! Invalid node name + ELSE + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + END IF + SYSTEM = SYSTEM.OR.4 ! Set shutdown bit + INEXDATE = '5-NOV-2000' + WRITE (INEXTIME,'(I4)') NODE_NUMBER + WRITE (INEXTIME(7:),'(I4)') NODE_AREA + DO I=1,11 + IF (INEXTIME(I:I).EQ.' ') INEXTIME(I:I) = '0' + END DO + INEXTIME = INEXTIME(1:2)//':'//INEXTIME(3:4)//':'// + & INEXTIME(7:8)//'.'//INEXTIME(9:10) + END IF + END IF + + SELECT_NODES = .FALSE. + IF (CLI$PRESENT('NODES')) THEN + CALL GET_NODE_INFO + IF (NODE_ERROR) GO TO 940 + SELECT_NODES = .TRUE. + END IF + + IF (SYSTEM.LE.1) THEN ! Not permanent or shutdown + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + + IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + INDESCRIP = DESCRIP ! Use description with RE:, + LENDES = TRIM(INDESCRIP) ! filled in by main subroutine + ELSE IF (CLI$PRESENT('SUBJECT')) THEN ! /SUBJECT specified + CALL CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + ELSE + WRITE(6,1050) ! Request header for bulletin + CALL GET_LINE(INDESCRIP,LENDES) ! Get input line + IF (LENDES.LE.0) GO TO 910 + END IF + + LENDES = MIN(LEN(INDESCRIP)-6,LENDES) ! Make room for "Subj: " + +C +C If file specified in ADD command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + IF (LEN_P.EQ.0) THEN ! If no file param specified + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + LEN_P = 1 + ELSE + CLOSE (UNIT=3) + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + END IF + END IF + + ICOUNT = 0 ! Line count for bulletin + + IF (LEN_P.GT.0) THEN ! If file param in ADD command + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + ICOUNT = ICOUNT + 1 + MIN(ILEN,80) + IF (ILEN.EQ.0) ICOUNT = ICOUNT + 1! COPY_BULL writes line with + END DO ! 1 space for blank line + ELSE ! If no input file + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) ! Temp file to save message + WRITE (6,1000) ! Request input from terminal + ILEN = LINE_LENGTH + 1 ! Length of input line + ICOUNT = 0 ! Character count counter + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Input line too long + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput:'')') LINE_LENGTH + ELSE IF (ILEN.GE.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN ! Update counter + WRITE(3,2010) INPUT(:ILEN) ! Save line in scratch file + END IF + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + REWIND (UNIT=3) + + IF (SELECT_NODES.AND.NODE_NUM.GT.0) THEN + INLINE = 'ADD' + IF (CLI$PRESENT('SYSTEM')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SYSTEM' + IF (CLI$PRESENT('BROADCAST')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BROADCAST' + IF (CLI$PRESENT('PERMANENT')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/PERMANENT' + IF (CLI$PRESENT('SHUTDOWN')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SHUTDOWN' + IF (CLI$PRESENT('BELL')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BELL' + + LEN_INLINE = STR$POSITION(INLINE,' ') - 1 + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + INLINE = INLINE(:LEN_INLINE) + SEMI = INDEX(NODES(POINT_NODE),'::') ! Look for semicolons + ILEN = TRIM(NODES(POINT_NODE)) ! Length of node name + IF (SEMI.GT.0) THEN ! Are semicolon found? + IF (ILEN.GT.SEMI+1) THEN ! Is username found? + TEMP_USER = NODES(POINT_NODE)(SEMI+2:) ! Yes + ILEN = SEMI - 1 ! Remove semicolons + ELSE ! No username found... + TEMP_USER = DEFAULT_USER ! Set user to default + ILEN = SEMI - 1 ! Remove semicolons + SEMI = 0 ! Indicate no username + END IF + ELSE ! No semicolons present + TEMP_USER = DEFAULT_USER ! Set user to default + END IF + IER = 1 + DO WHILE ((INLINE.NE.'ADD'.OR.SEMI.GT.0.OR. + & CLI$PRESENT('USERNAME')).AND.IER.NE.0) + WRITE(6,'('' Enter password for node '',2A)') + & NODES(POINT_NODE),CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) GO TO 910 + OPEN (UNIT=10+NODE_NUM,NAME=NODES(POINT_NODE)(:ILEN)// + & '"'//TEMP_USER(:TRIM(TEMP_USER))//' '// + & PASSWORD(:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10+NODE_NUM) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + END IF + END DO + INLINE = INLINE(:STR$POSITION(INLINE,' ')-1) + & //'/USERNAME='//TEMP_USER + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + IF (SYSTEM.LE.1) ! If not permanent or shutdown specify date + & WRITE (POINT_NODE+9,'(A)',ERR=940) INEXDATE//' '//INEXTIME + WRITE (POINT_NODE+9,'(A)',ERR=940) INDESCRIP(:LENDES) + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + ILEN = MIN(ILEN,LINE_LENGTH) + IF (IER.EQ.0) THEN + WRITE (POINT_NODE+9,'(A)',ERR=940) INPUT(:ILEN) + END IF + END DO + WRITE (POINT_NODE+9,'(A)',ERR=940) CHAR(26) + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INPUT + IF (INPUT.EQ.'END') THEN + WRITE (6,'('' Message successfully sent to node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while sending message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INPUT(:80) + GO TO 940 + END IF + REWIND (UNIT=3) + END DO + END IF + + IF (SELECT_NODES.AND..NOT.LOCAL_NODE_FOUND) GO TO 95 + ! Exit if local node not specified. + + IF (.NOT.SELECT_FOLDERS) THEN + NODE_NUM = 1 ! No folders specified so just + NODES(1) = FOLDER ! add to select folder + END IF + + IER = SYS_TRNLNM('SYS$NODE',LOCAL_NODE) + LNODE = TRIM(LOCAL_NODE) + LUSER = TRIM(USERNAME) + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + BRDCST = .FALSE. + + DO I = 1,NODE_NUM + + IF (FOLDER.NE.NODES(I)) THEN + FOLDER_NUMBER = -1 + FOLDER1 = NODES(I) + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE + IER = 1 + END IF + + IF (IER) THEN + CALL OPEN_BULLDIR ! Prepare to add dir entry + + DESCRIP=INDESCRIP(:LENDES) ! Description header + EXDATE=INEXDATE ! Expiration date + EXTIME=INEXTIME + FROM = USERNAME ! Username + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + REWIND (UNIT=3) + OBLOCK = NBLOCK+1 + CALL STORE_BULL(LNODE+LUSER+6,'From: '// + & LOCAL_NODE(:LNODE)//USERNAME(:LUSER),OBLOCK) + IF (LENDES.GT.LEN(DESCRIP)) THEN + CALL STORE_BULL(LENDES+6, + & 'Subj: '//INDESCRIP(:LENDES),OBLOCK) + END IF + CALL COPY_BULL(3,1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) GO TO 930 ! Error in creating bulletin + LENGTH = OCOUNT - (NBLOCK+1) + 1 +C +C Broadcast the bulletin if requested. +C + IF (.NOT.BRDCST.AND.CLI$PRESENT('BROADCAST').AND. + & (.NOT.REMOTE_SET.OR.FOLDER_NUMBER.GT.0)) THEN + CALL GET_BROADCAST_MESSAGE(CLI$PRESENT('BELL')) + BRDCST = .TRUE. + IF (.NOT.CLI$PRESENT('LOCAL')) THEN + CALL BROADCAST_ALL_NODES(CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER')) + END IF + CALL BROADCAST( + & CLI$PRESENT('ALL'),CLI$PRESENT('CLUSTER')) + END IF + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CALL ADD_ENTRY ! Add the new directory entry + + IF (FOLDER_NUMBER.GE.0) THEN + CALL UPDATE_FOLDER ! Update info in folder file +C +C If user is adding message, update that user's last read time for +C folder, so user is not alerted of new message which is owned by user. +C + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + ELSE + WRITE (6,'('' ERROR: Unable to add message to '',A)') + & NODES(I) + END IF + END DO + +95 CLOSE (UNIT=3) ! Close the input file + IF (DECNET_PROC) WRITE(5,'(''END'')') ! DECNET operation worked + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + DO I=10,NODE_NUM+9 + CLOSE (UNIT=I) + END DO + + IF (FOLDER_NUMBER.NE.OLD_FOLDER_NUMBER) THEN + FOLDER_NUMBER = OLD_FOLDER_NUMBER + FOLDER1 = OLD_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + + IF (CLI$PRESENT('TEXT').OR.CLI$PRESENT('EXTRACT')) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + +910 WRITE(ERROR_UNIT,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(6,1020) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + GOTO 100 + +930 WRITE (ERROR_UNIT,1025) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + +940 WRITE (6,1015) NODES(POINT_NODE) + WRITE (6,1018) + CLOSE (UNIT=3) + GO TO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1010 FORMAT (' No message was added.') +1015 FORMAT (' ERROR: Unable to reach node ',A) +1018 FORMAT (' Try using /FOLDER instead of /NODE.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1025 FORMAT (' ERROR: Unable to add message to file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1070 FORMAT (' ERROR: SETPRV privileges are needed for system + & messages.') +1080 FORMAT (' ERROR: SETPRV privileges are needed to broadcast + & messages.') +1081 FORMAT (' ERROR: SETPRV privileges are needed to permanent + & messages.') +1082 FORMAT (' ERROR: SETPRV privileges are needed to shutdown + & messages.') +1083 FORMAT (' ERROR: Folder has expiration limit.') +1090 FORMAT (' ERROR: Nodename cannot be specified for shutdown + & if folder is remote.') +2010 FORMAT(A) +2020 FORMAT(1X,A) + + END + + + SUBROUTINE SUBTIME(BTIM,DAYS_BEFORE_TODAY,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER DAYS_BEFORE_TODAY*(*),TODAY_DATE*23 + + INTEGER BTIM(2),TODAY_BTIM(2) + + IER = SYS$BINTIM(DAYS_BEFORE_TODAY,BTIM) + IF (.NOT.IER) RETURN + + BTIM(1) = -BTIM(1) ! Convert to negative delta time + BTIM(2) = -BTIM(2)-1 + + IER = SYS$ASCTIM(TLEN,TODAY_DATE,,) + CALL SYS$BINTIM(TODAY_DATE(:TLEN),TODAY_BTIM) + + CALL LIB$SUBX(TODAY_BTIM,BTIM,BTIM) + + RETURN + END + + + + SUBROUTINE BROADCAST_ALL_NODES(ALL,CLUSTER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + COMMON /BROAD_MESSAGE/ BMESSAGE,BLENGTH + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER LOCALNODE*8,RESPONSE*1 + + IF (.NOT.TEST_BULLCP().OR.REMOTE_SET) RETURN + + CALL OPEN_BULLUSER_SHARED + + REMOTE_FOUND = .FALSE. + TEMP_USER = ':' + + DO WHILE (.NOT.REMOTE_FOUND) + DO WHILE (REC_LOCK(IER)) + READ (4,KEYGT=TEMP_USER,IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM,NEW_FLAG + END DO + IF (TEMP_USER(:1).NE.':') THEN + CALL CLOSE(4) + RETURN + END IF + REMOTE_FOUND = TEST2(NEW_FLAG,FOLDER_NUMBER) + END DO + + CALL CLOSE (4) + +100 OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=NODENAME(:TRIM(NODENAME))//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IER = 0 + I = 1 + DO WHILE (IER.EQ.0.AND.I.LT.BLENGTH) + WRITE (17,'(4A)',IOSTAT=IER) + & 15,-1,I,BMESSAGE(I:MIN(BLENGTH,I+127)) + I = I + 128 + END DO + IF (IER.EQ.0) WRITE (17,'(7A)',IOSTAT=IER) + & 15,BLENGTH,I,ALL,CLUSTER,FOLDER_NUMBER,FOLDER + ELSE + WRITE (6,'('' BULLCP not responding to request to'', + & '' broadcast to other nodes.'')') + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Want to try again? (Y/N with Y as default): ') + IF (RESPONSE.NE.'n'.AND.RESPONSE.NE.'N') THEN + WRITE (6,'('' Trying again...'')') + GO TO 100 + ELSE + WRITE (6,'('' Broadcast aborting. '', + & ''Continuing with message addition.'')') + END IF + END IF + + CLOSE (UNIT=17) + + RETURN + END + + + + + INTEGER FUNCTION ERROR_TRAP + + ERROR_TRAP = 1 + + RETURN + END + + + + SUBROUTINE REPLY + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLDIR.INC' + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + WRITE (6,'('' Adding REPLY message with the subject:'')') + CALL STR$UPCASE(BULL_PARAMETER,DESCRIP) + IF (BULL_PARAMETER(:3).NE.'RE:') THEN + DESCRIP = 'RE: '//DESCRIP + ELSE + DESCRIP = 'RE:'//DESCRIP(4:) + END IF + WRITE (6,'(1X,A)') DESCRIP + CALL ADD + + RETURN + END + + + + + SUBROUTINE CRELNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PSLDEF)' + + INCLUDE '($LNMDEF)' + + CHARACTER*(*) INPUT,OUTPUT + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT)) + CALL END_ITMLST(CRELNM_ITMLST) + + IER = SYS$CRELNM(,'LNM$PROCESS',INPUT,PSL$C_USER, + & %VAL(CRELNM_ITMLST)) + + RETURN + END + + + + SUBROUTINE GETPRIV +C +C SUBROUTINE GETPRIV +C +C FUNCTION: +C To get process privileges. +C OUTPUTS: +C PROCPRIV - Returned privileges +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /REALPROC/ REALPROCPRIV(2) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(8,JPI$_PROCPRIV,%LOC(PROCPRIV)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + REALPROCPRIV(1) = PROCPRIV(1) + REALPROCPRIV(2) = PROCPRIV(2) + + RETURN + END + + + + + LOGICAL FUNCTION SETPRV_PRIV + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + DATA NEEDPRIV/0,0/ + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (NEEDPRIV(1).EQ.0.AND.NEEDPRIV(2).EQ.0) THEN + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + CALL CLOSE_BULLUSER + NEEDPRIV(1) = USERPRIV(1) + NEEDPRIV(2) = USERPRIV(2) + END IF + + IF ((PROCPRIV(1).AND.NEEDPRIV(1)).GT.0.OR. + & (PROCPRIV(2).AND.NEEDPRIV(2)).GT.0) THEN + SETPRV_PRIV = .TRUE. + ELSE + SETPRV_PRIV = .FALSE. + END IF + + RETURN + END + + + + LOGICAL FUNCTION OPER_PRIV + IMPLICIT INTEGER (A-Z) + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + INCLUDE '($PRVDEF)' + OPER_PRIV = BTEST(PROCPRIV(1),PRV$V_OPER) + RETURN + END + + + + SUBROUTINE GETUSER(USERNAME) +C +C SUBROUTINE GETUSER +C +C FUNCTION: +C To get username of present process. +C OUTPUTS: +C USERNAME - Username owner of present process. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + CHARACTER*(*) USERNAME ! Limit is 12 characters + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + RETURN + END + + + SUBROUTINE SPAWN_PROCESS + + IMPLICIT INTEGER (A - Z) + + CHARACTER*255 COMMAND + + CALL DISABLE_PRIVS + IF (CLI$PRESENT('COMMAND')) THEN + CALL CLI$GET_VALUE('COMMAND',COMMAND,CLEN) + CALL LIB$SPAWN('$'//COMMAND(:CLEN)) + ELSE + CALL LIB$SPAWN() + END IF + CALL ENABLE_PRIVS + + RETURN + END diff --git a/decus/vax90a/bulletin/bulletin0.for b/decus/vax90a/bulletin/bulletin0.for new file mode 100644 index 0000000..023da71 --- /dev/null +++ b/decus/vax90a/bulletin/bulletin0.for @@ -0,0 +1,1494 @@ +C +C BULLETIN0.FOR, Version 11/20/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE GET_BROADCAST_MESSAGE(RING_BELL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($BRKDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + +C +C The largest message that can be broadcasted is dependent on system +C and user quotas. The following limit is 12 lines of ( 80 characters + +C CR/LF ) + 2 bells. This should be more than enough room, as broadcasts +C shouldn't be too large anyway. +C + + PARAMETER CR=CHAR(13),LF=CHAR(10),BELL=CHAR(7) + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BROAD + + COMMON /BROAD_MESSAGE/ BROAD,BLENGTH + + IF (RING_BELL) THEN ! Include BELL in message? + BROAD(:36) = ! Say who the bulletin is from + & BELL//BELL//CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 37 ! Start adding next line here + ELSE + BROAD(:34) = ! Say who the bulletin is from + & CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 35 ! Start adding next line here + END IF + + IF (REMOTE_SET) REWIND (UNIT=3) + + END = 0 + ILEN = LINE_LENGTH + 1 + I = 0 + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (REMOTE_SET) THEN + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0) RETURN + ELSE + CALL GET_BULL_LINE(NBLOCK+1,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0) I = I + 1 + IF (ILEN.GT.0.AND.(I.GT.2.OR.(INPUT(:6).NE.'From: '.AND. + & INPUT(:6).NE.'Subj: '))) THEN + END = BLENGTH + ILEN - 1 + 2 ! Check how long string will be + IF (END.GT.BRDCST_LIMIT) RETURN ! String too long? + BROAD(BLENGTH:END) = CR//LF//INPUT(:ILEN)! Else add new input + BLENGTH = END + 1 ! Reset pointer + END IF + END DO + + RETURN + + ENTRY BROADCAST(ALL,CLUSTER) + + CALL SYS$SETRWM(%VAL(1)) ! Don't wait if can't broadcast + + IF (ALL) THEN ! Should we broadcast to ALL? + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,,,,,) + END IF + ELSE ! Else just broadcast to users. + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,,,,,) + END IF + END IF + + CALL SYS$SETRWM(%VAL(0)) + + RETURN + END + + + SUBROUTINE GET_FOLDER_INFO(IER) +C +C SUBROUTINE GET_FOLDER_INFO +C +C FUNCTION: Obtains & verifies folder names from command line. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + CHARACTER NODE_TEMP*256 + + NODE_NUM = 0 ! Initialize number of nodes + DO WHILE (CLI$GET_VALUE('SELECT_FOLDER',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(:COMMA-1) + NODE_TEMP = NODE_TEMP(COMMA+1:) + ELSE + NODES(NODE_NUM) = NODE_TEMP + NODE_TEMP = ' ' + END IF + NLEN = TRIM(NODES(NODE_NUM)) + IF (NODES(NODE_NUM)(NLEN-1:NLEN).EQ.'::') THEN + NODES(NODE_NUM) = NODES(NODE_NUM)(:NLEN)//'GENERAL' + END IF + FOLDER_NUMBER = -1 + FOLDER1 = NODES(NODE_NUM) + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' Unable to access folder '',A)') + & NODES(NODE_NUM) + RETURN + ELSE IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No write access for folder '',A)') + & NODES(NODE_NUM) + IER = 0 + RETURN + END IF + END DO + END DO + + IER = 1 + + RETURN + END + + + + + + + SUBROUTINE DELETE +C +C SUBROUTINE DELETE +C +C FUNCTION: Deletes a bulletin entry from the bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER ANSWER*1,REMOTE_USER*12,SUBJECT*53 + + INTEGER NOW(2) + + IMMEDIATE = 0 + IF (CLI$PRESENT('IMMEDIATE')) IMMEDIATE = 1 + + IF (CLI$PRESENT('NODES')) THEN ! Delete messages on DECNET node? + CALL DELETE_NODE ! Yes... + RETURN + ELSE IF (DECNET_PROC) THEN ! Is this from remote node? + IER = CLI$GET_VALUE('USERNAME',REMOTE_USER) + IER = CLI$GET_VALUE('SUBJECT',SUBJECT,SLEN) + CALL STR$UPCASE(SUBJECT,SUBJECT) + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + DEL_BULL = 0 + IER = 1 + DO WHILE (DEL_BULL+1.EQ.IER) + DEL_BULL = DEL_BULL + 1 + CALL READDIR(DEL_BULL,IER) + CALL STR$UPCASE(DESCRIP,DESCRIP) + IF (DEL_BULL+1.EQ.IER.AND.REMOTE_USER.EQ.FROM + & .AND.INDEX(DESCRIP,SUBJECT(:SLEN)).GT.0) THEN + CALL REMOVE_ENTRY(DEL_BULL,DEL_BULL,DEL_BULL,IMMEDIATE) + CALL CLOSE_BULLDIR + WRITE (5,'(''END'')') ! Tell DECNET that delete went ok. + RETURN + END IF + END DO + CALL CLOSE_BULLDIR ! Specified message not found, + WRITE(ERROR_UNIT,1030) ! so error out. + RETURN + END IF + +C +C Get the bulletin number to be deleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT ! Delete the file we are reading + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1020) + RETURN + ELSE IF (EBULL.GT.F_NBULL.AND..NOT.REMOTE_SET.AND. + & SBULL.NE.EBULL) THEN + WRITE (6,'('' Last message specified > number in folder.'')') + WRITE (6,'('' Do you want to delete to end of folder? '',$)') + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') THEN + WRITE (6,'('' Deletion aborted.'')') + RETURN + ELSE + EBULL = F_NBULL + END IF + END IF + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + IF (REMOTE_SET) THEN + IF (SBULL.NE.EBULL) THEN + WRITE (6,1025) + RETURN + END IF + IF (SBULL.NE.BULL_POINT) CALL READDIR(SBULL,IER) + WRITE(REMOTE_UNIT,'(4A)',IOSTAT=IER) + & 4,SBULL,IMMEDIATE,DESCRIP + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,INPUT,F1_NEWEST_BTIM,) + NEWEST_EXDATE = INPUT(1:11) + NEWEST_EXTIME = INPUT(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + RETURN + END IF + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + DO BULL_DELETE = SBULL,EBULL + CALL READDIR(BULL_DELETE,IER) ! Get info for bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges? + & (.NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER + & .AND.FOLDER_SET)) THEN + WRITE(6,1040) ! No, then error out. + CALL CLOSE_BULLDIR + RETURN + ELSE IF (SBULL.EQ.EBULL) THEN + CALL CLOSE_BULLDIR + WRITE (6,1050) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') RETURN + CALL OPEN_BULLDIR + CALL READDIR(BULL_DELETE,IER) + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + END IF + +C +C Delete the bulletin directory entry. +C + CALL REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + END DO + + CALL CLOSE_BULLDIR + RETURN + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1025 FORMAT(' ERROR: Cannot delete multiple messages in remote folder.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not deleted. Not owned by you.') +1050 FORMAT(' Message is not owned by you.', + & ' Are you sure you want to delete it? ',$) + + END + + + + SUBROUTINE REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + INTEGER NOW(2) + + IF (IMMEDIATE.EQ.1) THEN ! Delete it immediately + + CALL DELETE_ENTRY(BULL_DELETE) ! Delete the directory entry + + IF ((SYSTEM.AND.4).EQ.4) THEN ! Was entry shutdown bulletin? + SHUTDOWN = SHUTDOWN - 1 ! Decrement shutdown count + END IF + ELSE ! Delete it eventually +C +C Change year of expiration date of message to 100 years less, +C to indicate that message is to be deleted. Then, set expiration date +C in header of folder to 15 minutes from now. Thus, the folder will be +C checked in 15 minutes (or more), and will delete the messages then. +C +C NOTE: If some comic set their expiration date to > 1999, then +C the deleted date will be set to 1899 since can't specify date <1859. +C + + IF (SYSTEM.LE.1) THEN ! General or System message + EXDATE = EXDATE(1:7)//'18'//EXDATE(10:) + IF (EXDATE(10:10).LT.'6') EXDATE(10:11) = '99' + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(1:6)//'19'//EXDATE(9:) + ELSE + EXDATE = EXDATE(1:7)//'19'//EXDATE(10:) + END IF + END IF + + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + + IER = SYS$BINTIM('0 0:15',EX_BTIM) ! Get time 15 minutes from now + IER = SYS$GETTIM(NOW) + IER = LIB$SUBX(NOW,EX_BTIM,EX_BTIM) + IER = SYS$ASCTIM(,INPUT,EX_BTIM,) + + END IF + + IF (IMMEDIATE.NE.1.AND.BULL_DELETE.EQ.EBULL) THEN + CALL READDIR(0,IER) ! Get header + + NEWEST_EXDATE = INPUT(1:11) ! and store new expiration date + NEWEST_EXTIME = INPUT(13:) + + CALL WRITEDIR(0,IER) + ELSE IF (BULL_DELETE.EQ.EBULL) THEN + CALL CLEANUP_DIRFILE(SBULL) ! Reorder directory file + + CALL UPDATE_ALWAYS ! Somewhat a kludgey way of updating latest + ! bulletin and expired dates. + + IF (SBULL.LE.BULL_POINT) THEN + IF (BULL_POINT.GT.EBULL) THEN + BULL_POINT = BULL_POINT - (EBULL - SBULL + 1) + ELSE + BULL_POINT = SBULL + END IF + END IF ! Readjust where which bulletin to read next + ! if deletion causes messages to be moved. + END IF + + RETURN + END + + + + + + SUBROUTINE GET_2_VALS(INPUT,ILEN,SVAL,EVAL,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT + + DELIM = MAX(INDEX(INPUT,':'),INDEX(INPUT,'-')) + + IF (DELIM.EQ.0) THEN + DECODE(ILEN,'(I)',INPUT,IOSTAT=IER) SVAL + EVAL = SVAL + ELSE + DECODE(DELIM-1,'(I)',INPUT,IOSTAT=IER) SVAL + IF (IER.EQ.0) THEN + ILEN = ILEN - DELIM + DECODE(ILEN,'(I)',INPUT(DELIM+1:),IOSTAT=IER) EVAL + END IF + IF (EVAL.LT.SVAL) IER = 2 + END IF + + RETURN + END + + + + SUBROUTINE DIRECTORY(DIR_COUNT) +C +C SUBROUTINE DIRECTORY +C +C FUNCTION: Display directory of messages. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + DATA SCRATCH_D1/0/ + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED,CLI$_PRESENT + + CHARACTER START_PARAMETER*16,DATETIME*23 + + INTEGER TODAY(2) + + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + IF (INCMD(:3).EQ.'DIR'.AND..NOT.READ_TAG) THEN + IF (.NOT.CLI$PRESENT('SELECT_FOLDER').AND. + & CLI$PRESENT('MARKED')) THEN + IF (FOLDER_NUMBER.GE.0) THEN + READ_TAG = .TRUE. + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + ELSE + WRITE (6,'('' ERROR: Cannot use /MARKED with'', + & '' remote folder.'')') + RETURN + END IF + END IF + END IF + +C +C Directory listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C directory file, and to avoid the possibility of the user holding the screen, +C and thus causing the directory file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + CALL INIT_QUEUE(SCRATCH_D1,BULLDIR_ENTRY) + SCRATCH_D = SCRATCH_D1 + + CALL OPEN_BULLDIR_SHARED ! Get directory file + + CALL READDIR(0,IER) ! Does directory header exist? + IF (IER.EQ.1.AND.NBULL.GT.0) THEN ! And are there messages? + IF (DIR_COUNT.EQ.0) THEN + IF (CLI$PRESENT('START')) THEN ! Start number specified? + IER = CLI$GET_VALUE('START',START_PARAMETER,ILEN) + DECODE(ILEN,'(I)',START_PARAMETER) DIR_COUNT + IF (DIR_COUNT.GT.NBULL) THEN + DIR_COUNT = NBULL + ELSE IF (DIR_COUNT.LT.1) THEN + WRITE (6,'('' ERROR: Invalid starting message.'')') + CALL CLOSE_BULLDIR + DIR_COUNT = 0 + RETURN + END IF + ELSE IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + IF (CLI$PRESENT('SINCE')) THEN ! Was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present in'', + & '' folder '',A,''.'')') FOLDER(:TRIM(FOLDER)) + CALL CLOSE_BULLDIR + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + END IF + + CALL READDIR_KEYGE(IER) + + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + CALL CLOSE_BULLDIR + RETURN + ELSE + DIR_COUNT = IER + END IF + ELSE + DIR_COUNT = BULL_POINT + IF (DIR_COUNT.EQ.0) DIR_COUNT = 1 + END IF + + IF (READ_TAG) THEN + IF (.NOT.(CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW') + & .OR.CLI$PRESENT('START'))) THEN + DIR_COUNT = 1 + END IF + CALL READDIR(DIR_COUNT,IER1) + IF (IER1.EQ.DIR_COUNT+1) IER1 = 0 + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + END IF + + IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + ELSE IF (NBULL-DIR_COUNT+1.LE.PAGE_LENGTH-5) THEN + EBULL = NBULL + SBULL = NBULL - (PAGE_LENGTH-5) + 1 + IF (SBULL.LT.1) SBULL = 1 + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + END IF + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + END IF + IF (.NOT.PAGING) THEN + EBULL = NBULL + END IF + IF (.NOT.REMOTE_SET.AND..NOT.READ_TAG) THEN + DO I=SBULL,EBULL ! Copy messages from file + CALL READDIR(I,IER) ! Into the queue + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + END DO + ELSE IF (READ_TAG) THEN + I = SBULL + DO WHILE (I.LE.EBULL.AND.IER1.EQ.0) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,DIR_COUNT) + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + I = I + 1 + END DO + EBULL = I - 1 + IF (IER1.NE.0) EBULL = EBULL - 1 + ELSE + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,SBULL,EBULL + IF (IER.EQ.0) THEN + I = SBULL + DO WHILE (IER.EQ.0.AND.I.LE.EBULL) + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + I = I + 1 + END DO + END IF + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + RETURN + END IF + END IF + ELSE + NBULL = 0 + END IF + + CALL CLOSE_BULLDIR ! We don't need file anymore + + IF (NBULL.EQ.0) THEN + WRITE (6,'('' There are no messages present.'')') + RETURN + END IF + +C +C Directory entries are now in queue. Output queue entries to screen. +C + + FLEN = TRIM(FOLDER) + WRITE(6,'(X,A)') FOLDER(:FLEN) + WRITE(6,1000) ! Write header + N = 3 + + IF (BULL_TAG.AND..NOT.READ_TAG) THEN + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + + DO I=SBULL,EBULL + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + CALL CONVERT_ENTRY_FROMBIN + IF (MSG_NUM.GT.999) N = 4 + IF (MSG_NUM.GT.9999) N = 5 + IF (READ_TAG.OR.(BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG)) THEN + WRITE (6,'('' *'',$)') + ELSE + WRITE (6,'('' '',$)') + END IF + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM,'(DELETED)' + ELSE + WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM, + & DATE(1:7)//DATE(10:11) + END IF + IF (BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG) THEN + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + END DO + + DIR_COUNT = MSG_NUM + 1 ! Update directory counter + + IF (DIR_COUNT.GT.NBULL.OR.(READ_TAG.AND.IER1.NE.0)) THEN + ! Outputted all entries? + DIR_COUNT = 0 ! Yes. Set counter to 0. + ELSE + WRITE(6,1010) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(' #',1X,'Description',43X,'From',9X,'Date',/) +1010 FORMAT(1X,/,' Press RETURN for more...',/) + +2010 FORMAT('+',I,1X,A<55-N>,1X,A12,1X,A9) + + END + + + SUBROUTINE GET_MSGKEY(BTIM,MSG_KEY) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*8 MSG_KEY,INPUT + + CALL LIB$MOVC3(8,BTIM(1),%REF(INPUT)) + + DO I=1,8 + MSG_KEY(I:I) = INPUT(9-I:9-I) + END DO + + RETURN + END + + + + SUBROUTINE FILE +C +C SUBROUTINE FILE +C +C FUNCTION: Copies a bulletin to a file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN ! If no file name was specified + WRITE(6,1020) ! Write error + RETURN ! And return + END IF + + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + + IF (CLI$PRESENT('NEW')) THEN + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH, + & STATUS='UNKNOWN',CARRIAGECONTROL='LIST',ACCESS='APPEND') + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + DO FBULL = SBULL,EBULL + CALL READDIR(FBULL,IER) ! Get info for specified bulletin + + IF (IER.NE.FBULL+1) THEN ! Was bulletin found? + WRITE(6,1030) FBULL + IF (FBULL.GT.SBULL) GO TO 100 + CLOSE (UNIT=3,STATUS='DELETE') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + RETURN + END IF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + END DO + +100 CLOSE (UNIT=3) ! Bulletin copy completed + + WRITE(6,1040) BULL_PARAMETER(1:LEN_P) + ! Show name of file created. + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + + RETURN + +900 WRITE(6,1000) + CALL ENABLE_PRIVS ! Reset BYPASS privileges + RETURN + +1000 FORMAT(' ERROR: Error in opening file.') +1010 FORMAT(' ERROR: You have not read any bulletin.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1020 FORMAT(' ERROR: No file name was specified.') +1030 FORMAT(' ERROR: Following bulletin was not found: ',I) +1040 FORMAT(' Message(s) written to ',A) +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,/,'Date: ',A) + + END + + + + + SUBROUTINE LOGIN +C +C SUBROUTINE LOGIN +C +C FUNCTION: Alerts user of new messages upon logging in. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /READIT/ READIT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /POINT/ BULL_POINT + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY*23,INREAD*1 + + LOGICAL*1 CTRL_G/7/ + + DATA GEN_DIR1/0/ ! General directory link list header + DATA SYS_DIR1/0/ ! System directory link list header + DATA SYS_NUM1/0/ ! System message number link list header + DATA SYS_BUL1/0/ ! System bulletin link list header + DATA ALL_DIR1/0/ ! Full directory link list header (for remote) + + DATA PAGE/0/ + + DATA FIRST_WRITE/.TRUE./ + LOGICAL FIRST_WRITE + + COMMON /LOGIN_BTIM/ LOGIN_BTIM_SAVE(2) + + DIMENSION NOLOGIN_BTIM(2),TODAY_BTIM(2) + DIMENSION NEW_BTIM(2),PASSCHANGE(2),BULLCP_BTIM(2) + DIMENSION LOGIN_BTIM_OLD(2),LOGIN_BTIM_NEW(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + CALL SYS_BINTIM('5-NOV-1956 11:05:56',NEW_BTIM) + +C +C Find user entry in BULLUSER.DAT to update information and +C to get the last date that messages were read. +C + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_HEADER(IER) ! Get the header + + IF (IER.EQ.0) THEN ! Header is present. + UNLOCK 4 + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + ! Find if there is an entry + IF (NEW_FLAG(1).LT.143.OR.NEW_FLAG(1).GT.143) THEN + NEW_FLAG(2)=0 ! If old version clear GENERIC value + NEW_FLAG(1)=143 ! Set new version number + END IF + IF (IER1.EQ.0) THEN ! There is a user entry + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + ! DISMAIL or SET LOGIN set + IF (CLI$PRESENT('ALL')) THEN + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + ELSE + RETURN ! Don't notify + END IF + END IF + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_ENTRY + IF (SYSTEM_FLAG(1).NE.0.AND.SYSTEM_FLAG(1).NE.1) READIT = 1 + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0.OR.BRIEF_FLAG(I).NE.0.OR. + & (I.GT.1.AND.SYSTEM_FLAG(I).NE.0)) READIT = 1 + END DO + ELSE + CALL CLEANUP_LOGIN ! Good time to delete dead users + READ_BTIM(1) = NEW_BTIM(1) ! Make new entry + READ_BTIM(2) = NEW_BTIM(2) + DO I = 1,FLONG + SET_FLAG(I) = SET_FLAG_DEF(I) + BRIEF_FLAG(I) = BRIEF_FLAG_DEF(I) + NOTIFY_FLAG(I) = NOTIFY_FLAG_DEF(I) + END DO + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) + IF (DISMAIL.EQ.1) THEN + LOGIN_BTIM(1) = NOLOGIN_BTIM(1) + LOGIN_BTIM(2) = NOLOGIN_BTIM(2) + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + ELSE + LOGIN_BTIM_SAVE(1) = NEW_BTIM(1) + LOGIN_BTIM_SAVE(2) = NEW_BTIM(2) + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0) READIT = 1 + END DO + IF (COMPARE_BTIM(PASSCHANGE,NEWEST_BTIM).LT.0) IER1 = 0 + ! Old password change indicates user is new to BULLETIN + ! but not to system, so don't limit message viewing. + END IF + CALL WRITE_USER_FILE(IER) + IF (IER.NE.0) THEN ! Error in writing to user file + WRITE (6,1070) ! Tell user of the error + CALL CLOSE_BULLUSER ! Close the user file + CALL EXIT ! Go away... + END IF + IF (DISMAIL.EQ.1) RETURN ! Go away if DISMAIL set + DIFF = -1 ! Force us to look at messages + CALL OPEN_BULLINF_SHARED + DO I=1,FOLDER_MAX + LAST_READ_BTIM(1,I) = READ_BTIM(1) + LAST_READ_BTIM(2,I) = READ_BTIM(2) + END DO + WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(I,J),I=1,2),J=1,FOLDER_MAX) + CALL CLOSE_BULLINF + END IF + LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) + LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) + CALL READ_USER_FILE_HEADER(IER2) ! Reset read back to header + END IF + + IF (IER.EQ.0.AND.MINUTE_DIFF(TODAY_BTIM,BBOARD_BTIM) + & .GT.BBOARD_UPDATE) THEN ! Update BBOARD mail? + BBOARD_BTIM(1) = TODAY_BTIM(1) + BBOARD_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_HEADER ! Rewrite header + IF (.NOT.TEST_BULLCP()) CALL CREATE_BBOARD_PROCESS + ELSE IF (IER.NE.0) THEN + CALL CLOSE_BULLUSER + CALL EXIT ! If no header, no messages + END IF + + IF (IER1.EQ.0) THEN ! Skip date comparison if new entry +C +C Compare and see if messages have been added since the last time +C that the user has logged in or used the BULLETIN facility. +C + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,READ_BTIM) + IF (DIFF1.LT.0) THEN ! If read messages since last login, + LOGIN_BTIM(1) = READ_BTIM(1) ! then use the read date to compare + LOGIN_BTIM(2) = READ_BTIM(2) ! with the latest bulletin date + END IF ! to see if should alert user. + + IF (SYSTEM_SWITCH) THEN + DIFF1 = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,NEWEST_BTIM) + ELSE + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,NEWEST_BTIM) + END IF + END IF + + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) ! These are destroyed in UPDATE_READ + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + + IF (NEW_FLAG(2).NE.0) THEN + CALL LIB$MOVC3(4,NEW_FLAG(2),%REF(BULL_PARAMETER)) + CALL SUBTIME(LOGIN_BTIM,BULL_PARAMETER(1:4),IER) + ELSE IF (DIFF1.GT.0) THEN + BULL_POINT = -1 + IF (READIT.EQ.1) THEN + CALL UPDATE_READ(1) + CALL READ_IN_FOLDERS + CALL MODIFY_SYSTEM_LIST(1) + END IF + CALL CLOSE_BULLUSER + RETURN + END IF + + CALL READ_IN_FOLDERS + CALL MODIFY_SYSTEM_LIST(1) + +C +C If there are new messages, look for them in BULLDIR.DAT +C Save all new entries in the GEN_DIR file BULLCHECK.SCR so +C that we can close BULLDIR.DAT as soon as possible. +C + + ENTRY LOGIN_FOLDER + + IF (NEW_FLAG(2).EQ.0.OR.FOLDER_SET) THEN + LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) + LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) + END IF + + IF (REMOTE_SET) THEN ! If system remote folder, use remote + DIFF1 = COMPARE_BTIM(LOGIN_BTIM, ! info, not local login time + & LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF1.LT.0) THEN + LOGIN_BTIM(1) = LAST_READ_BTIM(1,FOLDER_NUMBER+1) + LOGIN_BTIM(2) = LAST_READ_BTIM(2,FOLDER_NUMBER+1) + ELSE + DIFF = MINUTE_DIFF(LOGIN_BTIM,F_NEWEST_BTIM) + IF (DIFF.GE.0.AND.DIFF.LE.15) THEN ! BULLCP updates every 15 min + IER = SYS$BINTIM('0 00:15',BULLCP_BTIM) + BULLCP_BTIM(1) = -BULLCP_BTIM(1) ! Convert to -delta time + BULLCP_BTIM(2) = -BULLCP_BTIM(2)-1 + CALL LIB$SUBX(LOGIN_BTIM,BULLCP_BTIM,LOGIN_BTIM) + END IF + END IF + END IF + + ENTRY SHOW_SYSTEM + + JUST_SYSTEM = (.NOT.LOGIN_SWITCH.AND.SYSTEM_SWITCH).OR. + & (FOLDER_NUMBER.GT.0.AND.BTEST(FOLDER_FLAG,2) + & .AND..NOT.TEST2(SET_FLAG,FOLDER_NUMBER) + & .AND..NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) + + NGEN = 0 ! Number of general messages + NSYS = 0 ! Number of system messages + BULL_POINT = -1 + + IF (IER1.NE.0.AND.FOLDER_NUMBER.GT.0) THEN + IF (LOGIN_SWITCH) THEN + IF (READIT.EQ.1) THEN + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + CALL UPDATE_READ(1) + END IF + CALL CLOSE_BULLUSER + END IF + RETURN ! Don't overwhelm new user with lots of non-general msgs + END IF + + IF (BTEST(FOLDER_FLAG,2).AND.SYSTEM_SWITCH) THEN + ! Can folder have SYSTEM messages and /SYSTEM specified? + LOGIN_BTIM(1) = SYSTEM_LOGIN_BTIM(1) ! Use specified login time + LOGIN_BTIM(2) = SYSTEM_LOGIN_BTIM(2) ! for system messages. + END IF + + IF (LOGIN_SWITCH) THEN + IF (READIT.EQ.1) THEN + LOGIN_BTIM_OLD(1) = LOGIN_BTIM(1) + LOGIN_BTIM_OLD(2) = LOGIN_BTIM(2) + CALL UPDATE_READ(1) + LOGIN_BTIM_NEW(1) = LOGIN_BTIM(1) + LOGIN_BTIM_NEW(2) = LOGIN_BTIM(2) + LOGIN_BTIM(1) = LOGIN_BTIM_OLD(1) + LOGIN_BTIM(2) = LOGIN_BTIM_OLD(2) + END IF + CALL CLOSE_BULLUSER + END IF + + CALL OPEN_BULLDIR_SHARED ! Get bulletin directory + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(0,IER) ! Get header info + ELSE + NBULL = F_NBULL + END IF + + CALL INIT_QUEUE(GEN_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_NUM1,%DESCR(ICOUNT)) + GEN_DIR = GEN_DIR1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + START = 1 + REVERSE = 0 + IF (REVERSE_SWITCH.AND.(.NOT.TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & .NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER))) THEN + REVERSE = 1 + IF (IER1.EQ.0) THEN + CALL GET_NEWEST_MSG(LOGIN_BTIM,START) + IF (START.EQ.-1) START = NBULL + 1 + END IF + END IF + + IF (REMOTE_SET) THEN + CALL INIT_QUEUE(ALL_DIR1,BULLDIR_ENTRY) + IF (REVERSE) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,START,NBULL + ELSE + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,NBULL,START + END IF + IF (IER.EQ.0) THEN + ALL_DIR = ALL_DIR1 + I = START + DO WHILE (IER.EQ.0.AND.I.LE.NBULL) + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY + CALL WRITE_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + I = I + 1 + END DO + END IF + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + GO TO 9999 + END IF + ALL_DIR = ALL_DIR1 + END IF + + DO ICOUNT1 = NBULL,START,-1 + IF (REVERSE) THEN + ICOUNT = NBULL + START - ICOUNT1 + ELSE + ICOUNT = ICOUNT1 + END IF + IF (REMOTE_SET) THEN + CALL READ_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + IER = ICOUNT + 1 + ELSE + CALL READDIR(ICOUNT,IER) + END IF + IF (IER1.EQ.0.AND.IER.EQ.ICOUNT+1) THEN ! Is this a totally new user? + ! No. Is bulletin system or from same user? + IF (.NOT.REVERSE) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM,MSG_BTIM) ! No, so compare date + IF (DIFF.GT.0) GO TO 100 + END IF + IF (.NOT.BTEST(FOLDER_FLAG,2)) SYSTEM = SYSTEM.AND.(.NOT.1) + ! Show system msg in non-system folder as general msg + IF (USERNAME.NE.FROM.OR.SYSTEM) THEN + IF (SYSTEM) THEN ! Is it system bulletin? + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (.NOT.JUST_SYSTEM) THEN + IF (SYSTEM_SWITCH) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,MSG_BTIM) + ELSE + DIFF = -1 + END IF + IF (DIFF.LT.0) THEN + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + SYSTEM = ICOUNT + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END IF + ELSE IF (IER.EQ.ICOUNT+1) THEN + ! Totally new user, save only permanent system msgs + IF (SYSTEM.EQ.3) THEN + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (NGEN.EQ.0) THEN ! And save only the first non-system msg + SYSTEM = ICOUNT ! Save bulletin number for display + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END DO +100 CALL CLOSE_BULLDIR +C +C Review new directory entries. If there are system messages, +C copy the system bulletin into GEN_DIR file BULLSYS.SCR for outputting +C to the terminal. If there are simple messages, just output the +C header information. +C + IF (NGEN.EQ.0.AND.NSYS.EQ.0) GO TO 9999 + + IF (NSYS.GT.0) THEN ! Are there any system messages? + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + LENF = TRIM(FOLDER) + S1 = (PAGE_WIDTH-(LENF+16))/2 + S2 = PAGE_WIDTH - S1 - (LENF + 16) + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE (6,1026) FOLDER(:LENF) ! Yep... + PAGE = PAGE + 1 + CTRL_G = 0 ! Don't ring bell for non-system bulls + CALL OPEN_BULLFIL_SHARED + CALL INIT_QUEUE(SYS_BUL1,INPUT) + SYS_BUL = SYS_BUL1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + NSYS_LINE = 0 + DO J=1,NSYS + CALL READ_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + IF (REMOTE_SET) THEN + CALL READ_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,ICOUNT + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER) + END IF + IF (IER.GT.0) THEN + CALL CLOSE_BULLFIL + GO TO 9999 + END IF + END IF + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin to SYS_BUL link list + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + IF (ILEN.LT.0) THEN + CALL CLOSE_BULLFIL + GO TO 9999 + END IF + IF (J.LT.NSYS.AND.SEPARATE.NE.' ') THEN + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + DO I=1,PAGE_WIDTH + INPUT(I:I) = SEPARATE + END DO + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 2 + END IF + END DO + CALL CLOSE_BULLFIL + SYS_BUL = SYS_BUL1 + ILEN = 0 + I = 1 + DO WHILE (I.LE.NSYS_LINE.OR.ILEN.GT.0) ! Write out system messages + IF (ILEN.EQ.0) THEN + CALL READ_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + ILEN = TRIM(INPUT) + I = I + 1 + END IF + IF (SYS_BUL.NE.0) THEN + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN + ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD,! Get terminal input + & 'HIT any key for next page....') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) '+'//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) '+'//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + ELSE + PAGE = PAGE + 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) ' '//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) ' '//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + END IF + END IF + END DO + IF (NGEN.EQ.0) THEN + WRITE(6,'(A)') ! Write delimiting blank line + END IF + PAGE = PAGE + 1 + END IF + + ENTRY REDISPLAY_DIRECTORY + + GEN_DIR = GEN_DIR1 + IF (NGEN.GT.0) THEN ! Are there new non-system messages? + LENF = TRIM(FOLDER) + S1 = (PAGE_WIDTH-13-LENF)/2 + S2 = PAGE_WIDTH-S1-13-LENF + IF (PAGE+5+NGEN.GT.PAGE_LENGTH.AND.PAGE.GT.0) THEN + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, ! Get terminal input + & 'HIT any key for next page....') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1028) 'New '//FOLDER(1:LENF)//' messages' + PAGE = 1 + ELSE + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1027) 'New '//FOLDER(1:LENF)//' messages' + PAGE = PAGE + 1 + END IF + WRITE(6,1020) + WRITE(6,1025) + PAGE = PAGE + 2 + I = 0 + DO WHILE (I.LT.NGEN) + I = I + 1 + CALL READ_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + CALL CONVERT_ENTRY_FROMBIN + IF (SYSTEM.GT.9999) THEN ! # Digits in message number + N = 5 + ELSE IF (SYSTEM.GT.999) THEN + N = 4 + ELSE + N = 3 + END IF + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, + & 'HIT Q(Quit listing) or any other key for next page....') + CALL STR$UPCASE(INREAD,INREAD) + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (INREAD.EQ.'Q') THEN + I = NGEN ! Quit directory listing + WRITE(6,'(''+Quitting directory listing.'')') + ELSE + WRITE(6,1040) '+'//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM + END IF + ! Bulletin number is stored in SYSTEM + ELSE + PAGE = PAGE + 1 + WRITE(6,1040) ' '//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM + END IF + END DO + IF ((.NOT.FOLDER_SET.AND.BTEST(SET_FLAG(1),0).AND.DIFF1.LE.0) + & .OR.(FOLDER_SET.AND.TEST2(SET_FLAG,FOLDER_NUMBER))) THEN + PAGE = 0 ! Don't reset page counter if READNEW not set, + END IF ! as no prompt to read is generated. + END IF +C +C Instruct users how to read displayed messages if READNEW not selected. +C + IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE(6,1030) + ELSE IF (NGEN.EQ.0) THEN + ILEN = 57 + INDEX(COMMAND_PROMPT,'>') - 1 + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-57)// + & '/SYSTEM command can be used to reread these messages.' + ELSE + FLEN = TRIM(FOLDER) + IF (FOLDER_NUMBER.EQ.0) FLEN = -1 + ILEN = 49 + INDEX(COMMAND_PROMPT,'>') - 1 + FLEN + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-48)// + & ' command can be used to read these messages.' + ELSE + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-49-FLEN) + & //' '//FOLDER(:FLEN)// + & ' command can be used to read these messages.' + END IF + END IF + +9999 IF (LOGIN_SWITCH) THEN + LOGIN_BTIM(1) = LOGIN_BTIM_NEW(1) + LOGIN_BTIM(2) = LOGIN_BTIM_NEW(2) + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM_OLD(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM_OLD(2) + END IF + RETURN + +1020 FORMAT(' Description',43X,'From',9X,'Date',3X,'Number') +1025 FORMAT(' -----------',43X,'----',9X,'----',3X,'------') +1026 FORMAT(' ',('*'),A,' System Messages',('*')) +1027 FORMAT(/,' ',('*'),A,('*')) +1028 FORMAT('+',('*'),A,('*')) +1030 FORMAT(' ',('*')) +1035 FORMAT(' ',('*'),A,('*')) +1040 FORMAT(A<57-N>,1X,A12,1X,A6,<6-N>X,I) +1060 FORMAT(A) +1070 FORMAT(' ERROR: Cannot add new entry to user file.') +1080 FORMAT(' ',/) + + END + + + + SUBROUTINE GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,NODE_NAME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + CHARACTER*(*) NODE_NAME + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) + CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) + CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist + + IER = SYS$GETSYIW(,,NODE_NAME(:TRIM(NODE_NAME)), + & %VAL(GETSYI_ITMLST),,,) ! Get Info command. + + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Specified node name not found.'')') + NODE_AREA = 0 + END IF + + RETURN + END + diff --git a/decus/vax90a/bulletin/bulletin1.for b/decus/vax90a/bulletin/bulletin1.for new file mode 100644 index 0000000..fc51748 --- /dev/null +++ b/decus/vax90a/bulletin/bulletin1.for @@ -0,0 +1,1565 @@ +C +C BULLETIN1.FOR, Version 9/26/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE MAIL(STATUS) +C +C SUBROUTINE MAIL +C +C FUNCTION: Sends message which you have read to user via DEC mail. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*64 MAIL_SUBJECT + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + MAIL_SUBJECT = DESCRIP + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',MAIL_SUBJECT,LEN_D) + IF (LEN_D.GT.LEN(MAIL_SUBJECT)-2) THEN + WRITE(6,'('' ERROR: Subject limit is 64 characters.'')') + RETURN + END IF + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Error in opening scratch file.'')') + RETURN + END IF + + IF (CLI$PRESENT('HEADER')) THEN ! Printout header? + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + WRITE (3,'(A)') INPUT(:TRIM(INPUT)) + END IF + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Message copy completed + + CALL CLOSE_BULLFIL + + LEN_D = TRIM(MAIL_SUBJECT) + IF (LEN_D.EQ.0) THEN + MAIL_SUBJECT = 'BULLETIN message.' + LEN_D = TRIM(MAIL_SUBJECT) + END IF + + I = 1 + DO WHILE (I.LE.LEN_D) + IF (MAIL_SUBJECT(I:I).EQ.'"') THEN + IF (LEN_D.EQ.64) THEN + MAIL_SUBJECT(I:I) = '`' + ELSE + MAIL_SUBJECT = MAIL_SUBJECT(:I)//'"'//MAIL_SUBJECT(I+1:) + I = I + 1 + LEN_D = LEN_D + 1 + END IF + END IF + I = I + 1 + END DO + + LEN_P = 0 + DO WHILE (CLI$GET_VALUE('RECIPIENTS',BULL_PARAMETER(LEN_P+1:),I) + & .NE.%LOC(CLI$_ABSENT)) ! Get all the usernames + LEN_P = LEN_P + I + 1 + BULL_PARAMETER(LEN_P:LEN_P) = ',' + END DO + LEN_P = LEN_P - 1 + + I = 1 ! Must change all " to "" in MAIL recipients + DO WHILE (I.LE.LEN_P) + IF (BULL_PARAMETER(I:I).EQ.'"') THEN + BULL_PARAMETER = BULL_PARAMETER(:I)//'"'// + & BULL_PARAMETER(I+1:) + I = I + 1 + LEN_P = LEN_P + 1 + END IF + I = I + 1 + END DO + + CALL DISABLE_PRIVS + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR '//BULL_PARAMETER(:LEN_P) + & //'/SUBJECT="'//MAIL_SUBJECT(:LEN_D)//'"',,,,,,STATUS) + CALL ENABLE_PRIVS + + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR') + + RETURN + +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A) + + END + + + + SUBROUTINE MODIFY_FOLDER +C +C SUBROUTINE MODIFY_FOLDER +C +C FUNCTION: Modifies a folder's information. +C + IMPLICIT INTEGER (A - Z) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER PASSWORD*31,DEFAULT_USER*12 + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + RETURN + ELSE IF (FOLDER_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: No privileges to modify folder.'')') + RETURN + END IF + + IF (CLI$PRESENT('NAME')) THEN + IF (REMOTE_SET) THEN + WRITE (6,'('' ERROR: Cannot change name of'', + & '' remote folder.'')') + RETURN + ELSE + CALL CLI$GET_VALUE('NAME',FOLDER1,LEN_P) + IF (LEN_P.GT.25) THEN + WRITE (6,'('' ERROR: Folder name cannot be larger + & than 25 characters.'')') + RETURN + END IF + END IF + ELSE + FOLDER1 = FOLDER + END IF + + IF (CLI$PRESENT('DESCRIPTION')) THEN + WRITE (6,'('' Enter one line description of folder.'')') + LEN_P = 81 + DO WHILE (LEN_P.GT.80) + CALL GET_LINE(FOLDER1_DESCRIP,LEN_P) ! Get input line + IF (LEN_P.LE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + RETURN + ELSE IF (LEN_P.GT.80) THEN ! If too many characters + WRITE (6,'('' ERROR: Description must be < 80 characters.'')') + ELSE + FOLDER1_DESCRIP = FOLDER1_DESCRIP(:LEN_P) ! End fill with spaces + END IF + END DO + ELSE + FOLDER1_DESCRIP = FOLDER_DESCRIP + END IF + + IF (CLI$PRESENT('OWNER')) THEN + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner name is not valid username.'')') + RETURN + ELSE IF (LEN_P.GT.LEN(FOLDER1_OWNER)) THEN + WRITE (6,'('' ERROR: Folder owner name too long.'')') + RETURN + ELSE IF (.NOT.SETPRV_PRIV()) THEN + WRITE(6,'('' Enter password of new owner: '',A)') CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) THEN + WRITE (6,'('' ERROR: No password entered.'')') + RETURN + END IF + WRITE (6,'('' Attempting to verify password name...'')') + OPEN (UNIT=10,NAME='SYS$NODE"'// + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + & //' '//PASSWORD(:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + RETURN + ELSE + WRITE (6,'('' Password was verified.'')') + END IF + ELSE + FOLDER1_OWNER = FOLDER1_OWNER(:LEN_P) + END IF + ELSE + FOLDER1_OWNER = FOLDER_OWNER + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + + IF (CLI$PRESENT('NAME')) THEN + READ (7,IOSTAT=IER,KEY=FOLDER1,KEYID=0) + ! See if folder exists + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder name already exists.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + END IF + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (IER.EQ.0.AND.CLI$PRESENT('NAME')) THEN + LEN_F = TRIM(FOLDER_DIRECTORY) + IER = LIB$RENAME_FILE(FOLDER_DIRECTORY(:LEN_F)// + & FOLDER(:TRIM(FOLDER))//'.*',FOLDER_DIRECTORY(:LEN_F)// + & FOLDER1(:TRIM(FOLDER1))//'.*') + IF (IER) THEN + IER = 0 + FOLDER_FILE = FOLDER_DIRECTORY(:LEN_F)//FOLDER1 + END IF + END IF + + IF (IER.EQ.0) THEN + IF (CLI$PRESENT('OWNER')) THEN + CALL CHKACL + & (FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + CALL DEL_ACL(FOLDER_OWNER,'R+W+C',IER) + END IF + END IF + FOLDER = FOLDER1 + FOLDER_OWNER = FOLDER1_OWNER + FOLDER_DESCRIP = FOLDER1_DESCRIP + DELETE (7) + CALL WRITE_FOLDER_FILE(IER) + IF (IER.EQ.0) WRITE (6,'('' Folder successfully modified.'')') + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + SUBROUTINE MOVE(DELETE_ORIGINAL) +C +C SUBROUTINE MOVE +C +C FUNCTION: Moves message from one folder to another. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + EXTERNAL CLI$_ABSENT + + EXTERNAL BULLETIN_SUBCOMMANDS + + LOGICAL DELETE_ORIGINAL + + CHARACTER SAVE_FOLDER*25 + + IF (CLI$PRESENT('ORIGINAL').AND..NOT.SETPRV_PRIV()) THEN + WRITE (6, + & '('' ERROR: You have no privileges to keep original owner.'')') + END IF + + ALL = CLI$PRESENT('ALL') + + MERGE = CLI$PRESENT('MERGE') + + SAVE_BULL_POINT = BULL_POINT + + IER1 = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER1.EQ.%LOC(CLI$_ABSENT).AND..NOT.ALL) THEN + IF (BULL_POINT.EQ.0) THEN ! If no message has been read + WRITE(6,'('' ERROR: You are not reading any message.'')') + RETURN ! and return + END IF + + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) ! Get message directory entry + IF (IER.NE.BULL_POINT+1) THEN ! Was message found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + NUM_COPY = 1 + ELSE + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) ! Get message directory entry + IF (NBULL.EQ.0) THEN ! Were messages found? + WRITE(6,'('' ERROR: No messages were found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (IER1.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER1) + IF (SBULL.LE.0.OR.IER1.NE.0) THEN + WRITE (6,'(A)') + & ' ERROR: Specified message number has incorrect format.' + CALL CLOSE_BULLDIR + RETURN + ELSE + NUM_COPY = EBULL - SBULL + 1 + BULL_POINT = SBULL + END IF + ALL = .TRUE. + ELSE IF (CLI$PRESENT('ALL')) THEN + NUM_COPY = NBULL + BULL_POINT = 1 + END IF + END IF + + FROM_REMOTE = REMOTE_SET + + IF (REMOTE_SET) THEN + OPEN (UNIT=12,FILE='REMOTE.BULLDIR', + & STATUS='SCRATCH',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.0) THEN + OPEN (UNIT=11,FILE='REMOTE.BULLFIL', + & STATUS='SCRATCH',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END IF + IF (IER.EQ.0) THEN + CALL OPEN_BULLFIL + I = BULL_POINT - 1 + CALL READDIR(I,IER) + IF (IER.EQ.I+1) THEN + IF (I.EQ.0) THEN + WRITE (12,IOSTAT=IER1) BULLDIR_HEADER + ELSE + WRITE (12,IOSTAT=IER1) BULLDIR_ENTRY + END IF + END IF + NBLOCK = 1 + DO WHILE (I.LT.BULL_POINT+NUM_COPY-1.AND.IER.EQ.I+1) + I = I + 1 + CALL READDIR(I,IER) + IF (IER.EQ.I+1) THEN + BLOCK = NBLOCK + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (12,IOSTAT=IER1) BULLDIR_ENTRY + IF (IER1.EQ.0) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER1) 5,I + IF (IER1.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER1) + END IF + END IF + IF (IER1.EQ.0) THEN + SCRATCH_R = SCRATCH_R1 + DO J=1,LENGTH + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT(:128)) + WRITE (11'NBLOCK,IOSTAT=IER1) INPUT(:128) + NBLOCK = NBLOCK + 1 + END DO + END IF + IF (IER1.NE.0) I = IER + END IF + END DO + NUM_COPY = I - BULL_POINT + 1 + END IF + CALL CLOSE_BULLFIL + IF (IER1.NE.0) THEN + WRITE(6,'('' ERROR: Copy aborted. Remote folder problem.'')') + CLOSE (UNIT=11) + CLOSE (UNIT=12) + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + + CALL CLOSE_BULLDIR + + SAVE_FOLDER = FOLDER + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + CALL CLI$GET_VALUE('FOLDER',FOLDER1) + + FOLDER_NUMBER = -1 ! Use FOLDER as key rather than FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Cannot access specified folder.'')') + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER = SAVE_FOLDER + BULL_POINT = SAVE_BULL_POINT + CLOSE (UNIT=11) + CLOSE (UNIT=12) + RETURN + END IF + + IF (READ_ONLY.OR.(MERGE.AND.REMOTE_SET)) THEN + IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No access to write into folder.'')') + ELSE + WRITE (6,'('' ERROR: /MERGE invalid into remote folder.'')') + END IF + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + BULL_POINT = SAVE_BULL_POINT + CLOSE (UNIT=11) + CLOSE (UNIT=12) + RETURN + END IF + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + CALL OPEN_BULLDIR ! Prepare to add dir entry + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //SAVE_FOLDER + + IF (.NOT.FROM_REMOTE) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=12,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER.EQ.0) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=11,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END DO + END IF + ELSE + IER= 0 + END IF + + IF (MERGE) CALL INITIALIZE_MERGE(IER) + + START_BULL_POINT = BULL_POINT + + IF (IER.EQ.0) READ (12,KEYID=0,KEY=BULL_POINT-1,IOSTAT=IER) + + DO WHILE (NUM_COPY.GT.0.AND.IER.EQ.0) + READ (12,IOSTAT=IER) BULLDIR_ENTRY + NUM_COPY = NUM_COPY - 1 + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + + IF (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV()) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,0) ! Remove system bit + END IF + + IF (BTEST(SYSTEM,2).AND. ! Shutdown message? + & (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV())) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,2) ! Remove shutdown bit + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + EXTIME = '00:00:00.00' + ELSE IF (BTEST(SYSTEM,1).AND.FOLDER_NUMBER.EQ.0.AND. + & .NOT.SETPRV_PRIV().AND..NOT.ALL) THEN ! Permanent? + WRITE (6,'('' ERROR: No privileges to add'', + & '' permanent message.'')') + WRITE (6,'('' Expiration will be '',I,'' days.'')') + & FOLDER_BBEXPIRE + SYSTEM = IBCLR(SYSTEM,1) + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + EXTIME = '00:00:00.00' + END IF + + IF (.NOT.CLI$PRESENT('ORIGINAL')) THEN ! If not /ORIGINAL + FROM = USERNAME ! Specify owner + END IF + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + IF (IER.NE.0) CALL ERROR_AND_EXIT + END IF + + IF (MERGE) CALL ADD_MERGE_TO(IER) + + IF (IER.EQ.0) THEN + NBLOCK = NBLOCK + 1 + + DO I=BLOCK,BLOCK+LENGTH-1 + READ (11'I,IOSTAT=IER) INPUT(:128) + IF (IER.EQ.0) THEN + CALL WRITE_BULL_FILE(NBLOCK,INPUT(:128)) + END IF + NBLOCK = NBLOCK + 1 + END DO + END IF + + IF (IER.EQ.0) THEN + IF (MERGE) THEN + CALL ADD_MERGE_FROM(IER) + ELSE + CALL ADD_ENTRY ! Add the new directory entry + END IF + BULL_POINT = BULL_POINT + 1 + END IF + END DO + + IF (MERGE) CALL ADD_MERGE_REST(IER) + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CLOSE (UNIT=11) + + CLOSE (UNIT=12) + + IF (FOLDER_NUMBER.GE.0.AND.IER.EQ.0) THEN + CALL UPDATE_FOLDER ! Update folder info +C +C If user is adding message, update that user's last read time for +C folder, so user is not alerted of new message which is owned by user. +C + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + + IF (IER.EQ.0) THEN + WRITE (6,'('' Successful copy to folder '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + IF (MERGE) THEN + CALL LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END IF + ELSE IF (MERGE) THEN + WRITE (6,'('' ERROR: Copy aborted. No files copied.'')') + ELSE + WRITE (6,'('' ERROR: Copy aborted. '',I,'' files copied.'')') + & BULL_POINT - START_BULL_POINT + END IF + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + + BULL_POINT = SAVE_BULL_POINT + + IF (DELETE_ORIGINAL.AND.IER.EQ.0) THEN + IF (FROM_REMOTE.AND.ALL) THEN + WRITE (6,'('' WARNING: Original messages not deleted.'')') + WRITE (6,'('' Multiple deletions not possible for '', + & ''remote folders.'')') + ELSE + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + CALL DELETE + END IF + END IF + + RETURN + + END + + + + + SUBROUTINE PRINT +C +C SUBROUTINE PRINT +C +C FUNCTION: Print header to queue. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SJCDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + CHARACTER*32 QUEUE + + INTEGER*2 FILE_ID(14) + INTEGER*2 IOSB(4) + EQUIVALENCE (IOSB(1),JBC_ERROR) + + CHARACTER*31 FORM_NAME + + PARAMETER FF = CHAR(12) + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.LIS',ERR=900,IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + CALL ENABLE_PRIVS + + CALL OPEN_BULLDIR_SHARED + + CALL OPEN_BULLFIL_SHARED + + HEAD = CLI$PRESENT('HEADER') + + DO I=SBULL,EBULL + CALL READDIR(I,IER) ! Get info for specified message + + IF (IER.NE.I+1) THEN ! Was message found? + IF (I.EQ.SBULL) THEN ! No, were any messages found? + WRITE(6,1030) ! If not, then error out + CLOSE (UNIT=3,STATUS='DELETE') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + RETURN + END IF + ELSE ! Yes, message found. + IF (I.GT.SBULL) WRITE(3,'(A)') FF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + END IF + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(18,SJC$_FILE_SPECIFICATION, + & %LOC('SYS$LOGIN:BULL.LIS')) + + IER = CLI$GET_VALUE('QUEUE',QUEUE,ILEN) ! Get queue name + IF (ILEN.EQ.0) THEN + QUEUE = 'SYS$PRINT' + ILEN = 9 + END IF + + CALL ADD_2_ITMLST(ILEN,SJC$_QUEUE,%LOC(QUEUE)) + CALL ADD_2_ITMLST(0,SJC$_DELETE_FILE,0) + + IF (CLI$PRESENT('NOTIFY')) THEN + CALL ADD_2_ITMLST(0,SJC$_NOTIFY,0) + END IF + + IF (CLI$PRESENT('FORM')) THEN + IER = CLI$GET_VALUE('FORM',FORM_NAME,FORM_NAME_LEN) + CALL ADD_2_ITMLST(FORM_NAME_LEN,SJC$_FORM_NAME,%LOC(FORM_NAME)) + END IF + + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + + CALL END_ITMLST(SJC_ITMLST) + + IER=SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SJC_ITMLST),IOSB,,) + IF (IER.AND.(.NOT.JBC_ERROR)) THEN + CALL SYS_GETMSG(JBC_ERROR) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + ELSE IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + RETURN + +900 CALL ERRSNS(IDUMMY,IER) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + WRITE(6,1000) + CALL SYS_GETMSG(IER) + RETURN + +1000 FORMAT(' ERROR: Unable to open temporary file + & SYS$LOGIN:BULL.LIS for printing.') +1010 FORMAT(' ERROR: You have not read any message.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Specified message was not found.') +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A,/,'Date: ',A) + + END + + + + + SUBROUTINE READ(READ_COUNT,BULL_READ) +C +C SUBROUTINE READ +C +C FUNCTION: Reads a specified bulletin. +C +C PARAMETER: +C READ_COUNT - Variable to store the record in the message file +C that READ will read from. Must be set to 0 to indicate +C that it is the first read of the message. If -1, +C READ will search for the last message in the message file +C and read that one. If -2, just display header information. +C BULL_READ - Message number to be read. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /TAGS/ BULL_TAG,READ_TAG + + DATA SCRATCH_B1/0/ + + CHARACTER TODAY*11,DATETIME*23,BUFFER*(LINE_LENGTH) + CHARACTER SAVE_MSG_KEY*8 + + LOGICAL SINCE,PAGE + + CALL LIB$ERASE_PAGE(1,1) ! Clear screen + END = 0 ! Nothing outputted on screen + + IF (READ_COUNT.GT.0) GO TO 100 ! Skip init steps if this is + ! not first page of bulletin + + SINCE = .FALSE. + PAGE = .TRUE. + + IF (.NOT.PAGING) PAGE = .FALSE. + IF (INCMD(:4).EQ.'READ') THEN ! If READ command... + IF (CLI$PRESENT('MARKED')) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No marked messages found.'')') + RETURN + ELSE + READ_TAG = .TRUE. + END IF + END IF + + IF (.NOT.CLI$PRESENT('PAGE')) PAGE = .FALSE. + IF (CLI$PRESENT('SINCE')) THEN ! was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present.'')') + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + END IF + IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + CALL OPEN_BULLDIR_SHARED + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + RETURN + ELSE + BULL_READ = IER + IER = IER + 1 + END IF + SINCE = .TRUE. + END IF + END IF + + IF (READ_TAG) THEN + NEXT = .FALSE. + IF (INCMD(:4).EQ.'NEXT'.OR.INCMD.EQ.' ') THEN + NEXT = .TRUE. + ELSE IF (INCMD(:4).EQ.'READ') THEN + IF (.NOT.CLI$PRESENT('BULLETIN_NUMBER')) NEXT = .TRUE. + END IF + IF (INCMD(:4).EQ.'BACK') THEN + SAVE_MSG_KEY = MSG_KEY + MSG_KEY = BULLDIR_HEADER + I = 0 + IER = 0 + DO WHILE (IER.EQ.0.AND.MSG_KEY.NE.SAVE_MSG_KEY) + I = I + 1 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END DO + IF (IER.EQ.0) THEN + MSG_KEY = BULLDIR_HEADER + DO J=1,I-1 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END DO + IER = BULL_READ + 1 + ELSE + IER = 0 + END IF + ELSE IF (NEXT) THEN + IF (SINCE) THEN + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + ELSE + IF (BULL_POINT.GT.0) THEN + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) + CALL CLOSE_BULLDIR + ELSE + MSG_KEY = BULLDIR_HEADER + END IF + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END IF + IF (IER.EQ.0) THEN + IER = BULL_READ + 1 + ELSE + IER = 0 + END IF + END IF + END IF + + IF (.NOT.SINCE.AND. + & (.NOT.READ_TAG.OR.(.NOT.NEXT.AND.INCMD(:4).NE.'BACK'))) THEN + IF (BULL_READ.GT.0) THEN ! Valid bulletin number? + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_READ,IER) ! Get bulletin directory entry + IF (READ_COUNT.EQ.-1.AND.IER.NE.BULL_READ+1) THEN + READ_COUNT = 0 + CALL READDIR(0,IER) + IF (NBULL.GT.0) THEN + BULL_READ = NBULL + CALL READDIR(BULL_READ,IER) + ELSE + IER = 0 + END IF + END IF + CALL CLOSE_BULLDIR + ELSE + IER = 0 + END IF + END IF + + IF (IER.NE.BULL_READ+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + RETURN + END IF + + DIFF = COMPARE_BTIM(MSG_BTIM,LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF.GT.0) THEN + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = MSG_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = MSG_BTIM(2) + END IF + + BULL_POINT = BULL_READ ! Update bulletin counter + + IF (INCMD(:4).EQ.'READ'.OR.INCMD(:4).EQ.'CURR') THEN + IF (CLI$PRESENT('EDIT')) THEN + CALL READ_EDIT + RETURN + END IF + END IF + + FLEN = TRIM(FOLDER) + IF (BULL_POINT.GT.F_NBULL) F_NBULL = BULL_POINT + WRITE (INPUT,'(1X,I5,'' of '',I5)') BULL_POINT,F_NBULL + DO WHILE (INDEX(INPUT,' ').LT.TRIM(INPUT)) + I = INDEX(INPUT,' ') + INPUT(I:) = INPUT(I+1:) + END DO + I = TRIM(INPUT) + INPUT = ' #'//INPUT(2:TRIM(INPUT)) + INPUT(PAGE_WIDTH-LEN(FOLDER):) = FOLDER(:FLEN) + IF (READIT.GT.0) THEN + WRITE(6,'(A)') '+'//INPUT(:TRIM(INPUT)) + ELSE + WRITE(6,'(1X,A)') INPUT(:TRIM(INPUT)) + END IF + + END = 1 ! Outputted 1 line to screen + + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + WRITE (6,'(1X,A)') INPUT(:TRIM(INPUT)) + + END = END + 1 + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + LINE_OFFSET = 0 + CHAR_OFFSET = 0 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INPUT = 'From: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + WRITE(6,'(1X,A)') INPUT(:I) + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = 1 + ELSE + WRITE(6,'('' From: '',A)') FROM + END = END + 1 + END IF + IF (INPUT(:6).NE.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + INPUT = 'Subj: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + WRITE(6,'(1X,A)') INPUT(:I) + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = LINE_OFFSET + 1 + ELSE + IF (LINE_OFFSET.EQ.1) THEN + CHAR_OFFSET = 1 - PAGE_WIDTH + LINE_OFFSET = 2 + END IF + WRITE(6,'('' Subj: '',A)') DESCRIP + END = END + 1 + END IF + IF (LINE_OFFSET.EQ.0) ILEN = LINE_LENGTH + 1 + CALL CLOSE_BULLFIL ! End of bulletin file read + + WRITE(6,'(1X)') + IF (READIT.GT.0) WRITE(6,'(1X)') + END = END + 1 +C +C Each page of the bulletin is buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C bulletin file, and to avoid the possibility of the user holding the screen, +C and thus causing the bulletin file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_B1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + IF (SCRATCH_B1.NE.0) THEN ! Is queue empty? + SCRATCH_B = SCRATCH_B1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_B,INPUT) + SCRATCH_B1 = SCRATCH_B ! Init header pointer + END IF + + READ_ALREADY = 0 ! Number of lines already read + ! from record. + IF (READ_COUNT.EQ.-2) THEN ! Just output header first read + READ_COUNT = BLOCK + RETURN + ELSE + READ_COUNT = BLOCK ! Init bulletin record counter + END IF + + GO TO 200 + +100 IF (READIT.EQ.0) THEN ! If not 1st page of READ + WRITE (BUFFER,'(1X,I5,'' of '',I5)') BULL_POINT,F_NBULL + DO WHILE (INDEX(BUFFER,' ').LT.TRIM(BUFFER)) + I = INDEX(BUFFER,' ') + BUFFER(I:) = BUFFER(I+1:) + END DO + BUFFER = ' #'//BUFFER(2:TRIM(BUFFER)) + BUFFER(PAGE_WIDTH-LEN(FOLDER):) = FOLDER(:FLEN) + WRITE(6,'(1X,A,/)') BUFFER(:TRIM(BUFFER)) ! Output header info + END = END + 2 ! Increase display counter + END IF + +200 SCRATCH_B = SCRATCH_B1 ! Init queue pointer to header + IF (READIT.GT.0) END = END - 2 ! /READ can output 2 more lines + DISPLAY = 0 + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + MORE_LINES = .TRUE. + DO WHILE (ILEN.GT.0.AND.MORE_LINES) + IF (CHAR_OFFSET.EQ.0) THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + LINE_OFFSET = LINE_OFFSET + 1 + END IF + IF (ILEN.LT.0) THEN ! Error, couldn't read record + ILEN = 0 ! Fake end of reading file + MORE_LINES = .FALSE. + ELSE IF (ILEN.GT.0) THEN + IF (CHAR_OFFSET.EQ.0) THEN + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (LEN_TEMP.GT.PAGE_WIDTH) THEN + CHAR_OFFSET = 1 + BUFFER = INPUT(:PAGE_WIDTH) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + ELSE + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,INPUT) + END IF + ELSE + CHAR_OFFSET = CHAR_OFFSET + PAGE_WIDTH + IF (LEN_TEMP.LE.CHAR_OFFSET+PAGE_WIDTH-1) THEN + BUFFER = INPUT(CHAR_OFFSET:LEN_TEMP) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + CHAR_OFFSET = 0 + ELSE + BUFFER = INPUT(CHAR_OFFSET:CHAR_OFFSET+PAGE_WIDTH-1) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + END IF + END IF + DISPLAY = DISPLAY + 1 + IF ((DISPLAY.EQ.PAGE_LENGTH-END-4).AND.PAGE) THEN + MORE_LINES = .FALSE. + END IF + END IF + END DO + + CALL CLOSE_BULLFIL ! End of bulletin file read + +C +C Bulletin page is now in temporary memory, so output to terminal. +C Note that if this is a /READ, the first line will have problems with +C the usual FORMAT statement. It will cause a blank line to be outputted +C at the top of the screen. This is because of the input QIO at the +C end of the previous page. The output gets confused and thinks it must +C end the previous line. To prevent that, the first line of a new page +C in a /READ must use a different FORMAT statement to surpress the CR/LF. +C + + SCRATCH_B = SCRATCH_B1 ! Reinit queue pointer to head + DO I=1,DISPLAY ! Output page to terminal + CALL READ_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) ! Get queue record + IF (I.EQ.1.AND.READIT.GT.0) THEN + WRITE(6,'(A)') '+'//BUFFER(:TRIM(BUFFER)) ! (See above comments) + ELSE + WRITE(6,'(1X,A)') BUFFER(:TRIM(BUFFER)) + END IF + END DO + + IF (ILEN.EQ.0) THEN ! End of message? + READ_COUNT = 0 ! init bulletin record counter + ELSE ! Possibly end of message since end of page could be last line + CALL TEST_MORE_RECORDS(BLOCK,LENGTH,IREC) + IF (IREC.EQ.0) THEN ! Last record? + CALL TEST_MORE_LINES(ILEN) ! More lines to read? + IF (ILEN.GT.0) THEN ! Yes, there are still more + IF (READIT.EQ.0) WRITE(6,1070) ! say there is more of bulletin + ELSE ! Yes, last line anyway + READ_COUNT = 0 ! init bulletin record counter + END IF + ELSE IF (READIT.EQ.0) THEN ! Not last record so + WRITE(6,1070) ! say there is more of bulletin + END IF + END IF + + RETURN + +1030 FORMAT(' ERROR: Specified message was not found.') +1070 FORMAT(1X,/,' Press RETURN for more...',/) + +2000 FORMAT(A) + + END + + + + + + SUBROUTINE READ_EDIT + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + WRITE(3,1050) INPUT(7:ILEN) + ELSE + WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + CALL CLOSE_BULLFIL + + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A,' Date: ',A) + + RETURN + END + + + SUBROUTINE READNEW(REDO) +C +C SUBROUTINE READNEW +C +C FUNCTION: Displays new non-system bulletins with prompts between bulletins. +C + + IMPLICIT INTEGER (A-Z) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /POINT/ BULL_POINT + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + CHARACTER INREAD*1,FILE_DEF*80,NUMREAD*5 + + DATA LEN_FILE_DEF /0/, INREAD/0/ + + LOGICAL SLOW,SLOW_TERMINAL + + FIRST_MESSAGE = BULL_POINT + + IF (ICHAR(INREAD).EQ.0) THEN ! If calling READNEW for first time + SLOW = SLOW_TERMINAL() ! Check baud rate of terminal + END IF ! to avoid gobs of output + + LEN_P = 0 ! Tells read subroutine there is + ! no bulletin parameter + +1 WRITE(6,1000) ! Ask if want to read new bulletins + + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0) THEN + INREAD = NUMREAD(:1) + IF (INREAD.EQ.'N'.OR.INREAD.EQ.'Q'.OR.INREAD.EQ.'E') THEN + IF (INREAD.EQ.'Q') THEN + WRITE (6,'(''+uit'',$)') + ELSE IF (INREAD.EQ.'E') THEN + WRITE (6,'(''+xit'',$)') + DO I=1,FLONG ! Just show SYSTEM folders + NEW_MSG(I) = NEW_MSG(I).AND.SYSTEM_FLAG(I) + END DO + DO I=1,FLONG ! Test for new messages in SYSTEM folders + IF (NEW_MSG(I).NE.0) RETURN + END DO + CALL EXIT + ELSE + WRITE (6,'(''+o'',$)') + END IF + RETURN ! If NO, exit + ! Include QUIT to be consistent with next question + ELSE + CALL LIB$ERASE_PAGE(1,1) + END IF + END IF + +3 IF (TEMP_READ.GT.0) THEN + IF (TEMP_READ.LT.FIRST_MESSAGE+1.OR.TEMP_READ.GT.NBULL) THEN + WRITE (6,'('' ERROR: Specified new message not found.'')') + GO TO 1 + ELSE + BULL_POINT = TEMP_READ - 1 + END IF + END IF + + READ_COUNT = 0 ! Initialize display pointer + +5 CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + FILE_POINT = BULL_POINT + IF (READ_COUNT.EQ.0) THEN ! Is full bulletin displayed? + CALL OPEN_BULLDIR_SHARED ! If so, see if more new bulls +10 CALL READDIR(BULL_POINT+1,IER_POINT) + IF ((IER_POINT.EQ.BULL_POINT+2).AND. ! If system bulletin (and system + & (SYSTEM.AND.BTEST(FOLDER_FLAG,2))) THEN ! folder) then skip it. + BULL_POINT = BULL_POINT + 1 + GO TO 10 + END IF + CALL CLOSE_BULLDIR + END IF + +12 IF (READ_COUNT.EQ.0) THEN ! Prompt user in between + WRITE(6,1020) ! full screens or end of bull. + ELSE + WRITE(6,1030) + END IF + + CALL GET_INPUT_NOECHO(INREAD) + CALL STR$UPCASE(INREAD,INREAD) ! Convert input to upper case + + IF (INREAD.EQ.'Q') THEN ! If Q , then QUIT + WRITE (6,'(''+Quit'',$)') + RETURN + ELSE IF (INREAD.EQ.'D') THEN ! If D , then redisplay directory + WRITE (6,'(''+Dir'',$)') + REDO = .TRUE. + RETURN + ELSE IF (INREAD.EQ.'F') THEN ! If F then copy bulletin to file + WRITE (6,'(''+ '')') ! Move cursor from end of prompt line + ! to beginning of next line. + IF (LEN_FILE_DEF.EQ.0) THEN + CALL LIB$SYS_TRNLOG('SYS$LOGIN',ILEN,FILE_DEF) + IER = LIB$FIND_FILE(FILE_DEF//'BULL.DIR', + & BULL_PARAMETER,CONTEXT) + IF (IER) THEN + FILE_DEF = BULL_PARAMETER(:ILEN-1)//'.BULL]' + LEN_FILE_DEF = ILEN + 5 + ELSE + FILE_DEF = 'SYS$LOGIN:' + LEN_FILE_DEF = 10 + END IF + END IF + + LEN_FOLDER = TRIM(FOLDER) + CALL GET_INPUT_PROMPT(BULL_PARAMETER,LEN_P, + & 'Name of file? (Default='//FILE_DEF(:LEN_FILE_DEF)// + & FOLDER(:LEN_FOLDER)//'.LIS) ') + + IF (LEN_P.EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)//FOLDER(:LEN_FOLDER) + & //'.LIS' + LEN_P = LEN_FILE_DEF + LEN_FOLDER + 4 + ELSE + IER = LIB$SYS_TRNLOG(BULL_PARAMETER(:LEN_P),ILEN,INPUT) + IF (IER.NE.1.AND.INDEX(BULL_PARAMETER(:LEN_P),':').EQ.0 + & .AND.INDEX(BULL_PARAMETER(:LEN_P),'[').EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)// + & BULL_PARAMETER(:LEN_P) + LEN_P = LEN_P + LEN_FILE_DEF + END IF + END IF + + BLOCK_SAVE = BLOCK + LENGTH_SAVE = LENGTH + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + CALL READDIR(FILE_POINT,IER) + IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV + CALL DISABLE_PRIVS ! privileges when trying to + END IF ! create new file. + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH,ERR=18,STATUS='UNKNOWN', + & CARRIAGECONTROL='LIST',ACCESS='APPEND') + WRITE(3,1050) DESCRIP ! Output bulletin header info + WRITE(3,1060) FROM,DATE//' '//TIME(:5) + ILEN = LINE_LENGTH + 1 + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE(3,'(A)') INPUT(:TRIM(INPUT)) + END DO + IF (ILEN.EQ.0) WRITE(6,1040) BULL_PARAMETER(:LEN_P) + ! Show name of file created. +18 IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + END IF + CLOSE (UNIT=3) ! Bulletin copy completed + IF (READ_COUNT.GT.0) THEN ! Reposition GET_BULL routine + ILEN = LINE_LENGTH + 1 ! in case read in progress + DO I=1,LINE_OFFSET ! and partial block was read. + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + END IF + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + LENGTH = LENGTH_SAVE + BLOCK = BLOCK_SAVE + CALL ENABLE_PRIVS ! Reset BYPASS privileges + GO TO 12 + ELSE IF (INREAD.EQ.'N'.AND.READ_COUNT.GT.0) THEN + ! If NEXT and last bulletins not finished + READ_COUNT = 0 ! Reset read bulletin counter + CALL OPEN_BULLDIR_SHARED ! Look for NEXT bulletin +20 CALL READDIR(BULL_POINT+1,IER) + IF (IER.NE.BULL_POINT+2) THEN ! If no NEXT bulletin + CALL CLOSE_BULLDIR ! Exit + WRITE(6,1010) + RETURN + ELSE IF (SYSTEM.AND.BTEST(FOLDER_FLAG,2)) THEN + BULL_POINT = BULL_POINT + 1 ! If SYSTEM bulletin, skip it + GO TO 20 ! Look for more bulletins + END IF + CALL CLOSE_BULLDIR + ELSE IF (INREAD.EQ.'R') THEN + WRITE (6,'(''+Read'')') + WRITE (6,'('' Enter message number: '',$)') + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0.OR.TEMP_READ.LE.0) THEN + WRITE (6,'('' ERROR: Invalid message number specified.'')') + GO TO 12 + ELSE + GO TO 3 + END IF + ELSE IF (IER_POINT.NE.BULL_POINT+2.AND.READ_COUNT.EQ.0) THEN + WRITE(6,1010) + RETURN + END IF + IF (READ_COUNT.EQ.0.AND.SLOW) READ_COUNT = -2 + GO TO 5 + +1000 FORMAT(' Read messages? Type N(No),E(Exit),message + & number, or any other key for yes: ',$) +1010 FORMAT(' No more messages.') +1020 FORMAT(1X,('-'),/,' Type Q(Quit), + & F(File it), D(Dir), R(Read msg #) or other for next message: ',$) +1030 FORMAT(1X,('-'),/,' Type Q(Quit), F(File), N(Next), + & D(Dir), R(Read msg #) or other for MORE: ',$) +1040 FORMAT(' Message written to ',A) +1050 FORMAT(/,'Description: ',A53) +1060 FORMAT('From: ',A12,' Date: ',A20,/) + + END + + + + + SUBROUTINE SET_DEFAULT_EXPIRE +C +C SUBROUTINE SET_DEFAULT_EXPIRE +C +C FUNCTION: Sets default expiration date. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER EXPIRE*3 + + IF (SETPRV_PRIV().OR.USERNAME.EQ.FOLDER_OWNER) THEN + IER = CLI$GET_VALUE('DEFAULT_EXPIRE',EXPIRE,EX_LEN) + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + ELSE IF (TEMP.LT.-1) THEN + WRITE (6,'('' ERROR: Expiration must be > -1.'')') + ELSE + FOLDER_BBEXPIRE = TEMP + WRITE (6,'('' Default expiration modified.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to set expiration.'')') + END IF + + RETURN + END diff --git a/decus/vax90a/bulletin/bulletin2.for b/decus/vax90a/bulletin/bulletin2.for new file mode 100644 index 0000000..3af8357 --- /dev/null +++ b/decus/vax90a/bulletin/bulletin2.for @@ -0,0 +1,1518 @@ +C +C BULLETIN2.FOR, Version 2/16/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE SET_BBOARD(BBOARD) +C +C SUBROUTINE SET_BBOARD +C +C FUNCTION: Set username for BBOARD for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($UAIDEF)' + + EXTERNAL CLI$_ABSENT + + CHARACTER EXPIRE*3,INPUT_BBOARD*12,TODAY*23,RESPONSE*1 + + IF (TRIM(BBOARD_DIRECTORY).EQ.0) THEN + WRITE(6,'('' ERROR: System programmer has disabled BBOARD.'')') + RETURN + END IF + + IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + WRITE (6,'( + & '' ERROR: Cannot set BBOARD for remote folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + + IF (BBOARD) THEN + IER = CLI$GET_VALUE('BB_USERNAME',INPUT_BBOARD,INPUT_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_UAF + & (INPUT_BBOARD,USERB,GROUPB,ACCOUNTB,FLAGS,IER1) + CALL CLOSE_BULLFOLDER + IF (IER1.AND..NOT.BTEST(FLAGS,UAI$V_DISACNT)) THEN ! DISUSER? + WRITE (6,'('' ERROR: '',A, + & '' account needs DISUSER flag set.'')') + & INPUT_BBOARD(:INPUT_LEN) + RETURN + ELSE IF (IER1.AND.BTEST(USERB,31)) THEN + WRITE (6,'('' ERROR: User number of UIC cannot '', + & ''be greater than 7777777777.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_TEMP(IER) + DO WHILE ((FOLDER1_BBOARD.NE.INPUT_BBOARD.OR. + & FOLDER1_NUMBER.EQ.FOLDER_NUMBER).AND.IER.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER) + END DO + IF (FOLDER1_BBOARD.EQ.INPUT_BBOARD.AND. + & FOLDER1_NUMBER.NE.FOLDER_NUMBER) THEN + WRITE (6,'( + & '' ERROR: Account used by other folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + IF (.NOT.IER1) THEN + CALL CLOSE_BULLFOLDER + WRITE (6,'('' WARNING: '',A,'' account not in SYSUAF'', + & '' file.'')') INPUT_BBOARD(:INPUT_LEN) + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Is the name a mail forwarding entry? '// + & '(Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + USERB = 1 ! Fake userb/groupb, as old method of + GROUPB = 1 ! indicating /SPECIAL used [0,0] + END IF + GROUPB1 = GROUPB + USERB1 = USERB + ACCOUNTB1 = ACCOUNTB + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + GROUPB = GROUPB1 + USERB = USERB1 + ACCOUNTB = ACCOUNTB1 + FOLDER_BBOARD = INPUT_BBOARD + CALL OPEN_BULLUSER + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM(TODAY,BBOARD_BTIM) + REWRITE (4) USER_HEADER + CALL CLOSE_BULLUSER + IF (CLI$PRESENT('SPECIAL')) THEN ! SPECIAL specified? + USERB = IBSET(USERB,31) ! Set bit to show /SPECIAL + IF (CLI$PRESENT('VMSMAIL')) THEN + GROUPB = IBSET(GROUPB,31) ! Set bit to show /VMSMAIL + END IF + END IF + ELSE IF (CLI$PRESENT('SPECIAL')) THEN + USERB = IBSET(0,31) ! Set top bit to show /SPECIAL + GROUPB = 0 + DO I=1,LEN(FOLDER_BBOARD) + FOLDER_BBOARD(I:I) = ' ' + END DO + ELSE IF (FOLDER_BBOARD.EQ.'NONE') THEN + WRITE (6,'('' ERROR: No BBOARD specified for folder.'')') + END IF + + IER = CLI$GET_VALUE('EXPIRATION',EXPIRE,EX_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (TEMP.LE.0) THEN + WRITE (6,'('' ERROR: Expiration must be > 0.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + FOLDER_BBEXPIRE = TEMP + END IF + ELSE IF (.NOT.CLI$PRESENT('EXPIRATION')) THEN + FOLDER_BBEXPIRE = -1 + END IF + ELSE + FOLDER_BBOARD = 'NONE' + END IF + + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + WRITE (6,'('' BBOARD has been modified for folder.'')') + ELSE + WRITE (6,'('' You are not authorized to modify BBOARD.'')') + END IF + + RETURN + END + + + + + + + SUBROUTINE SET_SYSTEM(SYSTEM_SET) +C +C SUBROUTINE SET_SYSTEM +C +C FUNCTION: Set SYSTEM specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + ELSE IF (SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (SYSTEM_SET) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been set.'')') + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been removed.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL MODIFY_SYSTEM_LIST(0) + CALL CLOSE_BULLFOLDER + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + ELSE + WRITE (6,'('' You are not authorized to modify SYSTEM.'')') + END IF + + RETURN + END + + + + SUBROUTINE MODIFY_SYSTEM_LIST(FILE_OPENED) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + INTEGER SHUTDOWN_BTIM(FLONG),VERSION(FLONG) + + CHARACTER UPDATE*11,UPTIME*8 + + INTEGER UP_BTIM(2) + + IF (.NOT.FILE_OPENED) CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0.OR.VERSION(1).NE.168) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + SHUTDOWN_BTIM(1) = 0 + SHUTDOWN_BTIM(2) = 0 + NODE_NUMBER = 0 + NODE_AREA = 0 + IF (IER.EQ.0) THEN + DO WHILE (TEMP_USER(:7).EQ.'*SYSTEM'.AND.IER.EQ.0) + DELETE (UNIT=4) + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) TEMP_USER + END DO + END DO + IER = 2 + ELSE + VERSION(1) = 168 + END IF + END IF + + IF (VERSION(1).NE.168) THEN + CALL CLOSE_BULLFOLDER + CALL OPEN_BULLFOLDER + NODE_AREA = 0 + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + END DO + IER1 = 0 + DO WHILE (IER1.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER1) + IF (BTEST(FOLDER1_FLAG,2).AND.IER1.EQ.0) THEN + CALL SET2(SYSTEM_FLAG,FOLDER1_NUMBER) + END IF + END DO + VERSION(1) = 168 + END IF + + IF (BTEST(FOLDER_FLAG,2)) THEN + CALL SET2(SYSTEM_FLAG,FOLDER_NUMBER) + ELSE + CALL CLR2(SYSTEM_FLAG,FOLDER_NUMBER) + END IF + + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14,BTEST(FOLDER_FLAG,2), + & NODENAME + IF (IER1.NE.0) THEN + CALL DISCONNECT_REMOTE + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + RETURN + END IF + END IF + + CALL GET_UPTIME(UPDATE,UPTIME) + + CALL SYS_BINTIM(UPDATE//' '//UPTIME,UP_BTIM) + + IF (NODE_AREA.EQ.0) THEN + IF (SHUTDOWN_BTIM(1).EQ.0) THEN + DIFF = -1 + ELSE + DIFF = COMPARE_BTIM(SHUTDOWN_BTIM,UP_BTIM) + END IF + IF (DIFF.EQ.-1) THEN + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + SHUTDOWN_BTIM(1) = UP_BTIM(1) + SHUTDOWN_BTIM(2) = UP_BTIM(2) + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + END IF + ELSE ! Test to make sure NODE_AREA is zero + SEEN_FLAG = 0 ! if all of SHUTDOWN_FLAG is zero + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 + END IF + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + + RETURN + END + + + + SUBROUTINE GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) + CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) + CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist + + IER = SYS$GETSYIW(,,,%VAL(GETSYI_ITMLST),,,) ! Get Info command. +C +C NODE_AREA is set to 0 after shutdown messages are deleted. +C If node is not part of cluster, NODE_AREA will be 0, +C so set it to 1 as a dummy value to cause messages to be deleted. +C + IF (NODE_AREA.EQ.0) NODE_AREA = 1 + + RETURN + END + + + + + SUBROUTINE SET_NODE(NODE_SET) +C +C SUBROUTINE SET_NODE +C +C FUNCTION: Set or reset remote node specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,FOLDER_SAVE*25 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) ! Get folder name + FOLDER_SAVE = FOLDER + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + IF (IER.EQ.0) THEN + IF (FOLDER_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: No privs to modify folder.'')') + IER = 1 + END IF + ELSE + WRITE (6,'('' ERROR: Specified folder not found.'')') + END IF + IF (IER.NE.0) THEN + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + RETURN + END IF + CALL CLOSE_BULLFOLDER + END IF + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' Cannot set remote node for GENERAL folder.'')') + ELSE IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + IF (.NOT.NODE_SET) THEN + IF (INDEX(FOLDER_BBOARD,'*').GT.0) THEN + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + CALL OPEN_BULLDIR ! Remove directory file which + CALL CLOSE_BULLDIR_DELETE ! contains remote folder name + REMOTE_SET = REMOTE_SET_SAVE + END IF + FOLDER1_BBOARD = 'NONE' + WRITE (6,'('' Remote node setting has been removed.'')') + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .FALSE. + ELSE + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Are you sure you want to make folder '// + & FOLDER(:TRIM(FOLDER))// + & ' remote? (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + IER = CLI$GET_VALUE('NODENAME',FOLDER1_BBOARD,FLEN) + FOLDER1_BBOARD = '::'//FOLDER1_BBOARD(:FLEN) + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'( + & '' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE + WRITE (6,'('' Folder has been converted to remote.'')') + END IF + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + IF (FOLDER.NE.FOLDER1) THEN ! Different remote folder name? + CALL OPEN_BULLDIR ! If so, put name in header + BULLDIR_HEADER(13:) = FOLDER1 ! of directory file. + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:FLEN+2)//'*' + END IF + REMOTE_SET = REMOTE_SET_SAVE + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .TRUE. + END IF + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (.NOT.NODE_SET.AND.FOLDER_BBOARD(:2).EQ.'::' + & .AND.BTEST(FOLDER_FLAG,2)) THEN + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER_BBOARD(3:TRIM(FOLDER_BBOARD)) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Disregister remote SYSTEM folder + WRITE(17,'(2A)',IOSTAT=IER) 14,0 + CLOSE (UNIT=17) + END IF + END IF + FOLDER_BBOARD = FOLDER1_BBOARD + IF (NODE_SET) THEN + F_NBULL = F1_NBULL + F_NEWEST_BTIM(1) = F1_NEWEST_BTIM(1) + F_NEWEST_BTIM(2) = F1_NEWEST_BTIM(2) + F_NEWEST_NOSYS_BTIM(1) = F1_NEWEST_NOSYS_BTIM(1) + F_NEWEST_NOSYS_BTIM(2) = F1_NEWEST_NOSYS_BTIM(2) + FOLDER_FLAG = 0 + F_EXPIRE_LIMIT = F1_EXPIRE_LIMIT + ELSE + F_NBULL = 0 + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to modify NODE.'')') + END IF + + IF (CLI$PRESENT('FOLDER')) THEN + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + END IF + + RETURN + END + + + + + SUBROUTINE RESPOND(STATUS) +C +C SUBROUTINE RESPOND +C +C FUNCTION: Sends a mail message in reply to a posted message. +C +C NOTE: Modify the last SPAWN statement to specify the command +C you use to send mail to sites other than via MAIL. +C If you always use a different command, modify both +C spawn commands. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER FROM_TEST*5,INFROM*(LINE_LENGTH) + + EXTERNAL CLI$_NEGATED + + IF (INCMD(:4).NE.'POST') THEN + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + CALL STR$UPCASE(BULL_PARAMETER,DESCRIP) + IF (BULL_PARAMETER(:3).NE.'RE:') THEN + BULL_PARAMETER = 'RE: '//DESCRIP + ELSE + BULL_PARAMETER = 'RE:'//DESCRIP(4:) + END IF + END IF + + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',BULL_PARAMETER,LEN_P) + IF (LEN_P.GT.LEN(BULL_PARAMETER)-2) THEN + WRITE(6,'('' ERROR: Subject limit is 64 characters.'')') + RETURN + END IF + ELSE IF (INCMD(:4).EQ.'POST') THEN + WRITE(6,'('' Enter subject of message:'')') + CALL GET_LINE(BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.0) THEN + WRITE(6,'('' ERROR: No subject specified.'')') + RETURN + END IF + END IF + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + EDIT = .TRUE. + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + ELSE + EDIT = .FALSE. + END IF + + TEXT = CLI$PRESENT('TEXT').OR.CLI$PRESENT('EXTRACT') + + IF (EDIT.AND.TEXT) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + RETURN + END IF + ELSE IF (TEXT.AND..NOT.EDIT) THEN + WRITE (6,'('' ERROR: Cannot extract text without /EDIT.'')') + RETURN + END IF + + LENFRO = 0 + IF (CLI$GET_VALUE('CC',INPUT,ILEN)) THEN + INFROM = INPUT(:ILEN)//',' + LENFRO = ILEN + 1 + END IF + + IF ((EDIT.AND.TEXT).OR.INCMD(:4).NE.'POST') THEN + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INFROM = INFROM(:LENFRO)//INPUT(7:) + LENFRO = LENFRO + ILEN - 6 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + INFROM = INFROM(:LENFRO)//FROM + LENFRO = TRIM(FROM) + LENFRO + END IF + + IF (CLI$PRESENT('LIST')) THEN + INFROM = INFROM(:LENFRO)//',' + LENFRO = LENFRO + 1 + END IF + + IF (INCMD(:4).EQ.'POST') LENFRO = 0 + + IF (EDIT.AND.TEXT) THEN + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + + CALL CLOSE_BULLFIL + END IF + + IF (CLI$PRESENT('LIST')) THEN + LIST = INDEX(FOLDER_DESCRIP,'<') + IF (LIST.GT.0) THEN + INFROM = INFROM(:LENFRO)// + & FOLDER_DESCRIP(LIST+1:TRIM(FOLDER_DESCRIP)-1) + LENFRO = LENFRO + TRIM(FOLDER_DESCRIP) - 1 - LIST + ELSE + WRITE (6,'('' ERROR: No list address'', + & '' found in folder description.'')') + GO TO 900 + END IF + END IF + + I = 1 ! Must change all " to "" in FROM field + DO WHILE (I.LE.LENFRO) + IF (INFROM(I:I).EQ.'"') THEN + INFROM = INFROM(:I)//'"'//INFROM(I+1:) + I = I + 1 + LENFRO = LENFRO + 1 + END IF + I = I + 1 + END DO + + LEN_P = TRIM(BULL_PARAMETER) + I = 1 ! Must change all " to "" in SUBJECT field + DO WHILE (I.LE.LEN_P) + IF (BULL_PARAMETER(I:I).EQ.'"') THEN + IF (LEN_P.EQ.64) THEN + BULL_PARAMETER(I:I) = '`' + ELSE + BULL_PARAMETER = BULL_PARAMETER(:I)//'"' + & //BULL_PARAMETER(I+1:) + I = I + 1 + LEN_P = LEN_P + 1 + END IF + END IF + I = I + 1 + END DO + CALL DISABLE_PRIVS + IF (EDIT) THEN + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + IF (TEXT) THEN + CONTEXT = 0 + CALL LIB$FIND_FILE('SYS$LOGIN:BULL.SCR',INPUT,CONTEXT) + VERSION = INDEX(INPUT,';') + 1 + IF (INPUT(VERSION:VERSION).EQ.'1') THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + END IF + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR "'//INFROM(:LENFRO) + & //'"/SUBJECT="'//BULL_PARAMETER//'"',,,,,,STATUS) + ELSE + CALL LIB$SPAWN('$MAIL SYS$INPUT "'//INFROM(:LENFRO)// + & '"/SUBJECT="'//BULL_PARAMETER//'"',,,,,,STATUS) + END IF + CALL ENABLE_PRIVS + +900 IF (EDIT) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + + END + + + INTEGER FUNCTION CONFIRM_USER(USERNAME) +C +C FUNCTION CONFIRM_USER +C +C FUNCTION: Confirms that username is valid user. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + CALL OPEN_SYSUAF_SHARED + + READ (8,KEY=USERNAME,IOSTAT=CONFIRM_USER) + + CALL CLOSE_SYSUAF + + RETURN + END + + + + + + SUBROUTINE REPLACE +C +C SUBROUTINE REPLACE +C +C FUNCTION: Replaces existing bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER INEXDATE*11,INEXTIME*11 + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH) + CHARACTER*1 ANSWER + + CHARACTER DATE_SAVE*11,TIME_SAVE*11 + + INTEGER TIMADR(2) + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + LOGICAL*1 DOALL + +C +C Get the bulletin number to be replaced. +C + IF (.NOT.CLI$PRESENT('NUMBER')) THEN ! No number has been specified + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE (6,1005) ! Tell user of the error + RETURN ! and return + END IF + NUMBER_PARAM = BULL_POINT ! Replace the bulletin we are reading + ELSE + CALL CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + DECODE(LEN_P,'(I)',BULL_PARAMETER) NUMBER_PARAM + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to system.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SYSTEM cannot be set with selected folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to shutdown.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SHUTDOWN cannot be set with selected folder.'')') + RETURN + ELSE IF (CLI$GET_VALUE('SHUTDOWN',BULL_PARAMETER).NE. + & %LOC(CLI$_ABSENT).AND.REMOTE_SET) THEN + WRITE (6,'('' ERROR: Shutdown node name not'', + & '' permitted for remote folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('PERMANENT').AND. + & .NOT.FOLDER_SET.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to permanent.'')') + RETURN + END IF +C +C Check to see if specified bulletin is present, and if the user +C is permitted to replace the bulletin. +C + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(NUMBER_PARAM,IER) ! Get info for specified bulletin + + CALL CLOSE_BULLDIR + + IF (IER.NE.NUMBER_PARAM+1) THEN ! Was bulletin found? + WRITE (6,1015) ! If not, tell the person + RETURN ! and error out + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.SETPRV_PRIV().AND. + & USERNAME.NE.FOLDER_OWNER.AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1090) ! If not, then error out. + RETURN + ELSE + WRITE (6,1100) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER ! Get his answer + CALL STR$UPCASE(ANSWER,ANSWER) ! Convert input to uppercase + IF (ANSWER.NE.'Y') RETURN ! If not Yes, then exit + END IF + END IF + +C +C If no switches were given, replace the full bulletin +C + + DOALL = .FALSE. + + TEXT = CLI$PRESENT('TEXT').OR.CLI$PRESENT('EXTRACT') + + IF (TEXT) THEN + IF (.NOT.((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If no /EDIT + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)))) THEN + WRITE (6,'('' ERROR: Cannot extract text without /EDIT.'')') + RETURN + END IF + END IF + + IF ((.NOT.CLI$PRESENT('EXPIRATION')).AND. + & (.NOT.CLI$PRESENT('GENERAL')).AND. + & (.NOT.CLI$PRESENT('SYSTEM')).AND. + & (.NOT.CLI$PRESENT('HEADER')).AND. + & (.NOT.CLI$PRESENT('SUBJECT')).AND. + & (.NOT.TEXT).AND. + & (.NOT.CLI$PRESENT('SHUTDOWN')).AND. + & (.NOT.CLI$PRESENT('PERMANENT'))) THEN + DOALL = .TRUE. + END IF + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + +8 LENDES = 0 + IF (CLI$PRESENT('HEADER').OR.DOALL) THEN + WRITE(6,1050) ! Request header for bulletin + READ(5,'(Q,A)',END=910,ERR=910) LENDES,INDESCRIP + IF (LENDES.EQ.0) GO TO 910 ! If no header, don't add bull + ELSE IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + END IF + + IF (LENDES.GT.0) THEN + INDESCRIP = 'Subj: '//INDESCRIP + LENDES = MIN(LENDES+6,LEN(INDESCRIP)) + END IF + + REC1 = 0 + + LENFROM = 0 + + IF (LENDES.GT.0.OR.TEXT.OR.DOALL) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='SCRATCH',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + REC1 = 1 + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INFROM = INPUT(:ILEN) + LENFROM = ILEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (LENDES.EQ.0.AND..NOT.DOALL) THEN + INDESCRIP = INPUT(:ILEN) + LENDES = ILEN + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + CALL CLOSE_BULLFIL + + IF (TEXT.OR.DOALL) CLOSE(UNIT=3) + END IF + + IF (TEXT.OR.DOALL) THEN +C +C If file specified in REPLACE command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + ICOUNT = 0 ! Line count for bulletin + LAST_NOBLANK = 0 ! Last line with data + REC1 = 1 + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT).OR. ! If file param in ADD command + & ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! or /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)))) THEN + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + IF (LEN_P.EQ.0) THEN ! If no file param specified + IF (.NOT.CLI$PRESENT('NEW')) THEN + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='NEW', + & RECL=LINE_LENGTH, + & ERR=920,FORM='FORMATTED',CARRIAGECONTROL='LIST') + CALL OPEN_BULLFIL_SHARED ! Prepare to copy message + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy message into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + CALL CLOSE_BULLFIL + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + ELSE + IF (.NOT.SETPRV_PRIV()) CALL DISABLE_PRIVS + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + END IF + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;-1') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + ELSE IF (LEN_P.GT.0) THEN + IF (.NOT.SETPRV_PRIV()) CALL DISABLE_PRIVS + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD', + & READONLY,SHARED,ERR=920,FORM='FORMATTED') ! Try opening the file + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT ! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + CALL STR$TRIM(INPUT,INPUT,ILEN) + IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN + 1 ! Increment record count + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0) THEN + IF (ICOUNT.GT.0) THEN + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + ELSE ! 1 space for a blank line. + REC1 = REC1 + 1 + END IF + END IF + END DO + ELSE ! If no input file + OPEN (UNIT=3,STATUS='NEW',FILE='SYS$LOGIN:BULL.SCR',ERR=920, + & DISPOSE='DELETE',FORM='FORMATTED',RECL=LINE_LENGTH, + & CARRIAGECONTROL='LIST') ! Scratch file to save bulletin + WRITE (6,1000) ! Request bulletin input from terminal + ILEN = LINE_LENGTH ! Length of input line + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Line too long. + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput::'')') LINE_LENGTH + ELSE IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + 1 + ILEN ! Increment character count + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.0) THEN + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + END IF ! 1 space for a blank line. + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 ICOUNT = LAST_NOBLANK + IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + END IF + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + DATE_SAVE = DATE + TIME_SAVE = TIME + INPUT = DESCRIP + + CALL OPEN_BULLDIR ! Prepare to add dir entry + + CALL READDIR(NUMBER_PARAM,IER) ! Get info for message + + IF (IER.NE.NUMBER_PARAM+1.OR.DATE.NE.DATE_SAVE.OR. + & TIME.NE.TIME_SAVE.OR.INPUT.NE.DESCRIP) THEN + ! If message disappeared, try to find it. + IF (IER.NE.NUMBER_PARAM+1) DATE = ' ' + NUMBER_PARAM = 0 + IER = 1 + DO WHILE (IER.EQ.NUMBER_PARAM+1.AND. + & (DATE.NE.DATE_SAVE.OR.TIME.NE.TIME_SAVE.OR.DESCRIP.NE.INPUT)) + NUMBER_PARAM = NUMBER_PARAM + 1 + CALL READDIR(NUMBER_PARAM,IER) + END DO + + IF (IER.NE.NUMBER_PARAM+1) THEN ! Couldn't find message + CALL CLOSE_BULLDIR + CLOSE (UNIT=3,STATUS='SAVE') + WRITE(6,'('' ERROR: Message has been deleted'', + & '' by another user.'')') + IF (DOALL.OR.TEXT) THEN + WRITE (6,'('' New text has been saved in'', + & '' SYS$LOGIN:BULL.SCR.'')') + END IF + GO TO 100 + END IF + END IF + + CALL READDIR(0,IER) ! Get directory header + + IF (REC1.GT.0) THEN ! If text has been replaced + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + BLOCK = NBLOCK + 1 + BLOCK_SAVE = BLOCK + NEMPTY = NEMPTY + LENGTH + NBLOCK = NBLOCK + ICOUNT + + IF (.NOT.REMOTE_SET) CALL WRITEDIR(0,IER) + + OBLOCK = BLOCK + IF (LENFROM.GT.0) THEN + CALL STORE_BULL(LENFROM,INFROM(:LENFROM),OBLOCK) + END IF + IF (LENDES.GT.0) THEN + CALL STORE_BULL(LENDES,INDESCRIP(:LENDES),OBLOCK) + END IF + REWIND (UNIT=3) + CALL COPY_BULL(3,REC1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) THEN ! Error in creating bulletin + WRITE (6,'(A)') ' ERROR: Unable to replace message.' + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + END IF + + LENGTH_SAVE = OCOUNT - BLOCK + 1 + + CALL CLOSE_BULLFIL + + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(NUMBER_PARAM,IER) ! Get directory entry + LENGTH = LENGTH_SAVE ! Update size + BLOCK = BLOCK_SAVE + CALL WRITEDIR(NUMBER_PARAM,IER) ! Write new directory entry + END IF + ELSE + CALL READDIR(NUMBER_PARAM,IER) + END IF + + IF (.NOT.REMOTE_SET) THEN + + IF (LENDES.GT.0.OR.DOALL) THEN + DESCRIP=INDESCRIP(7:59) ! Update description header + END IF + CALL UPDATE_DIR_HEADER(CLI$PRESENT('EXPIRATION').OR.DOALL, + & CLI$PRESENT('PERMANENT'),CLI$PRESENT('SHUTDOWN'), + & INEXDATE,INEXTIME) + IF (CLI$PRESENT('SYSTEM')) THEN + SYSTEM = IBSET(SYSTEM,0) + ELSE IF (CLI$PRESENT('GENERAL')) THEN + SYSTEM = IBCLR(SYSTEM,0) + END IF + CALL WRITEDIR(NUMBER_PARAM,IER) + ELSE + MSGTYPE = 0 + IF (CLI$PRESENT('SYSTEM').OR. + & (BTEST(SYSTEM,0).AND..NOT.CLI$PRESENT('GENERAL'))) THEN + MSGTYPE = IBSET(MSGTYPE,0) + END IF + IF (CLI$PRESENT('PERMANENT')) THEN + MSGTYPE = IBSET(MSGTYPE,1) + ELSE IF (CLI$PRESENT('SHUTDOWN')) THEN + MSGTYPE = IBSET(MSGTYPE,2) + ELSE IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + MSGTYPE = IBSET(MSGTYPE,3) + END IF + IF (LENDES.EQ.0.AND..NOT.DOALL) INDESCRIP(7:) = DESCRIP + IF (CLI$PRESENT('EXPIRATION')) THEN + EXDATE = INEXDATE + EXTIME = INEXTIME + END IF + WRITE (REMOTE_UNIT,'(7A)',IOSTAT=IER) + & 10,DESCRIP,NUMBER_PARAM,INDESCRIP(7:59),MSGTYPE,EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + + CALL CLOSE_BULLDIR ! Totally finished with replace + + CLOSE (UNIT=3) + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + RETURN + +910 WRITE(6,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(6,1020) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + GOTO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1005 FORMAT (' ERROR: You are not reading any message.') +1010 FORMAT (' No message was replaced.') +1015 FORMAT (' ERROR: Specified message was not found.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1090 FORMAT(' ERROR: Specified message is not owned by you.') +1100 FORMAT(' Message is not owned by you.', + & ' Are you sure you want to replace it? ',$) +2020 FORMAT(1X,A) + + END + + + + SUBROUTINE UPDATE_DIR_HEADER(EXPIRE,PERM,SHUT,INEXDATE,INEXTIME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER TODAY*23,INEXDATE*11,INEXTIME*11 + + IF (EXPIRE) THEN + SYSTEM = IBCLR(SYSTEM,1) + SYSTEM = IBCLR(SYSTEM,2) + EXDATE=INEXDATE ! Update expiration date + EXTIME=INEXTIME + DIFF = COMPARE_DATE(EXDATE,NEWEST_EXDATE) ! Compare expiration + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,NEWEST_EXTIME) + IF (DIFF.LT.0) THEN ! If it's oldest expiration bull + NEWEST_EXDATE = EXDATE ! Update the header in + NEWEST_EXTIME = EXTIME ! the directory file + CALL WRITEDIR(0,IER) + END IF + ELSE IF (PERM.AND.(.NOT.BTEST(SYSTEM,1))) THEN + IF (BTEST(SYSTEM,2)) THEN + SYSTEM = IBCLR(SYSTEM,2) + SHUTDOWN = SHUTDOWN - 1 + CALL WRITEDIR(0,IER) + END IF + SYSTEM = IBSET(SYSTEM,1) + EXDATE = '5-NOV-2000' + EXTIME = '00:00:00.00' + ELSE IF (SHUT.AND.(.NOT.BTEST(SYSTEM,2))) THEN + SYSTEM = IBSET(SYSTEM,2) + SYSTEM = IBCLR(SYSTEM,1) + EXDATE = '5-NOV-2000' + NODE_AREA = 0 + IF (INCMD(:4).EQ.'REPL') THEN + IF (CLI$GET_VALUE('SHUTDOWN',NODE_NAME) + & .NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,NODE_NAME) + IF (NODE_AREA.EQ.0) THEN + WRITE (6,'('' ERROR: Shutdown node name ignored.'', + & '' Invalid node name specified.'')') + END IF + END IF + END IF + IF (NODE_AREA.EQ.0) 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) + SHUTDOWN = SHUTDOWN + 1 + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + SHUTDOWN_DATE = TODAY(:11) + SHUTDOWN_TIME = TODAY(13:) + CALL WRITEDIR(0,IER) + END IF + + RETURN + END + + + + + SUBROUTINE SEARCH(READ_COUNT) +C +C SUBROUTINE SEARCH +C +C FUNCTION: Search for bulletin with specified string +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*132 SEARCH_STRING,SAVE_STRING + DATA SEARCH_STRING /' '/, SEARCH_LEN /1/ + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CALL DISABLE_CTRL + + IF (CLI$PRESENT('START')) THEN ! Starting message specified + CALL CLI$GET_VALUE('START',BULL_PARAMETER,LEN_P) + DECODE(LEN_P,'(I)',BULL_PARAMETER) BULL_POINT + BULL_POINT = BULL_POINT - 1 + END IF + + SAVE_STRING = SEARCH_STRING + SAVE_LEN = SEARCH_LEN + + IER1 = CLI$GET_VALUE('SEARCH_STRING',SEARCH_STRING,SEARCH_LEN) + + IF (.NOT.IER1) THEN ! If no search string entered + SEARCH_STRING = SAVE_STRING ! use saved search string + SEARCH_LEN = SAVE_LEN + IF (SAVE_LEN.EQ.0) THEN + WRITE (6,'('' No search string present.'')') + RETURN + END IF + IF (STEP_BULL.EQ.-1) BULL_POINT = BULL_POINT - 2 + END IF + + CALL STR$UPCASE(SEARCH_STRING,SEARCH_STRING) ! Make upper case + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(0,IER) + + IF (IER1) THEN ! If string entered + IF (.NOT.CLI$PRESENT('START')) THEN ! If starting message not + BULL_POINT = 0 ! specified, use first + IF (CLI$PRESENT('REVERSE')) BULL_POINT = NBULL - 1 ! or last + END IF + SUBJECT = CLI$PRESENT('SUBJECT') + IF (CLI$PRESENT('REVERSE')) THEN + END_BULL = 1 + STEP_BULL = -1 + ELSE + END_BULL = NBULL + STEP_BULL = 1 + END IF + END IF + + IF ((BULL_POINT+1.GT.NBULL.AND.STEP_BULL.EQ.1).OR. + & (BULL_POINT+1.EQ.0)) THEN + WRITE (6,'('' ERROR: No more messages.'')') + CALL CLOSE_BULLDIR + CALL ENABLE_CTRL + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + CALL DECLARE_CTRLC_AST + + DO BULL_SEARCH = BULL_POINT+1, END_BULL, STEP_BULL + CALL READDIR(BULL_SEARCH,IER) ! Get bulletin directory entry + IF (IER.EQ.BULL_SEARCH+1) THEN + CALL STR$UPCASE(DESCRIP,DESCRIP) ! Make upper case + IF (INDEX(DESCRIP,SEARCH_STRING(:SEARCH_LEN)).GT.0) THEN + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + BULL_POINT = BULL_SEARCH - 1 + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + RETURN + END IF + END IF + IF (IER.EQ.BULL_SEARCH+1.AND..NOT.SUBJECT) THEN + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,BULL_SEARCH + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + GO TO 900 + ELSE + CALL GET_REMOTE_MESSAGE(IER) + IF (IER.GT.0) GO TO 900 + END IF + END IF + ILEN = LINE_LENGTH + 1 + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + CALL STR$UPCASE(INPUT,INPUT) ! Make upper case + IF (INDEX(INPUT,SEARCH_STRING(:SEARCH_LEN)).GT.0) THEN + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + BULL_POINT = BULL_SEARCH - 1 + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + RETURN + ELSE IF (FLAG.EQ.1) THEN + WRITE (6,'('' Search aborted.'')') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CALL ENABLE_CTRL + RETURN + END IF + END DO + END IF + END DO + +900 CALL CANCEL_CTRLC_AST + + CALL CLOSE_BULLFIL ! End of bulletin file read + CALL CLOSE_BULLDIR + + CALL ENABLE_CTRL + + WRITE (6,'('' No messages found with given search string.'')') + + RETURN + END + + + + + SUBROUTINE UNDELETE +C +C SUBROUTINE UNDELETE +C +C FUNCTION: Undeletes deleted message. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + +C +C Get the bulletin number to be undeleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + DECODE(LEN_P,5,BULL_PARAMETER,ERR=920) BULL_DELETE ! Yes +5 FORMAT(I) + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + GO TO 910 ! No, then error. + ELSE + BULL_DELETE = BULL_POINT ! Delete the file we are reading + END IF + + IF (BULL_DELETE.LE.0) GO TO 920 + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + CALL OPEN_BULLDIR + + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER + & .AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1040) ! Then error out. + GO TO 100 + ELSE + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + END IF + END IF + + IF (SYSTEM.LE.1) THEN ! General or System message + EXDATE = EXDATE(:7)//'19'//EXDATE(10:) + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(:6)//'20'//EXDATE(9:) + ELSE + EXDATE = EXDATE(:7)//'20'//EXDATE(10:) + END IF + END IF + + IF (.NOT.REMOTE_SET) THEN + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + WRITE (6,'('' Message was undeleted.'')') + ELSE + WRITE (REMOTE_UNIT,'(5A)',IOSTAT=IER) + & 11,BULL_DELETE,DESCRIP,EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + ELSE + WRITE (6,'('' Message was undeleted.'')') + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + +100 CALL CLOSE_BULLDIR + +900 RETURN + +910 WRITE(6,1010) + GO TO 900 + +920 WRITE(6,1020) + GO TO 900 + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not undeleted. Not owned by you.') + + END diff --git a/decus/vax90a/bulletin/bulletin3.for b/decus/vax90a/bulletin/bulletin3.for new file mode 100644 index 0000000..3c0510a --- /dev/null +++ b/decus/vax90a/bulletin/bulletin3.for @@ -0,0 +1,1594 @@ +C +C BULLETIN3.FOR, Version 3/15/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE UPDATE +C +C SUBROUTINE UPDATE +C +C FUNCTION: Searches for bulletins that have expired and deletes them. +C +C NOTE: Assumes directory file is already opened. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER*107 DIRLINE + + CHARACTER*11 TEMP_DATE,TEMP_EXDATE,TEMP_NOSYSDATE + CHARACTER*11 TEMP_TIME,TEMP_EXTIME,TEMP_NOSYSTIME + + IF (REMOTE_SET.AND. + & NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + + IF (TEST_BULLCP().OR.REMOTE_SET) RETURN + ! BULLCP cleans up expired bulletins + + ENTRY UPDATE_ALWAYS ! Entry to skip BULLCP test + + TEMP_EXDATE = '5-NOV-2000' ! If a bulletin gets deleted, and there are + TEMP_EXTIME = '00:00:00.00' ! are no more bulletins, this is the value + ! assigned to the latest expiration date + + TEMP_DATE = '5-NOV-1956' ! Storage for computing newest + TEMP_TIME = '00:00:00.00' ! bulletin date if deletion occurs + + TEMP_NOSYSDATE = '5-NOV-1956' ! Storage for computing newest + TEMP_NOSYSTIME = '00:00:00.00' ! non-system bulletin date + + BULL_ENTRY = 1 ! Init bulletin pointer + UPDATE_DONE = 0 ! Flag showing bull has been deleted + + NEW_SHUTDOWN = 0 + OLD_SHUTDOWN = SHUTDOWN + + DO WHILE (1) + CALL READDIR(BULL_ENTRY,IER) ! Get next directory entry + IF (IER.EQ.BULL_ENTRY) GO TO 100 ! ERROR: Not found + IF (SYSTEM.LE.3.OR.(OLD_SHUTDOWN.EQ.0! If not shutdown, or time + & .AND.(SYSTEM.AND.4).EQ.4)) THEN ! to delete shutdowns? + IF ((SYSTEM.AND.4).EQ.4) THEN ! Shutdown bulletin? + IF (NODE_AREA.GT.0) THEN + EXTIME(3:4) = EXTIME(4:5) + READ (EXTIME(1:4),'(I4)') NODE_NUMBER_MSG + EXTIME(9:10) = EXTIME(10:11) + READ (EXTIME(7:10),'(I4)') NODE_AREA_MSG + IF (NODE_NUMBER_MSG.EQ.NODE_NUMBER.AND. + & NODE_AREA_MSG.EQ.NODE_AREA) THEN + DIFF = 0 + ELSE + DIFF = 1 + END IF + ELSE + DIFF = 1 + END IF + IF (DIFF.EQ.1) NEW_SHUTDOWN = NEW_SHUTDOWN + 1 + ELSE + DIFF = COMPARE_DATE(EXDATE,' ') ! Has expiration date passed? + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,' ') + END IF + IF (DIFF.LE.0) THEN ! If so then delete bulletin + CALL DELETE_ENTRY(BULL_ENTRY) ! Delete bulletin entry + IF (UPDATE_DONE.EQ.0) THEN ! If this is first deleted file + UPDATE_DONE = BULL_ENTRY ! store it to use for reordering + END IF ! directory file. + ELSE IF (SYSTEM.LE.3) THEN ! Expiration date hasn't passed + ! If a bulletin is deleted, we'll have to update the latest + ! expiration date. The following does that. + DIFF = COMPARE_DATE(EXDATE,TEMP_EXDATE) + IF (DIFF.LT.0.OR.(DIFF.EQ.0.AND. + & COMPARE_TIME(EXTIME,TEMP_EXTIME).LT.0)) THEN + TEMP_EXDATE = EXDATE ! If this is the latest exp + TEMP_EXTIME = EXTIME ! date seen so far, save it. + END IF + TEMP_DATE = DATE ! Keep date after search + TEMP_TIME = TIME ! we have the last message date + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + ELSE + TEMP_DATE = DATE + TEMP_TIME = TIME + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + BULL_ENTRY = BULL_ENTRY + 1 + END DO + +100 IF (UPDATE_DONE.GT.0) THEN ! Reorder directory file + CALL CLEANUP_DIRFILE(UPDATE_DONE) ! due to deleted entries + END IF + + DATE = NEWEST_DATE + TIME = NEWEST_TIME + CALL READDIR(0,IER) + SHUTDOWN = NEW_SHUTDOWN + NEWEST_EXDATE = TEMP_EXDATE + DIFF = COMPARE_DATE(NEWEST_EXDATE,' ') + IF (DIFF.GT.20*356) NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = TEMP_EXTIME + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL WRITEDIR(0,IER) + SYSTEM = 0 ! Updating last non-system date/time + NEWEST_DATE = TEMP_NOSYSDATE + NEWEST_TIME = TEMP_NOSYSTIME + CALL UPDATE_FOLDER + SYSTEM = 1 ! Now update latest date/time + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL UPDATE_FOLDER + + IF (NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN ! Shutdowns deleted? + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) ! Save that info + END IF + +C +C If newest message date has been changed, must change it in BULLUSER.DAT +C and also see if it affects notification of new messages to users +C + IF (TEMP_DATE.NE.DATE.OR.TEMP_TIME.NE.TIME) THEN + CALL UPDATE_LOGIN(.FALSE.) + END IF + + RETURN + + END + + + + SUBROUTINE UPDATE_READ(USERFILE_OPEN) +C +C SUBROUTINE UPDATE_READ +C +C FUNCTION: +C Store the latest date that user has used the BULLETIN facility. +C If new bulletins have been added, alert user of the fact. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($PRVDEF)' + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2),READ_BTIM_SAVE(2) + + LOGICAL MODIFY_SYSTEM /.TRUE./ + +C +C Update user's latest read time in his entry in BULLUSER.DAT. +C + IF (.NOT.USERFILE_OPEN) THEN + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + END IF + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.NE.0) THEN ! If header not present, exit + IF (.NOT.USERFILE_OPEN) CALL CLOSE_BULLUSER + RETURN + ELSE IF (USERPRIV(1).EQ.-1.AND.USERPRIV(2).EQ.-1) THEN + ! If header present, but no + DO I=1,FLONG ! SET_FLAG and NOTIFY_FLAG + SET_FLAG_DEF(I) = 0 ! information, write default + NOTIFY_FLAG_DEF(I) = 0 ! flags. + BRIEF_FLAG_DEF(I) = 0 + END DO + SET_FLAG_DEF(1) = 1 + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + + CALL SYS$ASCTIM(,TODAY,,) ! Get today's time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + UNLOCK 4 + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + + IF (IER1.EQ.0) THEN ! If entry found, update it + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + ELSE ! If no entry create a new entry + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + CALL WRITE_USER_FILE_NEW(IER) + END IF + + IF (MODIFY_SYSTEM) THEN + CALL MODIFY_SYSTEM_LIST(1) + MODIFY_SYSTEM = .FALSE. + END IF + + IF (.NOT.USERFILE_OPEN) THEN + CALL CLOSE_BULLUSER ! All finished with BULLUSER + END IF + + RETURN ! to go home... + + END + + + + + SUBROUTINE FIND_NEWEST_BULL +C +C SUBROUTINE FIND_NEWEST_BULL +C +C If new bulletins have been added, alert user of the fact and +C set the next bulletin to be read to the first new bulletin. +C +C OUTPUTS: +C BULL_POINT - If -1, no new bulletins to read, else there are. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INTEGER DIR_BTIM(2) + +C +C Now see if bulletins have been added since the user's previous +C read time. If they have, then search for the first new bulletin. +C Ignore new bulletins that are owned by the user or system notices +C that have not been added since the user has logged in. +C + BULL_POINT = -1 ! Init bulletin pointer + + CALL OPEN_BULLDIR_SHARED ! Yep, so get directory file + CALL READDIR(0,IER) ! Get # bulletins from header + IF (IER.EQ.1) THEN + CALL GET_NEWEST_MSG(LAST_READ_BTIM(1,FOLDER_NUMBER+1),START) + IF (START.LE.0) THEN + BULL_POINT = START + CALL CLOSE_BULLDIR + RETURN + END IF + DO WHILE (START.LE.NBULL.AND.(FROM.EQ.USERNAME.OR.SYSTEM)) + IF (FROM.NE.USERNAME) THEN ! Ignore bull if owner is user + IF (SYSTEM) THEN ! If system bulletin + CALL SYS_BINTIM(DATE//' '//TIME,DIR_BTIM) + DIFF = COMPARE_BTIM(LOGIN_BTIM,DIR_BTIM) + IF (DIFF.GT.0) THEN + START = START + 1 + CALL READDIR(START,IER) + ELSE ! SYSTEM bulletin was not seen + SYSTEM = 0 ! so force exit to read it. + END IF + END IF + ELSE + START = START + 1 + CALL READDIR(START,IER) + IF (IER.NE.START+1) START = NBULL + 1 + END IF + END DO + IF (START.LE.NBULL) BULL_POINT = START - 1 + END IF + + CALL CLOSE_BULLDIR + + RETURN + END + + + + SUBROUTINE GET_EXPIRED(EXPDAT,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 EXPDAT + CHARACTER*23 TODAY + + DIMENSION EXTIME(2),NOW(2) + + EXTERNAL CLI$_ABSENT + + IER = SYS$ASCTIM(,TODAY,,) ! Get today's date + + IERC = CLI$GET_VALUE('EXPIRATION',EXPDAT,ILEN) + + PROMPT = .TRUE. + +5 IF (PROMPT) THEN + IF (IERC.NE.%LOC(CLI$_ABSENT)) THEN ! Was value specified? + PROMPT = .FALSE. + ELSE + DEFAULT_EXPIRE = FOLDER_BBEXPIRE + IF ((DEFAULT_EXPIRE.GT.F_EXPIRE_LIMIT.OR.DEFAULT_EXPIRE + & .EQ.0).AND.F_EXPIRE_LIMIT.GT.0.AND. + & .NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER) THEN + DEFAULT_EXPIRE = F_EXPIRE_LIMIT + END IF + IF (BTEST(FOLDER_FLAG,3)) THEN ! NOPROMPT was set + IF (DEFAULT_EXPIRE.LE.0) THEN ! If no expiration date + SYSTEM = SYSTEM.OR.2 ! make permanent + EXPDAT = '5-NOV-2000 00:00:00.00' + ELSE ! Else set expiration + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + ELSE + IF (DEFAULT_EXPIRE.EQ.0) THEN ! Get expiration date + WRITE(6,1030) TODAY(:INDEX(TODAY,'.')-4) + ELSE IF (DEFAULT_EXPIRE.EQ.-1) THEN + WRITE(6,1031) TODAY(:INDEX(TODAY,'.')-4) + ELSE + WRITE(6,1032) TODAY(:INDEX(TODAY,'.')-4), + & DEFAULT_EXPIRE + END IF + WRITE (6,1035) + CALL GET_LINE(EXPDAT,ILEN) ! Get EXPDAT line + IF (ILEN.EQ.0.AND.DEFAULT_EXPIRE.NE.0) THEN + IF (DEFAULT_EXPIRE.EQ.-1) THEN + EXPDAT = '5-NOV-2000 00:00:00.00' + SYSTEM = IBSET(SYSTEM,1) ! Indicate permanent message + ELSE + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + END IF + END IF + END IF + ELSE + RETURN + END IF + + IF (ILEN.LE.0) THEN + IER = 0 + RETURN + END IF + + EXPDAT = EXPDAT(:ILEN) ! Change trailing zeros 2 spaces + + IF (INDEX(EXPDAT,'-').EQ.0.AND.INDEX(EXPDAT,':').GT.0.AND. + & INDEX(EXPDAT(:ILEN),' ').EQ.0) THEN ! Only time specified? + EXPDAT = TODAY(:INDEX(TODAY(2:),' ')+1)//EXPDAT ! Add date + ELSE IF (INDEX(EXPDAT(6:),'-').EQ.0.AND. ! Date specified + & INDEX(EXPDAT,'-').GT.0) THEN ! but no year? + SPACE = INDEX(EXPDAT,' ') - 1 ! Add year + IF (SPACE.EQ.-1) SPACE = TRIM(EXPDAT) + YEAR = INDEX(TODAY(6:),'-') + EXPDAT = EXPDAT(:SPACE)//TODAY(5+YEAR:9+YEAR)//EXPDAT(SPACE+1:) + END IF + + CALL STR$UPCASE(EXPDAT,EXPDAT) ! Convert to upper case + IER = SYS_BINTIM(EXPDAT,EXTIME) + IF (IER.NE.1) THEN ! If not able to do so + WRITE(6,1040) ! tell user is wrong + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + IF (TIMLEN.EQ.16) THEN + CALL SYS$GETTIM(NOW) + CALL LIB$SUBX(NOW,EXTIME,EXTIME) + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + END IF + + IF (EXPDAT(2:2).EQ.'-') EXPDAT = '0'//EXPDAT + IER = COMPARE_DATE(EXPDAT(:11),TODAY(:11)) ! Compare date with today's + IF (IER.GT.F_EXPIRE_LIMIT.AND.F_EXPIRE_LIMIT.GT.0.AND. + & .NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER) THEN + WRITE(6,1050) F_EXPIRE_LIMIT ! Expiration date > limit + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IF (IER.EQ.0) IER = COMPARE_TIME(EXPDAT(13:),TODAY(13:)) + IF (IER.LE.0) THEN ! If expiration date not future + WRITE(6,1045) ! tell user + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + + IF (PROMPT) THEN + IF (BTEST(SYSTEM,1)) THEN ! Permanent message + WRITE (6,'('' Message will be permanent.'')') + ELSE + WRITE (6,'('' Expiration date will be '',A,''.'')') + & EXPDAT(:TRIM(EXPDAT)) + END IF + END IF + + IER = 1 + + RETURN + +1030 FORMAT(' It is ',A,'. Specify when message expires.') +1031 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is permanent.') +1032 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is ',I3,' days.') +1035 Format(' Enter absolute time: [dd-mmm-yyyy] hh:mm:ss ', + & 'or delta time: dddd hh:mm:ss') +1040 FORMAT(' ERROR: Invalid date format specified.') +1045 FORMAT(' ERROR: Specified time has already passed.') +1050 FORMAT(' ERROR: Specified expiration period too large.' + & ' Limit is ',I3,' days.') + + END + + + SUBROUTINE MAILEDIT(INFILE,OUTFILE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SSDEF)' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL BULLETIN_SUBCOMMANDS + + CHARACTER*(*) INFILE,OUTFILE + + CHARACTER*80 MAIL_EDIT,OUT + + IER = SYS_TRNLNM('MAIL$EDIT',MAIL_EDIT) + CALL STR$UPCASE(MAIL_EDIT,MAIL_EDIT) ! Convert to upper case + + OUT = OUTFILE + IF (TRIM(OUT).EQ.0) THEN + OUT = INFILE + END IF + + IF (INDEX(MAIL_EDIT,'CALLABLE_').EQ.0.AND. + & IER.EQ.SS$_NORMAL) THEN + CALL DISABLE_PRIVS + IF (OUT.EQ.INFILE) THEN + CALL LIB$SPAWN('$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' "" '//OUT(:TRIM(OUT))) + ELSE + CALL LIB$SPAWN('$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' '//INFILE//' '//OUT(:TRIM(OUT))) + END IF + CALL ENABLE_PRIVS + ELSE IF (INDEX(MAIL_EDIT,'EDT').GT.0.OR. + & IER.NE.SS$_NORMAL) THEN + CALL EDT$EDIT(INFILE,OUT) + ELSE IF (INDEX(MAIL_EDIT,'TPU').GT.0) THEN + CONTEXT = 0 + IER = LIB$FIND_FILE(INFILE,MAIL_EDIT,CONTEXT) + IF (.NOT.IER) THEN + CALL TPU$EDIT(' ',OUT) + ELSE + CALL TPU$EDIT(INFILE,OUT) + END IF + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + ! TPU does CLI$ stuff which wipes our parsed command line + END IF + + RETURN + END + + + + + + SUBROUTINE CREATE_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE '($JPIDEF)' + + INCLUDE '($SSDEF)' + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /REALPROC/ REALPROCPRIV(2) + + DIMENSION IMAGEPRIV(2) + + CHARACTER IMAGENAME*132,ANSWER*1,PRCNAM*15 + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: You do not have the privileges '', + & ''to execute the command.'')') + CALL EXIT + END IF + + JUST_STOP = CLI$PRESENT('STOP') + + IF (JUST_STOP.AND..NOT.BTEST(REALPROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: You need SETPRV to execute /STOP.'')') + CALL EXIT + ELSE IF (.NOT.JUST_STOP.AND. + & .NOT.BTEST(REALPROCPRIV(1),PRV$V_SYSNAM)) THEN + CALL SYS$SETPRV(,,,IMAGEPRIV) + IF (.NOT.BTEST(IMAGEPRIV(1),PRV$V_SYSNAM)) THEN + WRITE (6,'('' ERROR: This new version of BULLETIN'', + & '' needs to be installed with SYSNAM.'')') + CALL EXIT + END IF + END IF + + IF (TEST_BULLCP()) THEN + IF (.NOT.JUST_STOP) THEN + WRITE (6,'('' BULLCP process running. + & Do you wish to kill it and restart a new one? '',$)') + READ (5,'(A)') ANSWER + IF (ANSWER.NE.'Y'.AND.ANSWER.NE.'y') CALL EXIT + END IF + + WILDCARD = -1 + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(PRCNAM),JPI$_PRCNAM,%LOC(PRCNAM)) + CALL ADD_2_ITMLST(4,JPI$_PID,%LOC(PID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + IER = 1 + DO WHILE (IER.AND.PRCNAM(:6).NE.'BULLCP') + ! Get next interactive process + IER = SYS$GETJPIW(,WILDCARD,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + IF (IER.AND.PID.NE.0) IER = SYS$DELPRC(PID,) + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + CALL EXIT + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP process has been terminated.'')') + CALL EXIT + END IF + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP is not presently running.'')') + CALL EXIT + END IF + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(FOLDER_DIRECTORY) + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$SET NOON' + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$LOOP:' + WRITE(11,'(A)') '$PURGE '//FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$OUTPUT ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$ERROR ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.ERR' + WRITE(11,'(A)') '$B/BULLCP' + WRITE(11,'(A)') '$WAIT 00:01:00' + WRITE(11,'(A)') '$GOTO LOOP' ! File open timed out + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = 0 + DO WHILE (IER.EQ.0.OR.(IER.EQ.SS$_DUPLNAM.AND.PID.GT.0)) + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT', + & FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM','NL:' + & ,,,,'BULLCP',%VAL(4),,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + END DO + + IF (IER) THEN + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM;-1', + & STATUS='OLD',IOSTAT=IER1) + IF (IER1.EQ.0) CLOSE(UNIT=11,STATUS='DELETE',IOSTAT=IER1) + END IF + + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + ELSE + IF (CONFIRM_USER('DECNET').NE.0) THEN + WRITE (6,'('' WARNING: Account with username DECNET'', + & '' does not exist.'')') + WRITE (6,'('' BULLCP will be owned by present account.'')') + END IF + WRITE (6,'('' Successfully created BULLCP detached process.'')') + END IF + CALL EXIT + + END + + + + + + + SUBROUTINE FIND_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + DATA BULLCP /0/ + + CHARACTER*1 DUMMY + + IER = SYS_TRNLNM('BULL_BULLCP',DUMMY) + IF (IER) BULLCP = 1 + + RETURN + END + + + + + LOGICAL FUNCTION TEST_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + TEST_BULLCP = BULLCP + + RETURN + END + + + + + SUBROUTINE RUN_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + + CHARACTER*23 OLD_TIME,NEW_TIME + + IF (TEST_BULLCP()) CALL EXIT ! BULLCP already running, so exit. + + CALL LIB$DATE_TIME(OLD_TIME) + + BULLCP = 2 ! Enable process to do BULLCP functions + + IER = SYS$CREMBX(%VAL(1),CHAN,,,,,'BULL_BULLCP') + IF (.NOT.IER) THEN ! Can't create mailbox, so exit. + CALL SYS_GETMSG(IER) + CALL EXIT + END IF + + IER = SYS$DELMBX(%VAL(CHAN)) ! If process dies, mailbox is deleted. + + CALL REGISTER_BULLCP + + CALL SET_REMOTE_SYSTEM + + CALL START_DECNET + + DO WHILE (1) ! Loop once every 15 minutes + CALL SYS$SETAST(%VAL(0)) + CALL LIB$DATE_TIME(NEW_TIME) + CALL GET_PROXY_ACCOUNTS ! Proxy info for incoming connections + CALL SYS$SETAST(%VAL(1)) + CALL BBOARD ! Look for BBOARD messages. + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).NE.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + IF (IER) THEN + CALL DELETE_EXPIRED ! Delete expired messages + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Do empty block + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! cleanup at 3 a.m. + IF (NEMPTY.GT.200) THEN + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + END IF + END IF + END IF + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Cleanup deleted users from + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! data files at 3 a.m. + CALL SYS$SETAST(%VAL(0)) + CALL TOTAL_CLEANUP_LOGIN + CALL SYS$SETAST(%VAL(1)) + END IF + + OLD_TIME = NEW_TIME + CALL WAIT('15') ! Wait for 15 minutes +C +C Look at remote folders and update local info to reflect new messages. +C Do here after waiting in case problem with connecting to remote folder +C which requires killing process. +C + FOLDER_Q = FOLDER_Q1 + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + CALL SYS$SETAST(%VAL(0)) + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + CALL REGISTER_BULLCP + CALL SYS$SETAST(%VAL(1)) + END DO + + RETURN + END + + + + + + SUBROUTINE SET_REMOTE_SYSTEM + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER NODENAME*8 + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + CALL OPEN_BULLFOLDER_SHARED + + IER = 0 + DO WHILE (IER.EQ.0) + CALL READ_FOLDER_FILE(IER) + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER_FLAG,2) + & .AND.IER.EQ.0) THEN + CALL SELECT_FOLDER(.FALSE.,IER1) + IF (IER1) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14, + & BTEST(FOLDER_FLAG,2),NODENAME + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER + + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + + RETURN + END + + + + + SUBROUTINE REGISTER_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + NODE_AREA = 0 + END IF + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE UPDATE_SHUTDOWN(FOLDER_NUMBER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + CALL CLR2(SHUTDOWN_FLAG,FOLDER_NUMBER) + + SEEN_FLAG = 0 + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 ! All done with that node + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE WAIT(PARAM) +C +C SUBROUTINE WAIT +C +C FUNCTION: Waits for specified time period in minutes. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,PARAM*2 + DATA TIMBUF/'0 00:00:00.00'/ + + DATA WAIT_EF /0/ + + IF (WAIT_EF.EQ.0) CALL LIB$GET_EF(WAIT_EF) + + TIMBUF(6:7) = PARAM + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SETIMR(%VAL(WAIT_EF),TIMADR,,%VAL(2)) ! Set timer. + IER=SYS$WAITFR(%VAL(WAIT_EF)) ! Wait for EFN to be set. + + RETURN + END + + + + SUBROUTINE WAIT_SEC(PARAM) +C +C SUBROUTINE WAIT_SEC +C +C FUNCTION: Waits for specified time period in seconds. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,PARAM*2 + DATA TIMBUF/'0 00:00:00.00'/ + DATA WAIT_EF /0/ + + IF (WAIT_EF.EQ.0) CALL LIB$GET_EF(WAIT_EF) + + TIMBUF(9:10) = PARAM + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SETIMR(%VAL(WAIT_EF),TIMADR,,%VAL(3)) ! Set timer. + IER=SYS$WAITFR(%VAL(WAIT_EF)) ! Wait for EFN to be set. + + RETURN + END + + + + + SUBROUTINE DELETE_EXPIRED + +C +C SUBROUTINE DELETE_EXPIRED +C +C FUNCTION: +C +C Delete any expired bulletins (normal or shutdown ones). +C (NOTE: If bulletin files don't exist, they get created now by +C OPEN_FILE_SHARED. Also, if new format has been defined for files, +C they get converted now. The directory file has had it's record size +C lengthened in the past to include more info, and the bulletin file +C was lengthened from 80 to 81 characters to include byte which indicated +C start of bulletin message. However, that scheme was removed and +C was replaced with a 128 byte record compressed format). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER UPTIME_DATE*11,UPTIME_TIME*11 + + CALL OPEN_BULLDIR_SHARED ! Open directory file + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + CALL CLOSE_BULLFIL + CALL READDIR(0,IER) ! Get directory header + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired bulls? + IF (IER.GT.20*356) IER = -1 ! Check if latest expiration date valid. + IF (IER.EQ.0) IER = COMPARE_TIME(NEWEST_EXTIME,' ') + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)).AND. + & TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown messages exist and need to be checked? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER1.LE.0) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Reopen without sharing + CALL UPDATE ! Need to update + END IF + ELSE ! If header not there, then first time running BULLETIN + CALL OPEN_BULLUSER ! Create user file to be able to set + CALL CLOSE_BULLUSER ! defaults, privileges, etc. + END IF + CALL CLOSE_BULLDIR + + RETURN + END + + + + + SUBROUTINE BBOARD +C +C SUBROUTINE BBOARD +C +C FUNCTION: Converts mail to BBOARD into non-system bulletins. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + CHARACTER*11 INEXDATE + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH),INTO*76 + CHARACTER ACCOUNT_SAVE*8,USERNAME_SAVE*12 + + DIMENSION NEW_MAIL(FOLDER_MAX) + + DATA SPAWN_EF/0/ + + CALL SYS$SETAST(%VAL(0)) + + IF (SPAWN_EF.EQ.0) CALL LIB$GET_EF(SPAWN_EF) + + CALL DISABLE_CTRL + + CALL INIT_QUEUE(FOLDER_Q1,FOLDER_COM) + + FOLDER_Q = FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE(IER) + IF (IER.EQ.0) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + CALL SYS$SETAST(%VAL(1)) + + CALL SYS$SETAST(%VAL(0)) + CALL CHECK_MAIL(NEW_MAIL) + CALL SYS$SETAST(%VAL(1)) + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + + NBBOARD_FOLDERS = 0 + + POINT_FOLDER = 0 + +1 POINT_FOLDER = POINT_FOLDER + 1 + IF (POINT_FOLDER.GT.NUM_FOLDERS) GO TO 900 + + CALL SYS$SETAST(%VAL(0)) + + FOLDER_Q_SAVE = FOLDER_Q + + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (FOLDER_BBOARD.EQ.'NONE'.OR. + & FOLDER_BBOARD(:2).EQ.'::') GO TO 1 + + NBBOARD_FOLDERS = NBBOARD_FOLDERS + 1 + + IF (.NOT.NEW_MAIL(POINT_FOLDER)) GO TO 1 +C +C The process is set to the BBOARD uic and username in order to create +C a spawned process that is able to read the BBOARD mail (a real kludge). +C + + CALL GETUSER(USERNAME_SAVE) ! Get present username + CALL GETACC(ACCOUNT_SAVE) ! Get present account + CALL GETUIC(GROUP_SAVE,USER_SAVE) ! Get present uic + + IF (TRIM(FOLDER_BBOARD).GT.0) THEN ! BBOARD name present? + IER = SETUSER(FOLDER_BBOARD,USERNAME_SAVE)! Set to BBOARD username + IF (IER.EQ.2) GO TO 910 ! Can't set username. New VMS version? + CALL SETACC(ACCOUNTB) ! Set to BBOARD account + CALL SETUIC(IBCLR(GROUPB,31),IBCLR(USERB,31)) ! Set to BBOARD uic + END IF + + LEN_B = TRIM(BBOARD_DIRECTORY) + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.TXT;*') + ! Delete old TXT files left due to errors + + IF (.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)) THEN + ! If normal BBOARD user + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + IF (((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'READ_BOARD.COM', + & STATUS='NEW',ERR=910,CARRIAGECONTROL='LIST') + WRITE(11,'(A)') '$ SET PROTECT=(W:RWED)/DEFAULT' + WRITE(11,'(A)') '$ SET PROC/PRIV=SYSPRV' + WRITE(11,'(A)') + & '$ DEFINE/USER EXTRACT_FILE '//BBOARD_DIRECTORY(:LEN_B)// + & '''F$GETJPI("","USERNAME")''' + WRITE(11,'(A)') '$ MAIL' + WRITE(11,'(A)') 'READ' + WRITE(11,'(A)') 'EXTRACT/ALL/APPEND EXTRACT_FILE' + WRITE(11,'(A)') 'DELETE/ALL' + WRITE(11,'(A)') 'SELECT/NEW' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + ELSE + CONTEXT = 0 + IER = LIB$FIND_FILE(BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.COM',INPUT,CONTEXT) + IF (IER) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.COM','NL:', + & 'NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + IF (.NOT.IER.OR.((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & 'BOARD_SPECIAL.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + END IF + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),FOLDER_Q,FOLDER_COM) + + NBULL = F_NBULL + + CALL SETACC(ACCOUNT_SAVE) ! Reset to original account + CALL SETUSER(USERNAME_SAVE) ! Reset to original username + CALL SETUIC(GROUP_SAVE,USER_SAVE) ! Reset to original uic + + OPEN (UNIT=14,FILE=BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.TXT',STATUS='OLD',ERR=100) + READ (14,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read first line + CALL SYS$SETAST(%VAL(1)) + +5 CALL SYS$SETAST(%VAL(0)) + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),IDUMMY,FOLDER_COM) + + DO WHILE (LEN_INPUT.GT.0) + IF (INPUT(:5).EQ.'From:') THEN + INFROM = INPUT(7:) ! Store username + ELSE IF (INPUT(:5).EQ.'Subj:') THEN + INDESCRIP = INPUT(7:) ! Store subject + ELSE IF (INPUT(:3).EQ.'To:') THEN + INTO = INPUT(5:) ! Store address + END IF + READ (14,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read next line from mail + END DO + + INTO = INTO(:TRIM(INTO)) + CALL STR$TRIM(INTO,INTO) + CALL STR$UPCASE(INTO,INTO) + FLEN = TRIM(FOLDER_BBOARD) + IF (INDEX(INTO,FOLDER_BBOARD(:FLEN)).EQ.0.AND. + & INTO.NE.FOLDER_BBOARD.AND.INDEX(INTO,'@').EQ.0) THEN + POINT_FOLDER1 = 0 + FOLDER_Q2 = FOLDER_Q1 + FOLDER1_BBOARD = FOLDER_BBOARD + FOUND = .FALSE. + DO WHILE (.NOT.FOUND.AND.POINT_FOLDER1.LT.NUM_FOLDERS) + FOLDER_Q2_SAVE = FOLDER_Q2 + CALL READ_QUEUE(%VAL(FOLDER_Q2),FOLDER_Q2,FOLDER1_COM) + FLEN = TRIM(FOLDER1_BBOARD) + POINT_FOLDER1 = POINT_FOLDER1 + 1 + IF (POINT_FOLDER1.LE.NUM_FOLDERS.AND. + & FOLDER1_BBOARD(:2).NE.'::'.AND. + & FOLDER1_BBOARD.NE.'NONE') THEN + IF (INTO.EQ.FOLDER1_BBOARD) THEN + FOUND = .TRUE. + ELSE + FIND_TO = INDEX(INTO,FOLDER1_BBOARD(:FLEN)) + IF (FIND_TO.GT.0) THEN + END_TO = FLEN+FIND_TO + IF (TRIM(INTO).LT.END_TO.OR. + & INTO(END_TO:END_TO).LT.'A'.OR. + & INTO(END_TO:END_TO).GT.'Z') THEN + IF (FIND_TO.EQ.1) THEN + FOUND = .TRUE. + ELSE IF (INTO(FIND_TO-1:FIND_TO-1).LT.'A'.OR. + & INTO(FIND_TO-1:FIND_TO-1).GT.'Z') THEN + FOUND = .TRUE. + END IF + END IF + END IF + END IF + END IF + END DO + IF (FOUND) THEN + FOLDER_COM = FOLDER1_COM + FOLDER_Q_SAVE = FOLDER_Q2_SAVE + END IF + END IF + + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT ! Read first line + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12).AND.IER.EQ.0) + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (INPUT(:5).EQ.'From:') GO TO 5 + END DO ! If line is just form feed, the message is empty + IF (IER.NE.0) GO TO 100 ! If end of file, exit + + EFROM = 2 + I = TRIM(INFROM) + DO WHILE (EFROM.GT.0.AND.I.GT.0) ! Strip off the date + IF (INFROM(I:I).EQ.' ') EFROM = EFROM - 1 ! From the "From:" line + I = I - 1 + END DO + IF (I.GT.0) INFROM = INFROM(:I) + + CALL INIT_MESSAGE_ADD_BBOARD(INFROM,INDESCRIP,IER) + + ISTART = 0 + NBLANK = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Move text to bulletin file + IF (LEN_INPUT.EQ.0) THEN + IF (ISTART.EQ.1) THEN + NBLANK = NBLANK + 1 + END IF + ELSE + ISTART = 1 + DO I=1,NBLANK + CALL WRITE_MESSAGE_LINE(' ') + END DO + NBLANK = 0 + CALL WRITE_MESSAGE_LINE(INPUT) + END IF + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12)) THEN + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12) + & .AND.IER.EQ.0) + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + END DO + IF (IER.EQ.0.AND.INPUT(:5).EQ.'From:') THEN + IER = 1 + ELSE + NBLANK = NBLANK + 1 + END IF + END IF + END DO + + CALL FINISH_MESSAGE_ADD ! Totally finished with add + + CALL SYS$SETAST(%VAL(1)) + + GO TO 5 ! See if there is more mail + +100 CLOSE (UNIT=14,STATUS='DELETE') ! Close the input file + CALL SYS$SETAST(%VAL(1)) + GO TO 1 + +900 CALL SYS$SETAST(%VAL(0)) + + FOLDER_NUMBER = 0 + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNUM(0,IER) + CALL CLOSE_BULLFOLDER + CALL ENABLE_CTRL + FOLDER_SET = .FALSE. + + IF (NBBOARD_FOLDERS.EQ.0) THEN + CALL OPEN_BULLUSER + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',BBOARD_BTIM) + REWRITE (4) USER_HEADER ! Rewrite header + CALL CLOSE_BULLUSER + END IF + + CALL SYS$SETAST(%VAL(1)) + + RETURN + +910 WRITE (6,1010) + GO TO 100 + +930 CLOSE (UNIT=14) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + WRITE (6,1030) + GO TO 100 + +1010 FORMAT(' ERROR:Install program with CMKRNL privileges or relink.') +1030 FORMAT(' ERROR:Alert system programmer. Data file problems.') + + END + + + + + SUBROUTINE CREATE_BBOARD_PROCESS + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + CHARACTER*132 IMAGENAME + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(BBOARD_DIRECTORY) + + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='OLD',IOSTAT=IER) + IF (IER.EQ.0) CLOSE(UNIT=11,STATUS='DELETE') + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$ON ERROR THEN GOTO EXIT' + WRITE(11,'(A)') '$ON SEVERE THEN GOTO EXIT' + WRITE(11,'(A)') '$ON WARNING THEN GOTO EXIT' + WRITE(11,'(A)') '$B/'//'''F$PROCESS()''' + WRITE(11,'(A)') '$EXIT:' + WRITE(11,'(A)') '$LOGOUT' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT', + & BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM','NL:',, + & PROCPRIV,,'BBOARD',%VAL(4),,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + + RETURN + END + + + + SUBROUTINE GETUIC(GRP,MEM) +C +C SUBROUTINE GETUIC(UIC) +C +C FUNCTION: +C To get UIC of process submitting the job. +C OUTPUT: +C GRP - Group number of UIC +C MEM - Member number of UIC +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,JPI$_GRP,%LOC(GRP)) + CALL ADD_2_ITMLST(4,JPI$_MEM,%LOC(MEM)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + SUBROUTINE GET_UPTIME(UPTIME_DATE,UPTIME_TIME) +C +C SUBROUTINE GET_UPTIME +C +C FUNCTION: Gets time of last reboot. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + INTEGER UPTIME(2) + CHARACTER*(*) UPTIME_TIME,UPTIME_DATE + CHARACTER ASCSINCE*23 + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(8,SYI$_BOOTTIME,%LOC(UPTIME)) + CALL END_ITMLST(GETSYI_ITMLST) + + IER = SYS$GETSYI(,,,%VAL(GETSYI_ITMLST),,,) + + CALL SYS$ASCTIM(,ASCSINCE,UPTIME,) + + UPTIME_DATE = ASCSINCE(:11) + UPTIME_TIME = ASCSINCE(13:) + + RETURN + END + + + + INTEGER FUNCTION GET_L_VAL(I) + INTEGER I + GET_L_VAL = I + RETURN + END + + + + SUBROUTINE CHECK_MAIL(NEW_MAIL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + DIMENSION NEW_MAIL(1) + + CHARACTER INPUT*37,FILENAME*132 + + INTEGER*2 COUNT + + FOLDER_Q = FOLDER_Q1 ! so reinit queue pointer + + OPEN (UNIT=10,FILE='VMSMAIL_PROFILE', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL_PROFILE.DATA', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + OFFSET = 36 + + IF (IER.NE.0) THEN + OPEN (UNIT=10,FILE='VMSMAIL', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL.DAT', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + OFFSET = 34 + END IF + + DO I=1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (((.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)).OR. + & BTEST(GROUPB,31)).AND.FOLDER_BBOARD(:2).NE.'::') THEN + ! If normal BBOARD or /VMSMAIL + READ(10,'(A)',KEY=FOLDER_BBOARD,IOSTAT=IER1) INPUT + CALL LIB$MOVC3(2,%REF(INPUT(OFFSET:)),COUNT) + IF (IER1.EQ.0.AND.(COUNT.GT.0.OR.IER.NE.0)) THEN + NEW_MAIL(I) = .TRUE. + ELSE + NEW_MAIL(I) = .FALSE. + END IF + ELSE + NEW_MAIL(I) = .TRUE. + END IF + END DO + + CLOSE (10) + + RETURN + END + + + + SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C FUNCTION: +C To get image name of process. +C OUTPUT: +C IMAGNAME - Image name of process +C ILEN - Length of imagename +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CHARACTER*(*) IMAGNAME + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST_WITH_RET(LEN(IMAGNAME),JPI$_IMAGNAME, + & %LOC(IMAGNAME),%LOC(ILEN)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + + SUBROUTINE GET_NEWEST_MSG(IN_BTIM,START) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + DIMENSION IN_BTIM(2) + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 12,IN_BTIM(1),IN_BTIM(2) + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(A)',IOSTAT=IER) START + END IF + ELSE + CALL GET_MSGKEY(IN_BTIM,MSG_KEY) + CALL READDIR_KEYGE(START) + IF (START.EQ.0) THEN + START = -1 + END IF + END IF + + RETURN + END diff --git a/decus/vax90a/bulletin/bulletin4.for b/decus/vax90a/bulletin/bulletin4.for new file mode 100644 index 0000000..d86064c --- /dev/null +++ b/decus/vax90a/bulletin/bulletin4.for @@ -0,0 +1,1703 @@ +C +C BULLETIN4.FOR, Version 8/2/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C +C +C SUBROUTINE ITMLST_SUBS +C +C FUNCTION: +C A set of routines to easily create item lists. It allows one +C to easily create item lists without the need for declaring arrays +C or itemlist size. Thus, the code can be easily changed to add or +C delete item list codes. +C +C Here is an example of how to use the routines (prints file to a queue): +C +C CALL INIT_ITMLST ! Initialize item list +C ! Now add items to list +C CALL ADD_2_ITMLST(LEN,SJC$_FILE_SPECIFICATION,%LOC(FILENAME)) +C CALL ADD_2_ITMLST(9,SJC$_QUEUE,%LOC(QUEUE)) +C CALL END_ITMLST(SNDJBC_ITMLST) ! Get address of itemlist +C IER = SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SNDJBC_ITMLST),IOSB,,) +C + SUBROUTINE ITMLST_SUBS + + IMPLICIT INTEGER (A-Z) + + DATA SAVE_ITMLST_ADDRESS/0/,NUM_ITEMS/0/,QUEUE_HEADER/0/ + + ENTRY INIT_ITMLST + + IF (QUEUE_HEADER.EQ.0) THEN ! First time INIT_ITMLST ever called? + CALL LIB$GET_VM(8,QUEUE_HEADER) ! Yes, create queue header pointer + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER)) ! Zero out header + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER+4)) ! Zero out header + ELSE IF (SAVE_ITMLST_ADDRESS.GT.0) THEN ! Clean out old item list + CALL LIB$FREE_VM((NUM_ITEMS+1)*12,SAVE_ITMLST_ADDRESS) + NUM_ITEMS = 0 ! Release old itemlist memory + SAVE_ITMLST_ADDRESS = 0 + ELSE ! ITMLST calls cannot be nested. + WRITE (6,'('' ERROR: INIT_ITMLST called before previous'',$)') + WRITE (6,'(''+ ITMLST terminated with END_ITMLST.'')') + CALL EXIT + END IF + + RETURN + + + ENTRY ADD_2_ITMLST(BUFLEN,CODE,BUFADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR,0) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY ADD_2_ITMLST_WITH_RET(BUFLEN,CODE,BUFADR,RETADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR, + & RETADR) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY END_ITMLST(ITMLST_ADDRESS) + + CALL LIB$GET_VM((NUM_ITEMS+1)*12,ITMLST_ADDRESS) + ! Get memory for itemlist + SAVE_ITMLST_ADDRESS = ITMLST_ADDRESS ! Save address to remove memory + + DO I=1,NUM_ITEMS ! Place entries into itemlist + CALL LIB$REMQHI(%VAL(QUEUE_HEADER),INPUT_ITMLST) + CALL LIB$MOVC3(12,%VAL(INPUT_ITMLST+8), + & %VAL(ITMLST_ADDRESS+(I-1)*12)) + CALL LIB$FREE_VM(20,INPUT_ITMLST) + END DO + + CALL LIB$MOVC3(4,0,%VAL(ITMLST_ADDRESS+NUM_ITEMS*12)) + ! Place terminating 0 at end of itemlist + + RETURN + END + + + + SUBROUTINE STORE_ITMLST_ENTRY(INPUT_ITMLST,BUFLEN,CODE,BUFADR, + & RETADR) + + IMPLICIT INTEGER (A-Z) + + STRUCTURE /ITMLST/ + UNION + MAP + INTEGER*2 BUFLEN,CODE + INTEGER BUFADR,RETADR + END MAP + END UNION + END STRUCTURE + + RECORD /ITMLST/ INPUT_ITMLST(1) + + INPUT_ITMLST(1).BUFLEN = BUFLEN + INPUT_ITMLST(1).CODE = CODE + INPUT_ITMLST(1).BUFADR = BUFADR + INPUT_ITMLST(1).RETADR = RETADR + + RETURN + END + + + SUBROUTINE CLEANUP_LOGIN +C +C SUBROUTINE CLEANUP_LOGIN +C +C FUNCTION: Removes entry in user file of user that no longer exist +C if it creates empty space for new user. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 LOGIN_USER + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL OPEN_SYSUAF_SHARED + + LOGIN_USER = USERNAME + READ (4,IOSTAT=IER1,KEYGT=USERNAME) USER_ENTRY ! Look forward one + TEMP_USER = USERNAME + USERNAME = LOGIN_USER + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=TEMP_USER,IOSTAT=IER) TEMP_USER ! See if user exists + END DO + + IF (IER.NE.0.AND.IER1.EQ.0.AND.TEMP_USER.NE.USER_HEADER_KEY) THEN + ! If no UAF entry and last login was + ! more than 6 months old, delete entry + IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN + DELETE(UNIT=4) ! Delete non-existant user + CALL OPEN_BULLINF + READ (9,KEY=TEMP_USER,IOSTAT=IER) + IF (IER.EQ.0) DELETE(UNIT=9) + CALL CLOSE_BULLINF + END IF + END IF + + CALL CLOSE_SYSUAF ! All done... + + RETURN + END + + + SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C FUNCTION: Removes all entries in user file of usesr that no longer exist +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL OPEN_SYSUAF_SHARED + CALL OPEN_BULLUSER + CALL OPEN_BULLINF + + TEMP_USER = USERNAME + + READ (4,IOSTAT=IER) USER_ENTRY ! Skip header + + DO WHILE (IER.EQ.0) ! Clean out BULLUSER.DAT + READ (4,IOSTAT=IER) USER_ENTRY + IF (IER.EQ.0.AND.USERNAME(:1).NE.'*'.AND. + & USERNAME(:1).NE.':') THEN ! See if user exists + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=USERNAME,IOSTAT=IER) + END DO + IF (IER.NE.0) THEN ! If no UAF entry and last login was + ! more than 6 months old, delete entry + IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN + DELETE (UNIT=4) + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=9) + END IF + IER = 0 + END IF + END IF + END DO + + CALL CLOSE_SYSUAF ! All done... + + READ (9,KEYGT=' ',IOSTAT=IER) USERNAME + + DO WHILE (IER.EQ.0) ! Clean out BULLINF.DAT + READ (4,KEYEQ=USERNAME,IOSTAT=IER) + IF (IER.NE.0) DELETE (UNIT=9) + READ (9,IOSTAT=IER) USERNAME + END DO + + CALL CLOSE_BULLINF + CALL CLOSE_BULLUSER + + USERNAME = TEMP_USER + + RETURN + END + + + SUBROUTINE COPY_BULL(INLUN,IBLOCK,OBLOCK,IER) +C +C SUBROUTINE COPY_BULL +C +C FUNCTION: To copy data to the bulletin file. +C +C INPUT: +C INLUN - Input logical unit number +C IBLOCK - Input block number in input file to start at +C OBLOCK - Output block number in output file to start at +C +C OUTPUT: +C IER - If error in writing to bulletin, IER will be <> 0. +C +C NOTES: Input file is accessed using sequential access. This is +C to allow files which have variable records to be read. The +C bulletin file is assumed to be opened on logical unit 1. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + IF (IER.NE.0) CALL ERROR_AND_EXIT + END IF + + DO I=1,IBLOCK-1 + READ(INLUN,'(A)') + END DO + + OCOUNT = OBLOCK + ICOUNT = IBLOCK + + NBLANK = 0 + LENGTH = 0 + DO WHILE (1) + ILEN = 0 + DO WHILE (ILEN.EQ.0) + READ(INLUN,'(Q,A)',END=100) ILEN,INPUT + ILEN = MIN(ILEN,TRIM(INPUT),LINE_LENGTH) + IF (ILEN.GT.1.AND.ICHAR(INPUT(ILEN:ILEN)).EQ.10) THEN + INPUT(ILEN-1:ILEN-1) = CHAR(32) ! Remove imbedded + INPUT(ILEN:ILEN) = CHAR(32) ! CR/LFs at end of file. + ILEN = ILEN - 2 + END IF + IF (ILEN.GT.0) THEN + IF (ICOUNT.EQ.IBLOCK) THEN + IF (INPUT(:6).EQ.'From: ') THEN + INPUT(:4) = 'FROM' + END IF + END IF + ICOUNT = ICOUNT + 1 + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.IBLOCK) THEN + NBLANK = NBLANK + 1 + END IF + END DO + IF (NBLANK.GT.0) THEN + DO I=1,NBLANK + CALL STORE_BULL(1,' ',OCOUNT) + END DO + LENGTH = LENGTH + NBLANK*2 + NBLANK = 0 + END IF + CALL STORE_BULL(ILEN,INPUT,OCOUNT) + LENGTH = LENGTH + ILEN + 1 + END DO + +100 LENGTH = (LENGTH+127)/128 + IF (LENGTH.EQ.0) THEN + IER = 1 + ELSE + IER = 0 + END IF + + CALL FLUSH_BULL(OCOUNT) + + RETURN + END + + + + SUBROUTINE STORE_BULL(ILEN,INPUT,OCOUNT) + + IMPLICIT INTEGER (A-Z) + + PARAMETER BRECLEN=128 + + CHARACTER INPUT*(*),OUTPUT*256 + + DATA POINT/0/ + + IF (ILEN+POINT+1.GT.BRECLEN) THEN + IF (POINT.EQ.BRECLEN) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)) + OUTPUT = CHAR(ILEN)//INPUT + POINT = ILEN + 1 + ELSE IF (POINT.EQ.BRECLEN-1) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN)) + OUTPUT = INPUT + POINT = ILEN + ELSE + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN) + & //INPUT(:BRECLEN-1-POINT)) + OUTPUT = INPUT(BRECLEN-POINT:) + POINT = ILEN - (BRECLEN-1-POINT) + END IF + OCOUNT = OCOUNT + 1 + DO WHILE (POINT.GE.BRECLEN) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + OCOUNT = OCOUNT + 1 + OUTPUT = OUTPUT(BRECLEN+1:) + POINT = POINT - BRECLEN + END DO + ELSE + OUTPUT(POINT+1:) = CHAR(ILEN)//INPUT(:ILEN) + POINT = POINT + ILEN + 1 + END IF + + RETURN + + ENTRY FLUSH_BULL(OCOUNT) + + IF (POINT.LT.BRECLEN) OUTPUT(POINT+1:POINT+1) = CHAR(0) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + POINT = 0 + + RETURN + + END + + + SUBROUTINE WRITE_BULL_FILE(OCOUNT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*(*) OUTPUT + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 6,OUTPUT + ELSE + WRITE (1'OCOUNT) OUTPUT + END IF + + RETURN + END + + + SUBROUTINE GET_BULL_LINE(SBLOCK,BLENGTH,BUFFER,ILEN) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + IBLOCK = SBLOCK ! Initialize pointers. + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 + ELSE ! Else set ILEN to zero + ILEN = 0 ! to request next line + END IF + + DO WHILE (ILEN.EQ.0) ! Read until line created + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 ! Need to read new record. + IF (IBLOCK.GE.SBLOCK+BLENGTH) RETURN ! No more records. + END DO + + RETURN + + ENTRY TEST_MORE_RECORDS(SBLOCK,BLENGTH,IREC) + + IREC = (SBLOCK+BLENGTH-1) - IBLOCK + + RETURN + END + + + SUBROUTINE GET_BULL(IBLOCK,BUFFER,ILEN) +C +C SUBROUTINE GET_BULL +C +C FUNCTION: Outputs line from folder file. +C +C INPUT: +C IBLOCK - Input block number in input file to read from. +C +C OUTPUT: +C BUFFER - Character string containing output line. +C ILEN - Length of character string. If 0, signifies that +C new record needs to be read, -1 signifies error. +C +C NOTE: Since message file is stored as a fixed length (128) record file, +C but message lines are variable, message lines may span one or +C more record. This routine takes a record and outputs as many +C lines as it can from the record. When no more lines can be +C outputted, it returns ILEN=0 requesting the calling program to +C increment the record counter. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + PARAMETER BRECLEN=128 + + CHARACTER BUFFER*(*),TEMP*(BRECLEN), LEFT*(LINE_LENGTH) + + DATA POINT /1/, LEFT_LEN /0/ + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + POINT = 1 ! Initialize pointers. + LEFT_LEN = 0 + END IF + + IF (POINT.EQ.1) THEN ! Need to read new line? + IF (REMOTE_SET) THEN ! Remote folder? + IF (IBLOCK.EQ.BLOCK) SCRATCH_R = SCRATCH_R1 ! Read lines + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,TEMP) ! from queue + ELSE ! Local folder + DO WHILE (REC_LOCK(IER)) ! Read from file + READ (1'IBLOCK,IOSTAT=IER) TEMP + END DO + END IF + ELSE IF (POINT.EQ.BRECLEN+1) THEN ! Read all of line + ILEN = 0 ! so indicate need to read + POINT = 1 ! new line to calling routine. + RETURN + END IF + + IF (IER.GT.0) THEN ! Error in reading file. + ILEN = -1 ! ILEN = -1 signifies error + POINT = 1 + LEFT_LEN = 0 + RETURN + END IF + + IF (LEFT_LEN.GT.0) THEN ! Part of line is left from + ILEN = ICHAR(LEFT(:1)) ! previous record read. + IF (LEFT_LEN.LE.BRECLEN) THEN ! Rest of it is in next record. + BUFFER = LEFT(2:ILEN-LEFT_LEN+1)//TEMP(:LEFT_LEN) ! Output line. + POINT = LEFT_LEN + 1 ! Update pointers. + LEFT_LEN = 0 + ELSE ! Rest of line is longer than + LEFT(ILEN-LEFT_LEN+2:) = TEMP ! a record, so store record + LEFT_LEN = LEFT_LEN - BRECLEN ! and request another read. + ILEN = 0 ! Request new record read. + END IF + ELSE ! Else nothing left over. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Get line length + IF (ILEN.GT.BRECLEN-POINT) THEN ! If it extends to next record + LEFT = TEMP(POINT:) ! Store it in leftover buffer + LEFT_LEN = ILEN - (BRECLEN-POINT) ! Store leftover length + ILEN = 0 ! Request new record read + POINT = 1 ! Update record pointer. + ELSE IF (ILEN.EQ.0) THEN ! Empty line signifies + POINT = 1 ! end of message. + ELSE ! Else message line fully read + BUFFER = TEMP(POINT+1:POINT+ILEN) ! So output it + POINT = POINT+ILEN+1 ! and update pointer. + END IF + END IF + + RETURN + + ENTRY TEST_MORE_LINES(ILEN) ! Test for more lines in record. + ! Returns length of next line. + IF (POINT.EQ.BRECLEN+1) THEN ! If pointer greater than + ILEN = 0 ! record, no more lines. + ELSE ! Else there is another line. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Output it's length. + END IF + + RETURN + + END + + + + SUBROUTINE GET_REMOTE_MESSAGE(IER) +C +C SUBROUTINE GET_REMOTE_MESSAGE +C +C FUNCTION: +C Gets remote message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($RMSDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + IF (SCRATCH_R1.NE.0) THEN ! Is queue empty? + SCRATCH_R = SCRATCH_R1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_R,INPUT) + SCRATCH_R1 = SCRATCH_R ! Init header pointer + END IF + + ILEN = 128 + IER = 0 + LENGTH = 0 + DO WHILE (ILEN.GT.0.AND.IER.EQ.0) + READ (REMOTE_UNIT,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0.AND.ILEN.GT.0) THEN + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.RMS$_RER) THEN ! Ignore this error + IER = 0 + ILEN = 0 + ELSE + CALL SYS_GETMSG(IER1) + LENGTH = 0 + IER1 = IER + CALL DISCONNECT_REMOTE + IER = IER1 ! IER is set to 0 by DISCONNECT_REMOTE + END IF + ELSE IF (ILEN.GT.0) THEN + CALL WRITE_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT) + LENGTH = LENGTH + 1 + END IF + END DO + + RETURN + END + + + + + SUBROUTINE DELETE_ENTRY(BULL_ENTRY) +C +C SUBROUTINE DELETE_ENTRY +C +C FUNCTION: +C To delete a directory entry. +C +C INPUTS: +C BULL_ENTRY - Bulletin entry number to delete +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (NBULL.GT.0) THEN + CALL READDIR(0,IER) + NBULL = -NBULL + CALL WRITEDIR(0,IER) + END IF + + IF (BTEST(FOLDER_FLAG,1)) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',IOSTAT=IER,STATUS='OLD', + & RECL=LINE_LENGTH,CARRIAGECONTROL='LIST',ACCESS='APPEND') + IF (IER.NE.0) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + WRITE (3,'(A)') CHAR(12) + END IF + + CALL OPEN_BULLFIL + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + WRITE(3,1050) INPUT(7:ILEN) + ELSE + WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + + CALL CLOSE_BULLFIL + END IF + +900 CALL READDIR(BULL_ENTRY,IER) + DELETE(UNIT=2) + + NEMPTY = NEMPTY + LENGTH + CALL WRITEDIR(0,IER) + +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,' Date: ',A11) + + RETURN + END + + + + + SUBROUTINE GET_EXDATE(EXDATE,NDAYS) +C +C SUBROUTINE GET_EXDATE +C +C FUNCTION: Computes expiration date giving number of days to expire. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*11 EXDATE + + CHARACTER*3 MONTHS(12) + DIMENSION LENGTH(12) + DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP', + & 'OCT','NOV','DEC'/ + DATA LENGTH/31,27,31,30,31,30,31,31,30,31,30,31/ + + CALL SYS$ASCTIM(,EXDATE,,) ! Get the present date + + DECODE(2,'(I2)',EXDATE(:2)) DAY ! Get day + DECODE(4,'(I4)',EXDATE(8:11)) YEAR ! Get year + + MONTH = 1 + DO WHILE (MONTHS(MONTH).NE.EXDATE(4:6)) ! Get month + MONTH = MONTH + 1 + END DO + + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + + NUM_DAYS = NDAYS ! Put number of days into buffer variable + + DO WHILE (NUM_DAYS.GT.0) + IF (NUM_DAYS+DAY.GT.LENGTH(MONTH)) THEN + ! If expiration date exceeds end of month + NUM_DAYS = NUM_DAYS - (LENGTH(MONTH) - DAY + 1) + ! Decrement # of days by days left in month + DAY = 1 ! Reset day to first of month + MONTH = MONTH + 1 ! Increment month pointer + IF (MONTH.EQ.13) THEN ! Moved into next year? + MONTH = 1 ! Reset month pointer + YEAR = YEAR + 1 ! Increment year pointer + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + END IF + ELSE ! If expiration date is within the month + DAY = DAY + NUM_DAYS ! Find expiration day + NUM_DAYS = 0 ! Force loop exit + END IF + END DO + + ENCODE(2,'(I2)',EXDATE(:2)) DAY ! Put day into new date + ENCODE(4,'(I4)',EXDATE(8:11)) YEAR ! Put year into new date + EXDATE(4:6) = MONTHS(MONTH) ! Put month into new date + + RETURN + END + + + + SUBROUTINE GET_LINE(INPUT,LEN_INPUT) +C +C SUBROUTINE GET_LINE +C +C FUNCTION: +C Gets line of input from terminal. +C +C OUTPUTS: +C LEN_INPUT - Length of input line. If = -1, CTRLC entered. +C if = -2, CTRLZ entered. +C +C NOTES: +C Also, on first call, set LEN_INPUT to 1+LENGTH OF INPUT CHARCTER +C for initializing the CTRLC AST. +C + + IMPLICIT INTEGER (A-Z) + + LOGICAL*1 DESCRIP(8),DTYPE,CLASS + INTEGER*2 LENGTH + CHARACTER*(*) INPUT + EQUIVALENCE (DESCRIP(1),LENGTH),(DESCRIP(3),DTYPE) + EQUIVALENCE (DESCRIP(4),CLASS),(DESCRIP(5),POINTER) + + EXTERNAL SMG$_EOF + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + CHARACTER PROMPT*(*),NULLPROMPT*1 + LOGICAL*1 USE_PROMPT + + USE_PROMPT = .FALSE. + + GO TO 5 + + ENTRY GET_INPUT_PROMPT(INPUT,LEN_INPUT,PROMPT) + + USE_PROMPT = .TRUE. + +5 LIMIT = LEN(INPUT) ! Get input line size limit + INPUT = ' ' ! Clean out input buffer + +C +C Initialize CTRL-C AST with AST routine CTRLC_ROUTINE and +C AST parameter FLAG. When CTRLC occurs, FLAG is set to 1 +C + + CALL DECLARE_CTRLC_AST + + LEN_INPUT = 0 ! Nothing inputted yet + + LENGTH = 0 ! Init special variable + DTYPE = 0 ! descriptor so we won't + CLASS = 2 ! run into any memory limit + POINTER = 0 ! during input. + +C +C LIB$GET_INPUT is nice way of getting input from terminal, +C as it handles such thing as accidental wrap around to next line. +C + + IF (DECNET_PROC) THEN + READ (5,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (IER.NE.0) LEN_INPUT = -2 + RETURN + ELSE IF (USE_PROMPT) THEN + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,PROMPT) ! Get line from terminal with prompt + ELSE + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,NULLPROMPT) ! Get line from terminal with no prompt + END IF + + IF (.NOT.IER.AND.IER.NE.%LOC(SMG$_EOF)) CALL EXIT(IER) + + CALL STR$TRIM(DESCRIP,DESCRIP,LEN_INPUT) + + IF (FLAG.EQ.0) THEN ! If no CTRL-C has occurred + CALL CANCEL_CTRLC_AST ! Cancel CTRL-C AST + IF (IER.NE.%LOC(SMG$_EOF)) THEN ! End of input? + LEN_INPUT = MIN(LIMIT,LENGTH) ! No. Get length of line + DO I=0,LEN_INPUT-1 ! Extract from descriptor + CALL GET_VAL(INPUT(I+1:I+1),%VAL(POINTER+I)) + END DO + CALL CONVERT_TABS(INPUT,LEN_INPUT) + LEN_INPUT = MAX(LEN_INPUT,LENGTH) + ELSE + LEN_INPUT = -2 ! If CTRL-Z, say so + END IF + ELSE + LEN_INPUT = -1 ! If CTRL-C, say so + END IF + RETURN + END + + + + SUBROUTINE CONVERT_TABS(INPUT,LEN_INPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT + + PARAMETER TAB = CHAR(9) + + LIMIT = LEN(INPUT) + + DO WHILE (INDEX(INPUT,TAB).GT.0.AND.LEN_INPUT.LT.LIMIT) + TAB_POINT = INDEX(INPUT,TAB) ! Remove tabs + MOVE = ((TAB_POINT-1)/8)*8 + 9 + ADD = MOVE - TAB_POINT + IF (MOVE-1.LE.LIMIT) THEN + INPUT(MOVE:) = INPUT(TAB_POINT+1:) + DO I = TAB_POINT,MOVE-1 + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LEN_INPUT + ADD - 1 + ELSE + DO I = TAB_POINT,LIMIT + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LIMIT+1 + END IF + END DO + + CALL FILTER (INPUT, LEN_INPUT) + + RETURN + END + + + SUBROUTINE FILTER (INCHAR, LENGTH) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INCHAR + + DO I = 1,LENGTH + IF ((INCHAR(I:I).LT.' '.AND. + & INCHAR(I:I).NE.CHAR(13).AND.INCHAR(I:I).NE.CHAR(10))) + & INCHAR(I:I) = '.' + END DO + + RETURN + END + + + SUBROUTINE GET_VAL(OUTPUT,INPUT) ! Used to convert logical + CHARACTER*(*) OUTPUT ! byte to character value + LOGICAL*1 INPUT + OUTPUT = CHAR(INPUT) + RETURN + END + + SUBROUTINE CTRLC_ROUTINE ! CTRL-C AST routine + IMPLICIT INTEGER (A-Z) ! If CTRL-C, come here + + COMMON /CTRLY/ CTRLY + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + IF (FLAG.EQ.2) THEN + CALL LIB$PUT_OUTPUT('Bulletin aborting...') + CALL SYS$CANEXH() + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + CALL EXIT + END IF + FLAG = 1 ! to set flag + RETURN + END + + + + SUBROUTINE DECLARE_CTRLC_AST +C +C SUBROUTINE DECLARE_CTRLC_AST +C +C FUNCTION: +C Declares a CTRLC ast. +C NOTES: +C Assumes terminal assigned to TERM_CHAN in common /TERM_CHAN/. +C + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SETMODE,IO$M_CTRLCAST,CTRLC_ROUTINE + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /CTRLC_FLAG/ FLAG + + FLAG = 0 ! Init CTRL-C flag + IO_CTRLC = %LOC(IO$_SETMODE)+%LOC(IO$M_CTRLCAST) ! Set AST code + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + + ENTRY CANCEL_CTRLC_AST + + IER = SYS$CANCEL(%VAL(TERM_CHAN)) + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + END + + + + + SUBROUTINE GET_INPUT_NOECHO(DATA) +C +C SUBROUTINE GET_INPUT_NOECHO +C +C FUNCTION: Reads data in from terminal without echoing characters. +C Also contains entry to assign terminal. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) DATA,PROMPT + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /READIT/ READIT + + INCLUDE '($TRMDEF)' + + INTEGER TERMSET(2) + + INTEGER MASK(4) + DATA MASK/4*'FFFFFFFF'X/ + + DATA PURGE/.TRUE./ + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NOECHO_PROMPT(DATA,PROMPT) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NUM(DATA,NLEN) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_PURGE,,TERMSET,NLEN,TERM) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA),,, + & TERMSET,NLEN,TERM) + END IF + + IF (TERM.NE.13.AND.TERM.NE.510.AND.NLEN.EQ.0) THEN + ! Input did not end with CR or buffer full + NLEN = 1 + DATA(:1) = CHAR(TERM) + END IF + + RETURN + + ENTRY ASSIGN_TERMINAL + + IER = SYS$ASSIGN('TT',TERM_CHAN,,) ! Assign terminal + + CALL DECLARE_CTRLC_AST + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IF (CLI$PRESENT('KEYPAD')) THEN + CALL SET_KEYPAD + ELSE IF (READIT.EQ.0) THEN + CALL SET_NOKEYPAD + END IF + + TERMSET(1) = 16 + TERMSET(2) = %LOC(MASK) + + DO I=ICHAR('0'),ICHAR('9') + MASK(2) = IBCLR(MASK(2),I-32) + END DO + + RETURN + END + + + + + + SUBROUTINE GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) +C +C SUBROUTINE GETPAGSIZ +C +C FUNCTION: +C Gets page size of the terminal. +C +C OUTPUTS: +C PAGE_LENGTH - Page length of the terminal. +C PAGE_WIDTH - Page size of the terminal. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($DVIDEF)' + + LOGICAL*1 DEVDEPEND(4) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,DVI$_DEVDEPEND,%LOC(DEVDEPEND(1))) + CALL ADD_2_ITMLST(4,DVI$_DEVBUFSIZ,%LOC(PAGE_WIDTH)) + CALL END_ITMLST(GETDVI_ITMLST) ! Get address of itemlist + + CALL SYS$GETDVIW(,,'TT',%VAL(GETDVI_ITMLST),,,,) + + PAGE_LENGTH = ZEXT(DEVDEPEND(4)) + + PAGE_WIDTH = MIN(PAGE_WIDTH,132) + + RETURN + END + + + + + + LOGICAL FUNCTION SLOW_TERMINAL +C +C FUNCTION SLOW_TERMINAL +C +C FUNCTION: +C Indicates that terminal has a slow speed (2400 baud or less). +C +C OUTPUTS: +C SLOW_TERMINAL = .true. if slow, .false. if not. +C + + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SENSEMODE + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON CHAR_BUF(2) + + LOGICAL*1 IOSB(8) + + INCLUDE '($TTDEF)' + + IER = SYS$QIOW(,%VAL(TERM_CHAN),IO$_SENSEMODE,IOSB,,, + & CHAR_BUF,%VAL(8),,,,) + + IF (IOSB(3).LE.TT$C_BAUD_2400) THEN + SLOW_TERMINAL = .TRUE. + ELSE + SLOW_TERMINAL = .FALSE. + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_PRIV +C +C SUBROUTINE SHOW_PRIV +C +C FUNCTION: +C To show privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($PRVDEF)' + + INCLUDE '($SSDEF)' + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + IF (NEW_FLAG(1).EQ.-1.AND.NEW_FLAG(2).EQ.-1) THEN ! Info not present + CALL CLOSE_BULLUSER + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + WRITE (6,'('' Following privileges are needed for privileged + & commands:'')') + DO I=0,38 + IF ((I.LT.32.AND.BTEST(USERPRIV(1),I)).OR. + & (I.GT.31.AND.BTEST(USERPRIV(2),I-32))) THEN + WRITE (6,'(1X,A)') PRIVS(I) + END IF + END DO + ELSE + WRITE (6,'('' ERROR: Cannot show privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + CALL CHKACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE)),IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN + CALL SHOWACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE))) + END IF + + RETURN + + END + + + + + SUBROUTINE SET_PRIV +C +C SUBROUTINE SET_PRIV +C +C FUNCTION: +C To set privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + DATA PRIVS + & /'CMKRNL','CMEXEC','SYSNAM','GRPNAM','ALLSPOOL','DETACH', + & 'DIAGNOSE','LOG_IO','GROUP','ACNT','PRMCEB','PRMMBX','PSWAPM', + & 'ALTPRI','SETPRV','TMPMBX','WORLD','MOUNT','OPER','EXQUOTA', + & 'NETMBX','VOLPRO','PHY_IO','BUGCHK','PRMGBL','SYSGBL','PFNMAP', + & 'SHMEM','SYSPRV','BYPASS','SYSLCK','SHARE','UPGRADE','DOWNGRADE', + & 'GRPPRV','READALL',' ',' ','SECURITY'/ + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + DIMENSION ONPRIV(2),OFFPRIV(2) + + CHARACTER*32 INPUT_PRIV + + IF (.NOT.SETPRV_PRIV().OR..NOT.BTEST(PROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: This command requires SETPRV privileges.'')') + RETURN + END IF + + IF (CLI$PRESENT('ID').OR. + & CLI$PRESENT('ID').EQ.%LOC(CLI$_NEGATED)) THEN + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the IDs + IF (CLI$PRESENT('ID')) THEN + CALL ADD_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + ELSE + CALL DEL_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + END IF + IF (.NOT.IER) CALL SYS_GETMSG(IER) + END DO + RETURN + END IF + + OFFPRIV(1) = 0 + OFFPRIV(2) = 0 + ONPRIV(1) = 0 + ONPRIV(2) = 0 + + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the privileges + PRIV_FOUND = -1 + I = 0 + DO WHILE (I.LT.39.AND.PRIV_FOUND.EQ.-1) + IF (INPUT_PRIV(:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + IF (INPUT_PRIV(3:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + I = I + 1 + END DO + IF (PRIV_FOUND.EQ.-1) THEN + WRITE(6,'('' ERROR: Incorrectly specified privilege = '', + & A)') INPUT_PRIV(:PLEN) + RETURN + ELSE IF (INPUT_PRIV(:2).EQ.'NO') THEN + IF (INPUT_PRIV.EQ.'NOSETPRV') THEN + WRITE(6,'('' ERROR: Cannot remove SETPRV privileges.'')') + RETURN + ELSE IF (PRIV_FOUND.LT.32) THEN + OFFPRIV(1) = IBSET(OFFPRIV(1),PRIV_FOUND) + ELSE + OFFPRIV(2) = IBSET(OFFPRIV(2),PRIV_FOUND-32) + END IF + ELSE + IF (PRIV_FOUND.LT.32) THEN + ONPRIV(1) = IBSET(ONPRIV(1),PRIV_FOUND) + ELSE + ONPRIV(2) = IBSET(ONPRIV(2),PRIV_FOUND-32) + END IF + END IF + END DO + + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + USERPRIV(1) = USERPRIV(1).OR.ONPRIV(1) + USERPRIV(2) = USERPRIV(2).OR.ONPRIV(2) + USERPRIV(1) = USERPRIV(1).AND.(.NOT.OFFPRIV(1)) + USERPRIV(2) = USERPRIV(2).AND.(.NOT.OFFPRIV(2)) + REWRITE (4) USER_HEADER + WRITE (6,'('' Privileges successfully modified.'')') + ELSE + WRITE (6,'('' ERROR: Cannot modify privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + RETURN + + END + + + + + + + SUBROUTINE ADD_ACL(ID,ACCESS,IER) +C +C SUBROUTINE ADD_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + INCLUDE '($SSDEF)' + + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) THEN + IF (IER.EQ.SS$_NOSUCHID.AND.ADDID.AND. + & INDEX(ACCESS,'C').EQ.0) THEN + CALL GET_UAF(ID,USER,GROUP,ACCOUNT,FLAGS,IER) + IF (.NOT.IER) THEN + CALL ERRSNS(IDUMMY,IER) + WRITE (6,'( + & '' ERROR: Specified username cannot be verified.'')') + CALL SYS_GETMSG(IER) + RETURN + END IF + IDENT = USER + ISHFT(GROUP,16) + IER = SYS$ADD_IDENT(ID,%VAL(IDENT),,) + IF (IER) THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + END IF + END IF + END IF + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_ADDACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IF (INDEX(ACCESS,'C').GT.0.AND.INDEX(ACCESS,'W').EQ.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + SUBROUTINE DEL_ACL(ID,ACCESS,IER) +C +C SUBROUTINE DEL_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + IF (ID.NE.' ') THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_DELACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_DELETEACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + END IF + + IF (INDEX(ACCESS,'C').GT.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + + SUBROUTINE CREATE_FOLDER +C +C SUBROUTINE CREATE_FOLDER +C +C FUNCTION: Creates a new bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + IF (.NOT.SETPRV_PRIV().AND.CLI$PRESENT('NEEDPRIV')) THEN + WRITE(6,'('' ERROR: CREATE is a privileged command.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('CREATE_FOLDER',FOLDER,LEN_T) ! Get folder name + + IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + IF (.NOT.SETPRV_PRIV().AND. ! /NOTIFY /READNEW /BRIEF privileged + & (CLI$PRESENT('NOTIFY').OR.CLI$PRESENT('READNEW').OR. + & CLI$PRESENT('BRIEF').OR.CLI$PRESENT('SYSTEM'))) THEN + WRITE (6,'( + & '' ERROR: No privs for SYSTEM, NOTIFY, BRIEF or READNEW.'')') + RETURN + END IF + + IF (CLI$PRESENT('NODE')) THEN ! Remote node specified? + IER = CLI$GET_VALUE('NODE',FOLDER_BBOARD,LEN_B) ! Get node name + FOLDER_BBOARD = '::'//FOLDER_BBOARD(:LEN_B) + FOLDER1_BBOARD = FOLDER_BBOARD + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE IF (CLI$PRESENT('SYSTEM').AND. + & .NOT.BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' ERROR: /SYSTEM not allowed as remote node'', + & '' is not SYSTEM folder.'')') + RETURN + END IF + END IF + + LENDES = 0 + DO WHILE (LENDES.EQ.0) + IF (CLI$PRESENT('DESCRIPTION')) THEN ! DESCRIPTION specified? + IER = CLI$GET_VALUE('DESCRIPTION',FOLDER_DESCRIP,LENDES) + ELSE + WRITE (6,'('' Enter one line description of folder.'')') + CALL GET_LINE(FOLDER_DESCRIP,LENDES) ! Get input line + FOLDER_DESCRIP = FOLDER_DESCRIP(:LENDES) ! End fill with spaces + END IF + IF (LENDES.LE.0) THEN + WRITE (6,'('' Aborting folder creation.'')') + RETURN + ELSE IF (LENDES.GT.80) THEN ! If too many characters + WRITE(6,'('' ERROR: folder must be < 80 characters.'')') + LENDES = 0 + END IF + END DO + + CALL OPEN_BULLFOLDER ! Open folder file + READ (7,IOSTAT=IER,KEY=FOLDER,KEYID=0) + ! See if folder exists + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Specified folder already exists.'')') + GO TO 1000 + END IF + + IF (CLI$PRESENT('OWNER')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: /OWNER requires privileges.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner not valid username.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + FOLDER_OWNER = FOLDER1_OWNER + END IF + END IF + ELSE + FOLDER_OWNER = USERNAME ! Get present username + FOLDER1_OWNER = FOLDER_OWNER ! Save for later + END IF + + FOLDER_SET = .TRUE. + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + +C +C Folder file is placed in the directory FOLDER_DIRECTORY. +C The file prefix is the name of the folder. +C + + FD_LEN = TRIM(FOLDER_DIRECTORY) + IF (FD_LEN.EQ.0) THEN + WRITE (6,'('' ERROR: System programmer has disabled folders.'')') + GO TO 910 + ELSE + FOLDER_FILE = FOLDER_DIRECTORY(:FD_LEN)//FOLDER + END IF + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder directory file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='NEW', + 1 ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',IOSTAT=IER) + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder message file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + FOLDER_FLAG = 0 + + IF (CLI$PRESENT('PRIVATE').OR.CLI$PRESENT('SEMIPRIVATE')) THEN + ! Will folder have access limitations? + FOLDER1_FILE = FOLDER_FILE + CLOSE (UNIT=1) + CLOSE (UNIT=2) + IF (CLI$PRESENT('SEMIPRIVATE')) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER_OWNER,'R+W+C',IER) + OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLDIR',STATUS='OLD',IOSTAT=IER1) + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='OLD',IOSTAT=IER1) + IF (.NOT.IER) THEN + WRITE(6, + & '('' ERROR: Cannot create private folder using ACLs.'')') + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + + IER = 0 + LAST_NUMBER = 1 + DO WHILE (IER.EQ.0.AND.LAST_NUMBER.LT.FOLDER_MAX-1) + READ (7,IOSTAT=IER,KEY=LAST_NUMBER,KEYID=1) + LAST_NUMBER = LAST_NUMBER + 1 + END DO + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder limit of '',I,'' has been reached.'')') + & FOLDER_MAX + WRITE (6,'('' Unable to add specified folder.'')') + GO TO 910 + ELSE + FOLDER1_NUMBER = LAST_NUMBER - 1 + END IF + + IF (.NOT.CLI$PRESENT('NODE')) THEN + FOLDER_BBOARD = 'NONE' + IF (REMOTE_SET) CLOSE (UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + FOLDER_BBEXPIRE = 14 + F_NBULL = 0 + NBULL = 0 + F_NEWEST_BTIM(1) = 0 + F_NEWEST_BTIM(2) = 0 + F_NEWEST_NOSYS_BTIM(1) = 0 + F_NEWEST_NOSYS_BTIM(2) = 0 + F_EXPIRE_LIMIT = 0 + FOLDER_NUMBER = FOLDER1_NUMBER + ELSE + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + IF (FOLDER1.NE.FOLDER) THEN ! Different remote folder name? + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! If so, store name in directory file + BULLDIR_HEADER(13:) = FOLDER1 + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:LEN_B+2)//'*' + FOLDER1 = FOLDER + END IF + REMOTE_SET = .TRUE. + IF (BTEST(FOLDER1_FLAG,0)) FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + FOLDER1_FLAG = FOLDER_FLAG + FOLDER1_DESCRIP = FOLDER_DESCRIP + FOLDER_COM = FOLDER1_COM + NBULL = F_NBULL + END IF + + FOLDER_OWNER = FOLDER1_OWNER + + IF (CLI$PRESENT('SYSTEM')) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + END IF + + CALL WRITE_FOLDER_FILE(IER) + CALL MODIFY_SYSTEM_LIST(0) + + CLOSE (UNIT=1) + CLOSE (UNIT=2) + + NOTIFY = 0 + READNEW = 0 + BRIEF = 0 + IF (CLI$PRESENT('NOTIFY')) NOTIFY = 1 + IF (CLI$PRESENT('READNEW')) READNEW = 1 + IF (CLI$PRESENT('SHOWNEW')) BRIEF = 1 + IF (CLI$PRESENT('BRIEF')) THEN + BRIEF = 1 + READNEW = 1 + END IF + CALL SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) + + WRITE (6,'('' Folder is now set to '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + + GO TO 1000 + +910 WRITE (6,'('' Aborting folder creation.'')') + IF (FOLDER_NUMBER.EQ.0) FOLDER_SET = .FALSE. + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + +1000 CALL CLOSE_BULLFOLDER + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + diff --git a/decus/vax90a/bulletin/bulletin5.for b/decus/vax90a/bulletin/bulletin5.for new file mode 100644 index 0000000..40dcd71 --- /dev/null +++ b/decus/vax90a/bulletin/bulletin5.for @@ -0,0 +1,1614 @@ +C +C BULLETIN5.FOR, Version 2/12/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) +C +C SUBROUTINE SET_FOLDER_DEFAULT +C +C FUNCTION: Sets flag defaults for specified folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL CLI$_NEGATED + + IF (.NOT.SETPRV_PRIV().AND.INCMD(:3).EQ.'SET') THEN + WRITE (6,'( + & '' ERROR: No privs to change all defaults.'')') + RETURN + END IF + + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_HEADER(IER) + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + REWRITE(4) USER_HEADER + + FLAG = 0 + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',TEMP_USER) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',TEMP_USER) + END IF + READ (TEMP_USER(:1),'(I1)',IOSTAT=IER) FLAG + + IF (NOTIFY.EQ.1.AND.BTEST(FLAG,1).AND. + & CLI$PRESENT('CLUSTER').EQ.%LOC(CLI$_NEGATED)) THEN + CALL OPEN_BULLNOTIFY + READ (10,KEY='*',IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=10) + FLAG = -1 + END IF + + IF (BRIEF.NE.-1.AND.NOTIFY.NE.-1.AND.READNEW.NE.-1) THEN + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + IF (TEMP_USER(:1).NE.'*'.AND.TEMP_USER(:1).NE.':') THEN + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG,FOLDER_NUMBER) + REWRITE(4) TEMP_USER//USER_ENTRY(13:) + IF (FLAG.EQ.-1) WRITE (10,IOSTAT=IER) TEMP_USER + END IF + CALL READ_USER_FILE(IER) + END DO + END IF + + IF (FLAG.EQ.-1) THEN + CALL CLOSE_BULLNOTIFY + ELSE IF (NOTIFY.EQ.1.AND.BTEST(FLAG,1).AND. + & CLI$PRESENT('CLUSTER').NE.%LOC(CLI$_NEGATED)) THEN + WRITE (6,'('' NOTE: In a cluster, /ALL or /DEFAULT '', + & ''causes all users to be notified.'')') + WRITE (6,'('' They will not be able to disable this.'', + & '' See HELP SET NOTIFY for more info.'')') + CALL OPEN_BULLNOTIFY + CALL CLOSE_BULLNOTIFY_DELETE + CALL OPEN_BULLNOTIFY + WRITE (10) '* ' + CALL CLOSE_BULLNOTIFY + ELSE IF (NOTIFY.EQ.0.AND.BTEST(FLAG,1)) THEN + CALL OPEN_BULLNOTIFY + READ (10,IOSTAT=IER) TEMP_USER + IF ((IER.EQ.0.AND.TEMP_USER.EQ.'*').OR. + & (BRIEF.NE.-1.AND.READNEW.NE.-1)) THEN + CALL CLOSE_BULLNOTIFY_DELETE + ELSE + CALL CLOSE_BULLNOTIFY + END IF + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + SUBROUTINE REMOVE_FOLDER +C +C SUBROUTINE REMOVE_FOLDER +C +C FUNCTION: Removes a bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,TEMP*80 + + IER = CLI$GET_VALUE('REMOVE_FOLDER',FOLDER1,LEN_T) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + IF (.NOT.FOLDER_SET) THEN + WRITE (6,'('' ERROR: No folder specified.'')') + RETURN + ELSE + FOLDER1 = FOLDER + END IF + ELSE IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Are you sure you want to remove folder ' + & //FOLDER1(:TRIM(FOLDER1))//' (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not removed.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if folder exists + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + GO TO 1000 + END IF + + IF ((FOLDER1_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()).OR. + & FOLDER1_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: You are not able to remove the folder.'')') + GO TO 1000 + END IF + + TEMP = FOLDER_FILE + FOLDER_FILE = FOLDER1_FILE + + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER1_FLAG,2)) THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) FLEN = FLEN - 1 + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER1_BBOARD(3:FLEN) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Deregister remote SYSTEM folder + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + IF (IER.EQ.1) FOLDER1 = BULLDIR_HEADER(13:) + CALL CLOSE_BULLDIR + END IF + WRITE (17,'(2A)',IOSTAT=IER) 1,FOLDER1 ! Select folder + IF (IER.EQ.0) READ(17,'(5A)',IOSTAT=IER) ! Throw away response + IF (IER.EQ.0) WRITE(17,'(2A)',IOSTAT=IER) 14,0 ! Deregister + CLOSE (UNIT=17) + END IF + END IF + + TEMPSET = FOLDER_SET + FOLDER_SET = .TRUE. + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + ! in case files don't exist and are created. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL OPEN_BULLNOTIFY + CALL CLOSE_BULLNOTIFY_DELETE + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + FOLDER_FILE = TEMP + FOLDER_SET = TEMPSET + + DELETE (7) + + TEMP_NUMBER = FOLDER_NUMBER + FOLDER_NUMBER = FOLDER1_NUMBER + CALL SET_FOLDER_DEFAULT(0,0,0) + FOLDER_NUMBER = TEMP_NUMBER + + WRITE (6,'('' Folder removed.'')') + + IF (FOLDER.EQ.FOLDER1) THEN + FOLDER_SET = .FALSE. + ELSE + REMOTE_SET = REMOTE_SET_SAVE + END IF + +1000 CALL CLOSE_BULLFOLDER + + RETURN + + END + + + SUBROUTINE SELECT_FOLDER(OUTPUT,IER) +C +C SUBROUTINE SELECT_FOLDER +C +C FUNCTION: Selects the specified folder. +C +C INPUTS: +C OUTPUT - Specifies whether status messages are outputted. +C +C NOTES: +C FOLDER_NUMBER is used for selecting the folder. +C If FOLDER_NUMBER = -1, the name stored in FOLDER1 is used. +C If FOLDER_NUMBER = -2, the name stored in FOLDER1 is used, +C but the folder is not selected if it is remote. +C If the specified folder is on a remote node and does not have +C a local entry (i.e. specified via NODENAME::FOLDERNAME), then +C FOLDER_NUMBER is set to -1. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + INCLUDE '($SSDEF)' + + COMMON /POINT/ BULL_POINT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM + + EXTERNAL CLI$_ABSENT + + CHARACTER*80 LOCAL_FOLDER1_DESCRIP + + DIMENSION FIRST_TIME(FLONG) ! Bit set for folder if folder has + DATA FIRST_TIME /FLONG*0/ ! been selected before this. + + COMMAND = (INCMD(:3).EQ.'ADD').OR.(INCMD(:3).EQ.'DEL').OR. + & (INCMD(:3).EQ.'DIR').OR.(INCMD(:3).EQ.'IND').OR. + & (INCMD(:3).EQ.'REP').OR.(INCMD(:3).EQ.'SEL').OR. + & (INCMD(:3).EQ.'SET') + + IF (.NOT.OUTPUT.OR.FOLDER_NUMBER.NE.-1.OR.COMMAND) THEN + IF (OUTPUT) THEN ! Get folder name + IER = CLI$GET_VALUE('SELECT_FOLDER',FOLDER1) + END IF + + FLEN = TRIM(FOLDER1) ! Add GENERAL after :: if no + IF (FLEN.GT.1) THEN ! name specified after the :: + IF (FOLDER1(FLEN-1:FLEN).EQ.'::') THEN + FOLDER1 = FOLDER1(:FLEN)//'GENERAL' + END IF + END IF + + IF (((IER.EQ.%LOC(CLI$_ABSENT).OR.FOLDER1.EQ.'GENERAL').AND. + & OUTPUT).OR.((FOLDER_NUMBER.EQ.0.OR.(FOLDER1.EQ.'GENERAL'.AND. + & FOLDER_NUMBER.LE.-1)).AND..NOT.OUTPUT)) THEN ! Select GENERAL + FOLDER_NUMBER = 0 + FOLDER1 = 'GENERAL' + END IF + END IF + + REMOTE_TEST = 0 + + IF (SAVE_FOLDER_Q1.NE.0) THEN ! Have folder info + FOLDER1_COM = FOLDER_COM + IER = 0 + ELSE + CALL OPEN_BULLFOLDER_SHARED ! Go find folder + + IF (OUTPUT.OR.FOLDER_NUMBER.LE.-1) THEN + REMOTE_TEST = INDEX(FOLDER1,'::') + IF (REMOTE_TEST.GT.0) THEN + FOLDER1_BBOARD = '::'//FOLDER1(:REMOTE_TEST-1) + FOLDER1 = FOLDER1(REMOTE_TEST+2:TRIM(FOLDER1)) + FOLDER1_NUMBER = -1 + IER = 0 + ELSE IF (INCMD(:2).EQ.'SE') THEN + CALL READ_FOLDER_FILE_KEYNAME_TEMP + & (FOLDER1(:TRIM(FOLDER1)),IER) + ELSE + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + END IF + ELSE + FOLDER1_NUMBER = FOLDER_NUMBER + CALL READ_FOLDER_FILE_KEYNUM_TEMP(FOLDER_NUMBER,IER) + END IF + + IF (BTEST(FOLDER1_FLAG,29)) THEN ! Error in folder flag!! + FOLDER1_FLAG = FOLDER1_FLAG.AND.3 + F1_EXPIRE_LIMIT = 0 + CALL REWRITE_FOLDER_FILE_TEMP + END IF + + CALL CLOSE_BULLFOLDER + END IF + + IF (IER.EQ.0.AND.FOLDER1_BBOARD(:2).EQ.'::') THEN + IF (FOLDER_NUMBER.EQ.-2) RETURN ! Don't allow + LOCAL_FOLDER1_FLAG = FOLDER1_FLAG + LOCAL_FOLDER1_DESCRIP = FOLDER1_DESCRIP + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + IF (OUTPUT) THEN + WRITE (6,'('' ERROR: Unable to select the folder.'')') + WRITE (6,'('' Cannot connect to node '',A,''.'')') + & FOLDER1_BBOARD(3:TRIM(FOLDER1_BBOARD)) + END IF + RETURN + END IF + IF (REMOTE_TEST.GT.0) THEN ! Folder specified with "::" + FOLDER1 = FOLDER1_BBOARD(3:TRIM(FOLDER1_BBOARD))//'::'// + & FOLDER1 + FOLDER1_NUMBER = -1 + ELSE ! True remote folder + FOLDER1_DESCRIP = LOCAL_FOLDER1_DESCRIP ! Use local description + IF (BTEST(FOLDER1_FLAG,0)) THEN ! Copy remote folder protection + LOCAL_FOLDER1_FLAG = IBSET(LOCAL_FOLDER1_FLAG,0) + ELSE + LOCAL_FOLDER1_FLAG = IBCLR(LOCAL_FOLDER1_FLAG,0) + END IF + FOLDER1_FLAG = LOCAL_FOLDER1_FLAG ! Use local flag info + CALL OPEN_BULLFOLDER ! Update local folder information + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + FOLDER_COM = FOLDER1_COM + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + END IF + REMOTE_SET = .TRUE. + END IF + + IF (IER.EQ.0) THEN ! Folder found + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + IF (BTEST(FOLDER1_FLAG,0).AND.FOLDER1_BBOARD(:2).NE.'::' + & .AND..NOT.SETPRV_PRIV()) THEN + ! Is folder protected and not remote? + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER1_OWNER) THEN + IF (SETPRV_PRIV()) THEN + READ_ACCESS = 1 + WRITE_ACCESS = 1 + ELSE + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + END IF + IF (.NOT.READ_ACCESS.AND..NOT.WRITE_ACCESS) THEN + IF (OUTPUT) THEN + WRITE(6,'('' You are not allowed to access folder.'')') + WRITE(6,'('' See '',A,'' if you wish to access folder.'')') + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + ELSE IF (TEST2(BRIEF_FLAG,FOLDER1_NUMBER).OR. + & TEST2(SET_FLAG,FOLDER1_NUMBER)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER1_NUMBER) + CALL CLR2(SET_FLAG,FOLDER1_NUMBER) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + IER = 0 + RETURN + END IF + ELSE IF (BTEST(FOLDER1_FLAG,0).AND. + & IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER1) + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + ELSE ! Folder not protected + IER = SS$_ACLEMPTY.OR.SS$_NORMAL ! Indicate folder selected + END IF + + IF (FOLDER1_BBOARD(:2).NE.'::') THEN + IF (REMOTE_SET) CLOSE(UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + END IF + + IF (IER) THEN + FOLDER_COM = FOLDER1_COM ! Folder successfully set so + FOLDER_FILE = FOLDER1_FILE ! update folder parameters + + IF (FOLDER_NUMBER.NE.0) THEN + FOLDER_SET = .TRUE. + ELSE + FOLDER_SET = .FALSE. + END IF + + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + WRITE (6,'('' Folder has been set to '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + BULL_POINT = 0 ! Reset pointer to first bulletin + END IF + + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER_OWNER) THEN + IF (.NOT.WRITE_ACCESS) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') + & WRITE (6,'('' Folder only accessible for reading.'')') + READ_ONLY = .TRUE. + ELSE + READ_ONLY = .FALSE. + END IF + ELSE + READ_ONLY = .FALSE. + END IF + + IF (FOLDER_NUMBER.GT.0) THEN + IF (TEST_BULLCP()) THEN + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + ELSE IF (.NOT.TEST2(FIRST_TIME,FOLDER_NUMBER)) THEN + ! If first select, look for expired messages. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) ! Get header info from BULLDIR.DAT + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired? + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)) + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown bulletins exist? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER.GT.20*356.OR.IER1.LE.0) THEN + CALL UPDATE ! Need to update + END IF + ELSE + NBULL = 0 + END IF + CALL CLOSE_BULLDIR + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + END IF + END IF + + IF (OUTPUT) THEN + IF (FOLDER_NUMBER.GE.0.AND.CLI$PRESENT('MARKED')) THEN + READ_TAG = .TRUE. + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + IF (INCMD(:3).NE.'DIR') THEN + IF (IER.EQ.0) THEN + WRITE(6,'('' NOTE: Only marked messages'', + & '' will be shown.'')') + ELSE + WRITE(6,'('' ERROR: No marked messages found.'')') + END IF + END IF + ELSE + READ_TAG = .FALSE. + END IF + END IF + + IF (FOLDER_NUMBER.NE.0.AND..NOT.READ_TAG) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN ! If new unread messages + CALL FIND_NEWEST_BULL ! See if we can find it + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + END IF + END IF + END IF + END IF + IER = 1 + ELSE IF (OUTPUT) THEN + WRITE (6,'('' Cannot access specified folder.'')') + CALL SYS_GETMSG(IER) + END IF + ELSE ! Folder not found + IF (OUTPUT) WRITE (6,'('' ERROR: Folder does not exist.'')') + IER = 0 + END IF + + RETURN + + END + + + + SUBROUTINE CONNECT_REMOTE_FOLDER(READ_ONLY,IER) +C +C SUBROUTINE CONNECT_REMOTE_FOLDER +C +C FUNCTION: Connects to folder that is located on other DECNET node. +C + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_UNIT /15/ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*12 FOLDER_BBOARD_SAVE,FOLDER_OWNER_SAVE + CHARACTER*25 FOLDER_SAVE + + DIMENSION DUMMY(2) + + REMOTE_UNIT = 31 - REMOTE_UNIT + + SAME = .TRUE. + LEN_BBOARD = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN ! Remote folder name different + SAME = .FALSE. ! from local? Yes. + LEN_BBOARD = LEN_BBOARD - 1 + END IF + + OPEN (UNIT=REMOTE_UNIT,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=FOLDER1_BBOARD(3:LEN_BBOARD)//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IF (.NOT.SAME) THEN + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + FOLDER_FILE = FOLDER1_FILE + FOLDER_SAVE = FOLDER1 + FOLDER1 = BULLDIR_HEADER(13:) + END IF + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 1,FOLDER1 + FOLDER_OWNER_SAVE = FOLDER1_OWNER + FOLDER_BBOARD_SAVE = FOLDER1_BBOARD + FOLDER_NUMBER_SAVE = FOLDER1_NUMBER + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(5A)',IOSTAT=IER)IER1,READ_ONLY, + & DUMMY(1),DUMMY(2),FOLDER1_COM + END IF + IF (.NOT.SAME) FOLDER1 = FOLDER_SAVE + FOLDER1_BBOARD = FOLDER_BBOARD_SAVE + FOLDER1_NUMBER = FOLDER_NUMBER_SAVE + FOLDER1_OWNER = FOLDER_OWNER_SAVE + END IF + + IF (IER.NE.0.OR..NOT.IER1) THEN + CLOSE (UNIT=REMOTE_UNIT) + REMOTE_UNIT = 31 - REMOTE_UNIT + IF (IER.EQ.0.AND.FOLDER_NUMBER_SAVE.GE.0) THEN + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + & .OR.TEST2(SET_FLAG,FOLDER_NUMBER_SAVE)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + CALL CLR2(SET_FLAG,FOLDER_NUMBER_SAVE) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + END IF + IER = 2 + ELSE + CLOSE (UNIT=31-REMOTE_UNIT) +C +C If remote folder has returned a last read time for the folder, +C and if in /LOGIN mode, or last selected folder was a different +C folder, or folder specified with "::", then update last read time. +C + IF (((FOLDER_NUMBER.NE.FOLDER1_NUMBER.OR.LOGIN_SWITCH) + & .AND.(DUMMY(1).NE.0.OR.DUMMY(2).NE.0)) + & .OR.FOLDER1_NUMBER.EQ.-1) THEN + LAST_READ_BTIM(1,FOLDER1_NUMBER+1) = DUMMY(1) + LAST_READ_BTIM(2,FOLDER1_NUMBER+1) = DUMMY(2) + END IF + IER = 0 + END IF + + RETURN + END + + + + + + + + + + SUBROUTINE UPDATE_FOLDER +C +C SUBROUTINE UPDATE_FOLDER +C +C FUNCTION: Updates folder info due to new message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (FOLDER_NUMBER.LT.0) RETURN + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + + F_NBULL = NBULL + + IF (FOLDER_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + + IF (.NOT.BTEST(SYSTEM,0)) THEN ! Is non-system message? + F_NEWEST_NOSYS_BTIM(1) = F_NEWEST_BTIM(1) ! If so, update latest + F_NEWEST_NOSYS_BTIM(2) = F_NEWEST_BTIM(2) ! system time. + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + SUBROUTINE SHOW_FOLDER +C +C SUBROUTINE SHOW_FOLDER +C +C FUNCTION: Shows the information on any folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + INCLUDE '($SSDEF)' + + INCLUDE '($RMSDEF)' + + EXTERNAL CLI$_ABSENT + + IF (INDEX(INCMD,'/A').GT.0.OR.INDEX(INCMD,'/a').GT.0) THEN + WRITE (6,'('' ERROR: /ALL is invalid qualifier.'')') + RETURN + END IF + + IF (CLI$GET_VALUE('SHOW_FOLDER',FOLDER1).EQ.%LOC(CLI$_ABSENT)) + & FOLDER1 = FOLDER + + IF (INDEX(FOLDER1,'::').NE.0) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Specified folder was not found.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (FOLDER.EQ.FOLDER1) THEN + WRITE (6,1000) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + ELSE + WRITE (6,1010) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + END IF + + IF (CLI$PRESENT('FULL')) THEN + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL).OR.(.NOT.IER)) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND. ! Is folder remote + & BTEST(FOLDER1_FLAG,0)) THEN ! and private? + WRITE (6,'('' Folder is a private folder.'')') + ELSE + WRITE (6,'('' Folder is not a private folder.'')') + END IF + ELSE + IF (SETPRV_PRIV()) THEN + READ_ACCESS = 1 + WRITE_ACCESS = 1 + ELSE + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + END IF + IF (WRITE_ACCESS) + & CALL SHOWACL(FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL') + END IF + IF (SETPRV_PRIV().OR.USERNAME.EQ.FOLDER1_OWNER) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').EQ.0) THEN + WRITE (6,'('' Folder is located on node '', + & A,''.'')') FOLDER1_BBOARD(3:FLEN) + ELSE + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + WRITE (6,'('' Folder is located on node '', + & A,''. Remote folder name is '',A,''.'')') + & FOLDER1_BBOARD(3:FLEN-1), + & BULLDIR_HEADER(13:TRIM(BULLDIR_HEADER)) + END IF + ELSE IF (FOLDER1_BBOARD.NE.'NONE') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (FLEN.GT.0) THEN + WRITE (6,'('' BBOARD for folder is '',A,''.'')') + & FOLDER1_BBOARD(:FLEN) + END IF + IF ((USERB1.EQ.0.AND.GROUPB1.EQ.0).OR.BTEST(USERB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /SPECIAL.'')') + IF (BTEST(GROUPB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /VMSMAIL.'')') + END IF + END IF + ELSE + WRITE (6,'('' No BBOARD has been defined.'')') + END IF + IF (FOLDER1_BBEXPIRE.GT.0) THEN + WRITE (6,'('' Default expiration is '',I3,'' days.'')') + & FOLDER1_BBEXPIRE + ELSE IF (FOLDER1_BBEXPIRE.EQ.-1) THEN + WRITE (6,'('' Default expiration is permanent.'')') + ELSE + WRITE (6,'('' No default expiration set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' SYSTEM has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,1)) THEN + WRITE (6,'('' DUMP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,3)) THEN + WRITE (6,'('' NOPROMPT_EXPIRE has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,4)) THEN + WRITE (6,'('' STRIP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,5)) THEN + WRITE (6,'('' DIGEST has been set.'')') + END IF + IF (F1_EXPIRE_LIMIT.GT.0) THEN + WRITE (6,'('' EXPIRATION limit is '',I3,'' days.'')') + & F1_EXPIRE_LIMIT + END IF + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_HEADER(IER) + IF (TEST2(SET_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is BRIEF.'')') + ELSE + WRITE (6,'('' Default is READNEW.'')') + END IF + ELSE + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is SHOWNEW.'')') + ELSE + WRITE (6,'('' Default is NOREADNEW.'')') + END IF + END IF + IF (TEST2(NOTIFY_FLAG_DEF,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is NOTIFY.'')') + ELSE + WRITE (6,'('' Default is NONOTIFY.'')') + END IF + CALL CLOSE_BULLUSER + END IF + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + +1000 FORMAT(' Current folder is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) +1010 FORMAT(' Folder name is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) + END + + + SUBROUTINE DIRECTORY_FOLDERS(FOLDER_COUNT) +C +C SUBROUTINE DIRECTORY_FOLDERS +C +C FUNCTION: Display all FOLDER entries. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + DATA SCRATCH_D1/0/ + + CHARACTER*17 DATETIME + + IF (FOLDER_COUNT.GT.0) GO TO 50 ! Skip init steps if this is + ! not the 1st page of folder + + IF (CLI$PRESENT('DESCRIBE')) THEN + NLINE = 2 ! Include folder descriptor if /DESCRIBE specified + ELSE + NLINE = 1 + END IF + +C +C Folder listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C folder file, and to avoid the possibility of the user holding the screen, +C and thus causing the folder file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + CALL INIT_QUEUE(SCRATCH_D1,FOLDER1_COM) + SCRATCH_D = SCRATCH_D1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDER = 0 + IER = 0 + FOLDER1 = ' ' ! Start folder search + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0) THEN + IF (INDEX(FOLDER1_BBOARD,'::').EQ.0.AND. + & BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + NUM_FOLDER = NUM_FOLDER + 1 + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + IF (NUM_FOLDER.EQ.0) THEN + WRITE (6,'('' There are no folders.'')') + RETURN + END IF + +C +C Folder entries are now in queue. Output queue entries to screen. +C + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + + FOLDER_COUNT = 1 ! Init folder number counter + +50 CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + WRITE (6,'(1X,''Folder'',22X,''Last message'',7X,''Messages'', + & 2X,''Owner'',/,1X,80(''-''))') + + IF (.NOT.PAGING) THEN + DISPLAY = (NUM_FOLDER-FOLDER_COUNT+1)*NLINE+2 + ELSE + DISPLAY = MIN((NUM_FOLDER-FOLDER_COUNT+1)*NLINE+2,PAGE_LENGTH-4) + ! If more entries than page size, truncate output + END IF + + DO I=FOLDER_COUNT,FOLDER_COUNT+(DISPLAY-2)/NLINE-1 + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + DIFF = COMPARE_BTIM + & (LAST_READ_BTIM(1,FOLDER1_NUMBER+1),F1_NEWEST_BTIM) + IF (F1_NBULL.GT.0) THEN + CALL SYS$ASCTIM(,DATETIME,F1_NEWEST_BTIM,) + ELSE + DATETIME = ' NONE' + END IF + IF (DIFF.GE.0.OR.F1_NBULL.EQ.0) THEN + WRITE (6,1000) ' '//FOLDER1,DATETIME,F1_NBULL,FOLDER1_OWNER + ELSE + WRITE (6,1000) '*'//FOLDER1,DATETIME,F1_NBULL,FOLDER1_OWNER + END IF + IF (NLINE.EQ.2) WRITE (6,'(1X,A)') FOLDER1_DESCRIP + FOLDER_COUNT = FOLDER_COUNT + 1 ! Update folder counter + END DO + + IF (FOLDER_COUNT.GT.NUM_FOLDER) THEN ! Outputted all entries? + FOLDER_COUNT = 0 ! Yes. Set counter to 0. + ELSE + WRITE(6,1010) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(1X,A26,2X,A17,2X,I8,2X,A12) +1010 FORMAT(1X,/,' Press RETURN for more...',/) + + END + + + SUBROUTINE SET_ACCESS(ACCESS) +C +C SUBROUTINE SET_ACCESS +C +C FUNCTION: Set access on folder for specified ID. +C +C PARAMETERS: +C ACCESS - Logical: If .true., grant access, if .false. deny access +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + LOGICAL ACCESS,ALL,READONLY + + EXTERNAL CLI$_ABSENT + + CHARACTER ID*64,RESPONSE*1 + + CHARACTER INPUT*132 + + IF (CLI$PRESENT('ALL')) THEN + ALL = .TRUE. + ELSE + ALL = .FALSE. + END IF + + IF (CLI$PRESENT('READONLY')) THEN + READONLY = .TRUE. + ELSE + READONLY = .FALSE. + END IF + + IER = CLI$GET_VALUE('ACCESS_FOLDER',FOLDER1,LEN) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + FOLDER1 = FOLDER + ELSE IF (LEN.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if it exists + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + ELSE IF (FOLDER1_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6, + & '('' ERROR: You are not able to modify access to the folder.'')') + ELSE + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + IF ((ALL.AND..NOT.READONLY).OR.(.NOT.ACCESS)) THEN + WRITE (6,'('' ERROR: Folder is not a private folder.'')') + RETURN + END IF + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Folder is not private. Do you want to make it so? (Y/N): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder access was not changed.'')') + RETURN + ELSE + FOLDER1_FLAG = IBSET(FOLDER1_FLAG,0) + IF (READONLY.AND.ALL) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + IF (ALL) THEN ! All finished, so exit + WRITE (6,'('' Access to folder has been modified.'')') + GOTO 100 + END IF + END IF + END IF + + IF (ALL) THEN + IF (ACCESS) THEN + CALL DEL_ACL(' ','R+W',IER) + IF (READONLY) THEN + CALL ADD_ACL('*','R',IER) + ELSE + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + END IF + ELSE + CALL DEL_ACL('*','R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access.'')') + CALL SYS_GETMSG(IER) + END IF + END IF + + DO WHILE (CLI$GET_VALUE('ACCESS_ID',INPUT,ILEN) + & .NE.%LOC(CLI$_ABSENT).AND..NOT.ALL) + IER = SYS_TRNLNM(INPUT,INPUT) + IF (INPUT(:1).EQ.'@') THEN + ILEN = INDEX(INPUT,',') - 1 + IF (ILEN.EQ.-1) ILEN = TRIM(INPUT) + OPEN (UNIT=3,STATUS='OLD',FILE=INPUT(2:ILEN), + & DEFAULTFILE='.DIS',IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Cannot find file '',A)') + & INPUT(2:ILEN) + RETURN + END IF + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + ELSE + FILE_OPEN = .TRUE. + END IF + ELSE + FILE_OPEN = .FALSE. + END IF + DO WHILE (TRIM(INPUT).GT.0) + COMMA = INDEX(INPUT,',') + IF (INPUT(:1).EQ.'[') COMMA = INDEX(INPUT,']') + 1 + IF (INPUT(:1).EQ.'"') COMMA = INDEX(INPUT(2:),'"') + 2 + IF (COMMA.GT.0) THEN + ID = INPUT(1:COMMA-1) + INPUT = INPUT(COMMA+1:) + ELSE + ID = INPUT + INPUT = ' ' + END IF + ILEN = TRIM(ID) + IF (ID.EQ.FOLDER1_OWNER) THEN + WRITE (6,'('' ERROR: Cannot modify access'', + & '' for owner of folder.'')') + ELSE + IF (ACCESS) THEN + IF (READONLY) THEN + CALL ADD_ACL(ID,'R',IER) + ELSE + CALL ADD_ACL(ID,'R+W',IER) + END IF + ELSE + CALL DEL_ACL(ID,'R+W',IER) + IF (.NOT.IER) CALL DEL_ACL(ID,'R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access for '',A, + & ''.'')') ID(:ILEN) + CALL SYS_GETMSG(IER) + ELSE + WRITE(6,'('' Access modified for '',A,''.'')') + & ID(:ILEN) + END IF + END IF + IF (TRIM(INPUT).EQ.0.AND.FILE_OPEN) THEN + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + FILE_OPEN = .FALSE. + END IF + END IF + END DO + END DO + +100 IF (OLD_FOLDER1_FLAG.NE.FOLDER1_FLAG) THEN + CALL OPEN_BULLFOLDER ! Open folder file + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FLAG = OLD_FOLDER1_FLAG + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + END IF + + RETURN + + END + + + + SUBROUTINE CHKACL(FILENAME,IERACL) +C +C SUBROUTINE CHKACL +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C IERACL - Error returned for attempt to open file. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) FILENAME + + INCLUDE '($ACLDEF)' + INCLUDE '($SSDEF)' + + CHARACTER*255 ACLENT,ACLSTR + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IERACL=SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + IF (IERACL.EQ.SS$_ACLEMPTY) THEN + IERACL = SS$_NORMAL.OR.IERACL + END IF + + RETURN + END + + + + SUBROUTINE CHECK_ACCESS(FILENAME,USERNAME,READ_ACCESS,WRITE_ACCESS) +C +C SUBROUTINE CHECK_ACCESS +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C USERNAME - Name of user to check access for. +C READ_ACCESS - Error returned indicating read access. +C WRITE_ACCESS - Error returned indicating write access. +C If initially set to -1, indicates just +C folder for read access. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER FILENAME*(*),USERNAME*(*),ACE*255,OUTPUT*80 + + INCLUDE '($ACLDEF)' + INCLUDE '($CHPDEF)' + INCLUDE '($ARMDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,CHP$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(4,CHP$_ACCESS,%LOC(ACCESS)) + CALL ADD_2_ITMLST(LEN(ACE),CHP$_MATCHEDACE,%LOC(ACE)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + FLAGS = 0 ! Default is no access + + ACCESS = ARM$M_READ ! Check if user has read access + READ_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + IF (.NOT.SETPRV_PRIV().AND.ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'READ').EQ.0) READ_ACCESS = 0 + ELSE IF (ICHAR(ACE(:1)).EQ.0.AND.READ_ACCESS) THEN + READ_ACCESS = 0 + END IF + + IF (WRITE_ACCESS.EQ.-1) THEN ! Only check read access + RETURN + ELSE IF (READ_ACCESS.EQ.0) THEN ! If no read access, then of + WRITE_ACCESS = 0 ! course there is no write access. + RETURN + END IF + + ACCESS = ARM$M_WRITE ! Check if user has write access + WRITE_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + IF (.NOT.SETPRV_PRIV().AND.ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'WRITE').EQ.0) WRITE_ACCESS = 0 + END IF + + RETURN + END + + + + + SUBROUTINE SHOWACL(FILENAME) +C +C SUBROUTINE SHOWACL +C +C FUNCTION: Shows users who are allowed to read private bulletin. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER*(*) FILENAME + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + CALL LIB$GET_VM(ACLLENGTH+8,ACLSTR) + CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) + + CALL READACL(FILENAME,%VAL(ACLSTR),ACLLENGTH) + + RETURN + END + + + + SUBROUTINE FOLDER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLFOLDER.INC' + + ENTRY WRITE_FOLDER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + WRITE (7,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + ENTRY REWRITE_FOLDER_FILE + + REWRITE (7) FOLDER_COM + + RETURN + + ENTRY REWRITE_FOLDER_FILE_TEMP + + REWRITE (7) FOLDER1_COM + + RETURN + + ENTRY READ_FOLDER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_TEMP(IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM(KEY_NUMBER,IER) + + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER_COM + END DO + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM_TEMP(KEY_NUMBER,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME_TEMP(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + END + + + SUBROUTINE USER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 SAVE_USERNAME + + ENTRY READ_USER_FILE(IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) USER_ENTRY + END DO + + TEMP_USER = USERNAME + USERNAME = SAVE_USERNAME + + RETURN + + ENTRY READ_USER_FILE_KEYNAME(KEY_NAME,IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=KEY_NAME,IOSTAT=IER) USER_ENTRY + END DO + + USERNAME = SAVE_USERNAME + TEMP_USER = KEY_NAME + + RETURN + + ENTRY READ_USER_FILE_HEADER(IER) + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=' ',IOSTAT=IER) USER_HEADER + END DO + + RETURN + + ENTRY WRITE_USER_FILE_NEW(IER) + + SET_FLAG(1) = SET_FLAG_DEF(1) + SET_FLAG(2) = SET_FLAG_DEF(2) + BRIEF_FLAG(1) = BRIEF_FLAG_DEF(1) + BRIEF_FLAG(2) = BRIEF_FLAG_DEF(2) + NOTIFY_FLAG(1) = NOTIFY_FLAG_DEF(1) + NOTIFY_FLAG(2) = NOTIFY_FLAG_DEF(2) + + ENTRY WRITE_USER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + WRITE (4,IOSTAT=IER) USER_ENTRY + END DO + + RETURN + + END + + + + + + SUBROUTINE SET_GENERIC(GENERIC) +C +C SUBROUTINE SET_GENERIC +C +C FUNCTION: Enables or disables "GENERIC" display, i.e. displaying +C general bulletins continually for a certain amount of days. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change GENERIC.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + IF (IER.EQ.0) THEN + IF (GENERIC) THEN + IF (CLI$PRESENT('DAYS')) THEN + IER = CLI$GET_VALUE('DAYS',BULL_PARAMETER) + CALL LIB$MOVC3(4,%REF(BULL_PARAMETER),NEW_FLAG(2)) + ELSE + NEW_FLAG(2) = ' 7' + END IF + ELSE + NEW_FLAG(2) = 0 + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET_LOGIN(LOGIN) +C +C SUBROUTINE SET_LOGIN +C +C FUNCTION: Enables or disables bulletin display at login. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER TODAY*23 + + DIMENSION NOLOGIN_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change LOGIN.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + IF (IER.EQ.0) THEN + IF (LOGIN.AND.COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + CALL SYS_BINTIM(TODAY,LOGIN_BTIM) + ELSE IF (.NOT.LOGIN) THEN + LOGIN_BTIM(1) = NOLOGIN_BTIM(1) + LOGIN_BTIM(2) = NOLOGIN_BTIM(2) + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE GET_UAF(USERNAME,USER,GROUP,ACCOUNT,FLAGS,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER USERNAME*(*),ACCOUNT*(*) + + INCLUDE '($UAIDEF)' + + INTEGER*2 UIC(2) + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(LEN(ACCOUNT),UAI$_ACCOUNT,%LOC(ACCOUNT)) + CALL ADD_2_ITMLST(4,UAI$_UIC,%LOC(UIC)) + CALL END_ITMLST(GETUAI_ITMLST) + + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) + + USER = UIC(1) + GROUP = UIC(2) + + RETURN + END + + + + SUBROUTINE DCLEXH(EXIT_ROUTINE) + + IMPLICIT INTEGER (A-Z) + + INTEGER*4 EXBLK(4) + + EXBLK(2) = EXIT_ROUTINE + EXBLK(3) = 1 + EXBLK(4) = %LOC(EXBLK(4)) + + CALL SYS$DCLEXH(EXBLK(1)) + + RETURN + END diff --git a/decus/vax90a/bulletin/bulletin6.for b/decus/vax90a/bulletin/bulletin6.for new file mode 100644 index 0000000..f567bff --- /dev/null +++ b/decus/vax90a/bulletin/bulletin6.for @@ -0,0 +1,1586 @@ +C +C BULLETIN6.FOR, Version 10/26/89 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE CLOSE_FILE +C +C SUBROUTINE CLOSE_FILE +C +C FUNCTION: To close out the bulletin files and enable CTRL-C & -Y +C + DATA LUN /0/ + + ENTRY CLOSE_BULLNOTIFY + LUN = LUN + 1 ! Unit = 10 + + ENTRY CLOSE_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY CLOSE_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY CLOSE_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY CLOSE_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY CLOSE_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN) + + LUN = 0 + + RETURN + END + + + SUBROUTINE CLOSE_FILE_DELETE + + IMPLICIT INTEGER (A-Z) + + DATA LUN /0/ + + ENTRY CLOSE_BULLNOTIFY_DELETE + LUN = LUN + 8 ! Unit = 10 + + ENTRY CLOSE_BULLDIR_DELETE + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL_DELETE + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN,STATUS='DELETE') + + LUN = 0 + + RETURN + END + + + SUBROUTINE OPEN_FILE(UNIT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($FORIOSDEF)' + + INCLUDE '($PRVDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + DATA LUN /0/ + + LUN = UNIT - 10 ! 10 gets added to LUN + + ENTRY OPEN_BULLNOTIFY + LUN = LUN + 1 ! Unit = 10 + + ENTRY OPEN_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL ! No breaks while file is open + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + WRITE (4,FMT=USER_FMT) USER_HEADER_KEY,NEWEST_BTIM, + & BBOARD_BTIM,PRV$M_OPER.OR.PRV$M_CMKRNL.OR. + & PRV$M_SETPRV,(0,I=1,FLONG*4-1) + CLOSE (UNIT=4) + IDUMMY = FILE_LOCK(IER,IER1) + ELSE IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + FOLDER1 = 'GENERAL' + FOLDER1_OWNER = 'SYSTEM' + FOLDER1_DESCRIP = 'Default general bulletin folder.' + FOLDER1_BBOARD = 'NONE' + FOLDER1_BBEXPIRE = 14 + NBULL = 0 + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER2, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + WRITE (7,FMT=FOLDER_FMT,IOSTAT=IER2) + & FOLDER1,0,FOLDER1_OWNER,FOLDER1_DESCRIP + & ,FOLDER1_BBOARD,FOLDER1_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,4,0,F_NEWEST_NOSYS_BTIM + ! 4 means system folder + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = 0 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.10) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=10,STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=3, + & ORGANIZATION='INDEXED',KEY=(1:12:CHARACTER), + & FORM='UNFORMATTED', + & FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.NOTIFY') + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (IER.NE.0) THEN + WRITE (6,'( + & '' Cannot open file in OPEN_FILE, unit = '',I)') LUN + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT ! Enable CTRL-Y & -C & EXIT + END IF + + LUN = 0 + + RETURN + END + + + + SUBROUTINE TIMER_ERR(UNIT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*14 NAMES(6) + DATA NAMES/'directory','message','BULLUSER.DAT','BULLFOLDER.DAT', + & 'BULLINF.DAT','notify'/ + INTEGER NAME(10) + DATA NAME/1,2,0,3,0,0,4,0,5,6/ + + IF (TEST_BULLCP().NE.2) THEN ! If BULLCP process, don't log error + WRITE(6,'('' ERROR: Unable to open '',A, + & '' file after 30 secs.'')') + & NAMES(NAME(UNIT))(:TRIM(NAMES(NAME(UNIT)))) + WRITE (6,'('' Please try again later.'')') + END IF + + CALL ENABLE_CTRL_EXIT ! No breaks while file is open + END + + + + SUBROUTINE OPEN_FILE_SHARED + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + EXTERNAL LNM_MODE_EXEC,ENABLE_CTRL_EXIT +C +C The following 2 files were used prior to V1.1. +C + CHARACTER*80 BULLDIR_FILE /'BULL_DIR:BULLDIR.DAT'/ + CHARACTER*80 BULLETIN_FILE /'BULL_DIR:BULLETIN.DAT'/ + + CHARACTER*25 SAVE_FOLDER + DATA SAVE_BLOCK/-1/ + + DATA LUN /0/ + + ENTRY OPEN_BULLNOTIFY_SHARED + LUN = LUN + 1 ! Unit = 10 + + ENTRY OPEN_BULLINF_SHARED + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF_SHARED + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER_SHARED + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER_SHARED + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR_SHARED + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL_SHARED + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.(FOLDER_NUMBER.EQ.0 + & .OR.FOLDER.EQ.'GENERAL')) THEN + IER2 = LIB$RENAME_FILE(BULLETIN_FILE,'GENERAL.BULLFIL') + IER2 = LIB$RENAME_FILE(BULLDIR_FILE,'GENERAL.BULLDIR') + IF (IER2) IDUMMY = FILE_LOCK(IER,IER1) ! Don't break out of loop + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND.REMOTE_SET.AND.(SAVE_BLOCK.NE.BLOCK.OR. + & SAVE_FOLDER.NE.FOLDER)) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,BULL_POINT + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + SAVE_BLOCK = BLOCK + SAVE_FOLDER = FOLDER + CALL GET_REMOTE_MESSAGE(IER) + IER = 0 + END IF + ELSE IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED',IOSTAT=IER,SHARED) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + + IF (IER.EQ.0) THEN + INQUIRE(UNIT=7,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.FOLDER_RECORD/4) THEN + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_BULLFOLDER(ASK_SIZE) + NTRIES = 0 + END IF + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.8) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=8,FILE='SYSUAF',DEFAULTFILE='SYS$SYSTEM:SYSUAF.DAT', + & ACCESS='KEYED',FORM='UNFORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,IOSTAT=IER,SHARED, + & USEROPEN=LNM_MODE_EXEC) + END DO + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.10) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=10,STATUS='OLD',IOSTAT=IER, + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=3, + & ORGANIZATION='INDEXED',KEY=(1:12:CHARACTER), + & FORM='UNFORMATTED', + & FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.NOTIFY') + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.LUN.NE.8) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + CALL OPEN_FILE(LUN) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + ELSE IF (IER.NE.0) THEN + WRITE (6,'( + & '' Cannot open file in OPEN_FILE_SHARE, unit = '',I)') LUN + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT + END IF + + LUN = 0 + + RETURN + END + + + + + + SUBROUTINE CONVERT_BULLDIRS + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER BUFFER*115 + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP', + & IOSTAT=IER) + + IF (IER.NE.0) GO TO 900 ! No BULLDIR file found. + + READ (2'1,IOSTAT=IER1) BUFFER + + CALL LIB$MOVC3(4,%REF(BUFFER(39:)),NBULL) + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+5 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END IF + + IF (IER1.NE.0) GO TO 800 + + CALL SYS_BINTIM(BUFFER(1:11)//' '//BUFFER(12:19),NEWEST_EXBTIM) + CALL SYS_BINTIM(BUFFER(20:30)//' '//BUFFER(31:38),NEWEST_MSGBTIM) + BULLDIR_HEADER(29:40) = BUFFER(39:) + CALL SYS_BINTIM(BUFFER(51:61)//' '//BUFFER(62:69),SHUTDOWN_BTIM) + BULLDIR_HEADER(49:52) = BUFFER(70:) + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) BULLDIR_HEADER + + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ (2'ICOUNT,IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + MSG_NUM = ICOUNT - 1 + DESCRIP = BUFFER(1:) + FROM = BUFFER(54:) + BULLDIR_ENTRY(78:81) = BUFFER(85:) + BULLDIR_ENTRY(90:97) = BUFFER(108:) + CALL SYS_BINTIM(BUFFER(89:99)//' '//BUFFER(100:107),EX_BTIM) + CALL SYS_BINTIM(BUFFER(66:76)//' '//BUFFER(77:84),MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (9,IOSTAT=IER) BULLDIR_ENTRY + ICOUNT = ICOUNT + 1 + END IF + END DO + +800 CLOSE (UNIT=9,DISPOSE='KEEP') + CLOSE (UNIT=2) + +900 CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFILES +C +C SUBROUTINE CONVERT_BULLFILES +C +C FUNCTION: Converts bulletin files to new format file. +C Add expiration time to directory file, add extra byte to bulletin +C file to show where each bulletin starts (for redunancy sake in +C case crash occurs). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*81 BUFFER + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=107,ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP',FORM='FORMATTED', + & SHARED,READONLY,IOSTAT=IER) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=10,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=80, + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=81, + & FORM='FORMATTED') + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + NEWEST_EXTIME = '00:00:00.00' + READ (9'1,1000,IOSTAT=IER) + & NEWEST_EXDATE,NEWEST_DATE,NEWEST_TIME(:8), + & NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_DATE,SHUTDOWN_TIME(:8) + NEMPTY = 0 + IF (IER.EQ.0) CALL WRITEDIR(0,IER1) + + EXTIME = '00:00:00.00' + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ(9'ICOUNT,1010,IOSTAT=IER) + & DESCRIP,FROM,DATE,TIME(:8),LENGTH,EXDATE,SYSTEM,BLOCK + IF (IER.EQ.0) THEN + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER(1:80)//CHAR(1) + DO I=2,LENGTH + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER + END DO + CALL WRITEDIR(ICOUNT-1,IER1) + ICOUNT = ICOUNT + 1 + END IF + END DO + + CLOSE (UNIT=9) + CLOSE (UNIT=2) + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + RETURN + +1000 FORMAT(A11,A11,A8,A4,A4,A4,A11,A8) +1010 FORMAT(A53,A12,A11,A8,A4,A11,A4,A4) + + END + + SUBROUTINE CONVERT_BULLFILE +C +C SUBROUTINE CONVERT_BULLFILE +C +C FUNCTION: Converts bulletin data file to new format file. +C +C NOTE: CONVERT_BULLFILES converts from 80 to 81 byte length. +C This converts from 81 byte length to 128 compressed format. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*80 BUFFER,NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL CLOSE_BULLDIR + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + CALL OPEN_BULLFOLDER + +100 READ (7,FMT=FOLDER_FMT,ERR=200) + & FOLDER,FOLDER_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + NEW_FILE = FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFILOLD' + OPEN (UNIT=10,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL' + & ,STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=81,ACCESS='DIRECT', + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.BULLFIL;-1',NEW_FILE) + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + IF (IER.EQ.1) THEN + NBLOCK = 0 + DO I=1,NBULL + CALL READDIR(I,IER) + NBLOCK = NBLOCK + 1 + SBLOCK = NBLOCK + DO J=BLOCK,LENGTH+BLOCK-1 + READ(10'J,'(A)') BUFFER + ILEN = TRIM(BUFFER) + IF (ILEN.EQ.0) ILEN = 1 + CALL STORE_BULL(ILEN,BUFFER,NBLOCK) + END DO + CALL FLUSH_BULL(NBLOCK) + LENGTH = NBLOCK - SBLOCK + 1 + BLOCK = SBLOCK + CALL WRITEDIR(I,IER) + END DO + + NEMPTY = 0 + CALL WRITEDIR(0,IER) + END IF + + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL CLOSE_BULLDIR + GOTO 100 + +200 CALL OPEN_BULLDIR_SHARED + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFOLDER(ASK_SIZE) +C +C SUBROUTINE CONVERT_BULLFOLDER +C +C FUNCTION: Converts bulletin folder file to new format. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + INCLUDE '($FORIOSDEF)' + + CHARACTER*80 NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + + EODIR = MAX(INDEX(BULLFOLDER_FILE,':'),INDEX(BULLFOLDER_FILE,']')) + SUFFIX = INDEX(BULLFOLDER_FILE(EODIR:),'.') + EODIR - 1 + NEW_FILE = BULLFOLDER_FILE(:SUFFIX)//'OLD' + + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + END DO + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=19,FILE=NEW_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER),DISPOSE='DELETE') + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + IF (ASK_SIZE.EQ.173/4) THEN + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8,5A4)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + IF (IER.EQ.0) THEN + WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + & ,F_NEWEST_BTIM + F_NUMBER = F_NUMBER + 1 + END IF + END DO + ELSE + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + IF (IER.EQ.0) THEN + FOLDER_FLAG = 0 + IF (F_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_BULLDIRS + END IF + END DO + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + F_NEWEST_BTIM(1) = 0 + F_NEWEST_BTIM(2) = 0 + ELSE + CALL READDIR(0,IER) + IF (NEWEST_DATE.EQ.'5-NOV-1956 ') THEN + IF (NBULL.GT.0) THEN + CALL READDIR(NBULL,IER) + NEWEST_DATE = DATE + NEWEST_TIME = TIME + CALL WRITEDIR(0,IER) + END IF + END IF + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + CLOSE (UNIT=2) + END IF + WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,FOLDER_FLAG,0,F_NEWEST_BTIM + F_NUMBER = F_NUMBER + 1 + END IF + END DO + END IF + + CLOSE (UNIT=7) + CLOSE (UNIT=19,STATUS='SAVE') + + IER = LIB$RENAME_FILE(NEW_FILE,BULLFOLDER_FILE) + IER = LIB$RENAME_FILE(BULLFOLDER_FILE//';-1',NEW_FILE) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:TRIM(BBOARD_DIRECTORY)) + & //'BOARD.COM;*') ! BULLETIN$ is referenced in old file + + RETURN + END + + SUBROUTINE CONVERT_USERFILE +C +C SUBROUTINE CONVERT_USERFILE +C +C FUNCTION: Converts user file to new format which has 8 bytes added. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER BUFFER*74,NEW_FILE*80 + + CHARACTER*11 LOGIN_DATE,READ_DATE + CHARACTER*8 LOGIN_TIME,READ_TIME + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + EODIR = MAX(INDEX(BULLUSER_FILE,':'),INDEX(BULLUSER_FILE,']')) + SUFFIX = INDEX(BULLUSER_FILE(EODIR:),'.') + EODIR - 1 + NEW_FILE = BULLUSER_FILE(:SUFFIX)//'OLD' + IER = LIB$RENAME_FILE(BULLUSER_FILE,NEW_FILE) + + OPEN (UNIT=9,FILE=NEW_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + INQUIRE (UNIT=9,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IER = LIB$RENAME_FILE(NEW_FILE,BULLUSER_FILE) + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + IF (IER.EQ.0) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot convert user file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + CALL SYS_GETMSG(IER1) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + CALL ENABLE_CTRL_EXIT + END IF + + DO I=1,FLONG + NEW_FLAG(I) = 'FFFFFFFF'X + NOTIFY_FLAG(I) = 0 + BRIEF_FLAG(I) = 0 + SET_FLAG(I) = 0 + END DO + + IF (RECL.EQ.42.OR.RECL.EQ.50.OR.RECL.EQ.58.OR.RECL.EQ.66.OR. + & RECL.EQ.74) THEN ! Old format + IF (RECL.LE.58) RECL = 50 + IER = 0 + DO WHILE (IER.EQ.0) + READ (9,'(A)',IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + TEMP_USER = BUFFER(1:12) + LOGIN_DATE = BUFFER(13:23) + LOGIN_TIME = BUFFER(24:31) + READ_DATE = BUFFER(32:42) + READ_TIME = BUFFER(43:50) + IF (RECL.EQ.58) + & CALL LIB$MOVC3(8,%REF(BUFFER(51:)),SET_FLAG(1)) + IF (RECL.EQ.66) + & CALL LIB$MOVC3(8,%REF(BUFFER(59:)),NEW_FLAG(1)) + IF (RECL.EQ.74) + & CALL LIB$MOVC3(8,%REF(BUFFER(67:)),NOTIFY_FLAG(1)) + CALL SYS_BINTIM(LOGIN_DATE//' '//LOGIN_TIME,LOGIN_BTIM) + CALL SYS_BINTIM(READ_DATE//' '//READ_TIME,READ_BTIM) + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + IF (RECL.LT.66) THEN + READ (4,KEY=USER_HEADER_KEY,FMT=USER_FMT) TEMP_USER, + & LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + NEW_FLAG(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + ELSE ! Folder maxmimum increase + OFLONG = (RECL - 28) / 16 ! Old #longwords/flag + DO WHILE (IER.EQ.0) + READ (9,FMT='(A12,<4+OFLONG*4>A4)',IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM, + & (NEW_FLAG(I),I=1,OFLONG),(SET_FLAG(I),I=1,OFLONG), + & (BRIEF_FLAG(I),I=1,OFLONG),(NOTIFY_FLAG(I),I=1,OFLONG) + IF (IER.EQ.0) THEN + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + END IF + + IER = 0 + + CLOSE (UNIT=9) + CLOSE (UNIT=4) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + END + + + SUBROUTINE READDIR(BULLETIN_NUM,ICOUNT) +C +C SUBROUTINE READDIR +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file and returns the information for that entry. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, gives header info, i.e number of bulls, +C number of blocks in bulletin file, etc. +C OUTPUTS: +C ICOUNT - The last record read by this routine. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + CHARACTER*3 CFOLDER_NUMBER + + ICOUNT = BULLETIN_NUM + + IF (ICOUNT.EQ.0) THEN + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=0,IOSTAT=IER) BULLDIR_HEADER + END DO + IF (IER.EQ.0) THEN + CALL CONVERT_HEADER_FROMBIN + DIR_NUM = 0 + END IF + ELSE + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 8,0 + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_HEADER + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + CALL CONVERT_HEADER_FROMBIN + RETURN + END IF + END IF + IF (IER.EQ.0) THEN + IF (NBULL.LT.0) THEN ! This indicates bulletin deletion + ! was incomplete. + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR + CALL CLEANUP_DIRFILE(1) + CALL UPDATE_FOLDER + END IF + IF (NEMPTY.EQ.' ') NEMPTY = 0 +C +C Check to see if cleanup of empty file space is necessary, which is +C defined here as being 50 blocks (200 128byte records). Also check +C to see if cleanup was in progress but didn't properly finish. +C + IF (NEMPTY.GT.200.AND.TEST_BULLCP().EQ.0) THEN + WRITE (CFOLDER_NUMBER,'(I3)') FOLDER_NUMBER + IER1 = LIB$SPAWN('$'//COMMAND_PROMPT(1:INDEX( + & COMMAND_PROMPT,'>')-1)//'/CLEANUP='//CFOLDER_NUMBER, + & 'NL:','NL:',1,'BULL_CLEANUP') + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLEANUP_BULLFILE + END IF + END IF + ELSE + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + IF (DIR_NUM.EQ.ICOUNT-1) THEN + READ(2,IOSTAT=IER) BULLDIR_ENTRY + IF (MSG_NUM.NE.ICOUNT) IER = 36 + ELSE + READ(2,KEYID=0,KEY=ICOUNT,IOSTAT=IER) BULLDIR_ENTRY + END IF + END DO + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + DIR_NUM = -1 + END IF + ELSE + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 8,ICOUNT + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_ENTRY + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + CALL CONVERT_ENTRY_FROMBIN + RETURN + END IF + END IF + END IF + + IF (IER.EQ.0) ICOUNT = ICOUNT + 1 + + UNLOCK 2 + + RETURN + + END + + + + + + SUBROUTINE READDIR_KEYGE(IER) +C +C SUBROUTINE READDIR_KEYGE +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file corresponding to or later than the date specified. +C +C INPUTS: +C MSG_KEY - Message key (passed via BULLDIR.INC common block). +C OUTPUTS: +C IER - If not 0, no entry found. Else contains message number. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ(2,KEYID=1,KEYGT=MSG_KEY,IOSTAT=IER) BULLDIR_ENTRY + END DO + IF (IER.EQ.0) THEN + IER = MSG_NUM + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + IER = 0 + DIR_NUM = -1 + END IF + UNLOCK 2 + ELSE + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 8,-1,MSG_KEY + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_ENTRY + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + IER = MSG_NUM + CALL CONVERT_ENTRY_FROMBIN + END IF + END IF + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,NEWEST_EXBTIM,) + + NEWEST_EXDATE = DATETIME + NEWEST_EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,NEWEST_MSGBTIM,) + + NEWEST_DATE = DATETIME + NEWEST_TIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,SHUTDOWN_BTIM,) + + SHUTDOWN_DATE = DATETIME + SHUTDOWN_TIME = DATETIME(13:) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,EX_BTIM,) + + EXDATE = DATETIME + EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,MSG_BTIM,) + + DATE = DATETIME + TIME = DATETIME(13:) + + RETURN + END + + + + + + SUBROUTINE WRITEDIR(BULLETIN_NUM,IER) +C +C SUBROUTINE WRITEDIR +C +C FUNCTION: Writes the entry for the specified bulletin in the +C directory file. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, write the header of the directory file. +C OUTPUTS: +C IER - Error status from WRITE. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + INCLUDE 'BULLDIR.INC' + + CONV = .TRUE. + + GO TO 10 + + ENTRY WRITEDIR_NOCONV(BULLETIN_NUM,IER) + + CONV = .FALSE. + +10 IF (BULLETIN_NUM.EQ.0) THEN + IF (CONV) CALL CONVERT_HEADER_TOBIN + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,0,BULLDIR_HEADER + ELSE + IER = -1 + IF (DIR_NUM.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=0,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + IF (IER.NE.0) THEN + WRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + ELSE + IF (CONV) CALL CONVERT_ENTRY_TOBIN + MSG_NUM = BULLETIN_NUM + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,BULLETIN_NUM,BULLDIR_ENTRY + ELSE + IER = -1 + IF (DIR_NUM.EQ.MSG_NUM) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=BULLETIN_NUM,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + ELSE + WRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + END IF + END IF + END IF + + IF (REMOTE_SET.AND.IER.GT.0) CALL ERROR_AND_EXIT + + DIR_NUM = -1 + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(NEWEST_EXDATE//' '//NEWEST_EXTIME,NEWEST_EXBTIM) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_MSGBTIM) + + CALL SYS_BINTIM(SHUTDOWN_DATE//' '//SHUTDOWN_TIME,SHUTDOWN_BTIM) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(EXDATE//' '//EXTIME,EX_BTIM) + + CALL SYS_BINTIM(DATE//' '//TIME,MSG_BTIM) + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + + RETURN + END + + + + + SUBROUTINE READACL(FILENAME,ACLENT,ACLLENGTH) +C +C SUBROUTINE READACL +C +C FUNCTION: Reads the ACL of a file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C ACLENT - String which will be large enough to hold ACL information. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*(*),OUTPUT*80,ACLSTR*255,FILENAME*(*) + CHARACTER NOT_ID*3 + DATA NOT_ID /'=[,'/ + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + DO ACC_TYPE=1,2 + POINT = 1 + OUTLEN = 0 + DO WHILE ((POINT.LT.ACLLENGTH).AND.IER) + IER = SYS$FORMAT_ACL(ACLENT(POINT:POINT-1+ + & ICHAR(ACLENT(POINT:POINT))),ACLLEN,ACLSTR,,,,) + AC = INDEX(ACLSTR,',ACCESS') + IF ((ACC_TYPE.EQ.1.AND.INDEX(ACLSTR(AC:),'WRITE').GT.0).OR. + & (ACC_TYPE.EQ.2.AND.INDEX(ACLSTR(AC:),'READ').GT.0)) THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,',ACCESS') - 1 + IF (ACLSTR(END_ID:END_ID).EQ.']') THEN + START_ID = END_ID - 1 + DO WHILE + & (INDEX(NOT_ID,ACLSTR(START_ID:START_ID)).EQ.0) + START_ID = START_ID - 1 + END DO + START_ID = START_ID + 1 + END_ID = END_ID - 1 + IF (ACLSTR(START_ID:START_ID).EQ.'*') THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,'ACCESS') - 2 + END IF + END IF + IF (OUTLEN.EQ.0) THEN + IF (FILENAME.NE.BULLUSER_FILE) THEN + IF (ACC_TYPE.EQ.1) THEN + WRITE (6,'( + & '' These users can read and write to this folder:'')') + ELSE + WRITE (6,'( + & '' These users can only read this folder:'')') + END IF + ELSE + WRITE (6,'('' The following are rights identifiers'', + & '' which will give privileges.'')') + END IF + OUTLEN = 1 + END IF + IDLEN = END_ID - START_ID + 1 + IF (OUTLEN+IDLEN-1.GT.80) THEN + WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-1) + OUTPUT = ACLSTR(START_ID:END_ID)//',' + OUTLEN = IDLEN + 2 + ELSE IF (OUTLEN+IDLEN-1.EQ.80) THEN + WRITE (6,'(1X,A)') + & OUTPUT(:OUTLEN-1)//ACLSTR(START_ID:END_ID) + OUTLEN = 1 + ELSE + OUTPUT(OUTLEN:) = ACLSTR(START_ID:END_ID)//',' + OUTLEN = OUTLEN + IDLEN + 1 + END IF + END IF + POINT = POINT + ICHAR(ACLENT(POINT:POINT)) + END DO + IF (OUTLEN.GT.1) WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-2) + END DO + + RETURN + END + + + + + SUBROUTINE CONVERT_INFFILE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + OPEN (UNIT=10,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + INQUIRE (UNIT=10,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + RECL = RECL/8 + + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + DO WHILE (IER.EQ.0) + READ (10,IOSTAT=IER) TEMP_USER,((LAST_READ_BTIM(J,I),J=1,2),I=1,RECL) + IF (IER.EQ.0) WRITE (9) TEMP_USER, + & ((LAST_READ_BTIM(J,I),J=1,2),I=1,FOLDER_MAX) + END DO + + CLOSE (UNIT=10,STATUS='DELETE') + + CLOSE (UNIT=9) + + RETURN + END + + + SUBROUTINE ERROR_AND_EXIT + + IMPLICIT INTEGER (A-Z) + + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + CALL ENABLE_CTRL_EXIT + + RETURN + END + + + + + SUBROUTINE COPY_ACL(INFILE,OUTFILE) +C +C SUBROUTINE COPY_ACL +C +C FUNCTION: +C Copy ACLs from one file to another file +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*255 + + CHARACTER*(*) INFILE,OUTFILE + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) + ! Get length needed to store acl output + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,) + + CALL LIB$GET_VM(ACLLENGTH+8,ACLSTR) ! Create character string to + CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) ! store acl + + CALL COPY_ACL1(INFILE,OUTFILE,%VAL(ACLSTR),ACLLENGTH) + ! Pass location of string + RETURN + END + + + SUBROUTINE COPY_ACL1(INFILE,OUTFILE,ACLENT,ACLLENGTH) +C +C SUBROUTINE COPY_ACL1 +C +C FUNCTION: Called by COPY_ACL to actually do the copy. Need 2 routines +C since must convert location of string into a character string. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*(*),INFILE*(*),OUTFILE*(*) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,) + ! Read input file acl + + CALL INIT_ITMLST ! Initialize item list + POINT = 1 + DO WHILE (POINT.LT.ACLLENGTH) ! Transfer all acls to output file + CALL ADD_2_ITMLST(ICHAR(ACLENT(POINT:POINT)),ACL$C_ADDACLENT, + & %LOC(ACLENT(POINT:))) + POINT = POINT + ICHAR(ACLENT(POINT:POINT)) + END DO + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,OUTFILE,%VAL(ACL_ITMLST),,,) + + RETURN + END diff --git a/decus/vax90a/bulletin/bulletin7.for b/decus/vax90a/bulletin/bulletin7.for new file mode 100644 index 0000000..f9b970d --- /dev/null +++ b/decus/vax90a/bulletin/bulletin7.for @@ -0,0 +1,1845 @@ + +C +C BULLETIN7.FOR, Version 4/3/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE UPDATE_LOGIN(ADD_BULL) +C +C SUBROUTINE UPDATE_LOGIN +C +C FUNCTION: Updates the login file when a bulletin has been deleted +C or added. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($BRKDEF)' + + INCLUDE '($SSDEF)' + + DIMENSION READ_BTIM_SAVE(2),TEMP_BTIM(2) + + CHARACTER OUTPUT*160,TERMINAL*7,FLAGS*1 + CHARACTER*1 CR/13/,LF/10/,BELL/7/ + +C +C We want to keep the last read date for comparison when selecting new +C folders, so save it for later restoring. +C + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL OPEN_BULLUSER_SHARED + +C +C Newest date/time in user file only applies to general bulletins. +C This was present before adding folder capability. +C We set flags in user entry to show new folder added for folder bulletins. +C However, the newest bulletin for each folder is not continually updated, +C As it is only used when comparing to the last bulletin read time, and to +C store this for each folder would be too expensive. +C + + TEMP_BTIM(1) = NEWEST_BTIM(1) + TEMP_BTIM(2) = NEWEST_BTIM(2) + CALL READ_USER_FILE_HEADER(IER) + NEWEST_BTIM(1) = TEMP_BTIM(1) + NEWEST_BTIM(2) = TEMP_BTIM(2) + + IF (IER.NE.0) THEN + CALL CLOSE_BULLUSER + RETURN + ELSE IF (FOLDER_NUMBER.EQ.0) THEN + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_BTIM) + REWRITE (4,IOSTAT=IER) USER_HEADER + END IF + + IF (ADD_BULL.AND.FOLDER_NUMBER.GE.0) THEN ! Message added? + IF (FOLDER_NUMBER.GT.0) THEN ! Folder private? + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CHECK_ACL = 0 + ELSE + CHECK_ACL = 1 + END IF + ELSE + CHECK_ACL = 0 + END IF + + OUTPUT = BELL//CR//LF//LF// + & 'New bulletin added to folder '//FOLDER(1:TRIM(FOLDER)) + & //'. From: '//FROM(1:TRIM(FROM))//CR//LF// + & 'Description: '//DESCRIP(1:TRIM(DESCRIP)) + + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',FLAGS) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',FLAGS) + END IF + + FLAG = 0 + BFLAG = 0 + + CALL SYS$SETRWM(%VAL(1)) ! Don't wait if can't broadcast + + IF (IER) THEN + READ (FLAGS(:1),'(I1)',IOSTAT=IER) FLAG + IF (BTEST(FLAG,1).AND.IER.EQ.0) THEN ! Node part of cluster? + CALL OPEN_BULLNOTIFY_SHARED ! Yes, get notify list. + DO WHILE (REC_LOCK(IER1)) ! Any entries? + READ (10,IOSTAT=IER1) TEMP_USER + END DO + IF (IER1.NE.0) THEN ! No entries. + CALL READ_USER_FILE(IER) ! Create entries from + DO WHILE (IER.EQ.0) ! user file. + IF (TEMP_USER(:1).NE.':'.AND.TEMP_USER(:1).NE.'*' + & .AND.TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (10) TEMP_USER + END IF + CALL READ_USER_FILE(IER) + END DO + DO WHILE (REC_LOCK(IER1)) ! Reset to first entry. + READ (10,KEYGT=' ',IOSTAT=IER1) + & TEMP_USER + END DO + END IF + + BFLAG = BRK$M_CLUSTER ! Broadcast to all nodes + + IF (TEST2(NOTIFY_FLAG_DEF,FOLDER_NUMBER).AND. ! If /ALL then + & TEMP_USER.EQ.'*'.AND.IER1.EQ.0) THEN ! notify all. + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & ,%VAL(BRK$C_ALLUSERS),,,%VAL(BFLAG),,,,) + IER1 = 1 ! Don't have to loop through notify list + END IF + END IF + END IF + + DO WHILE ((BFLAG.EQ.0.AND.GETUSERS(TEMP_USER,TERMINAL)).OR. + & (BFLAG.NE.0.AND.IER1.EQ.0)) + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + IF (IER.EQ.0.AND.TEMP_USER.NE.FROM.AND. + & TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + IF (CHECK_ACL) THEN + CALL CHECK_ACCESS + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL', + & TEMP_USER,IER,WRITE_ACCESS) + ELSE + IER = 1 + END IF + IF (IER) THEN + IF (BFLAG.EQ.0) THEN + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & TERMINAL(:TRIM(TERMINAL)),%VAL(BRK$C_DEVICE) + & ,,,%VAL(BFLAG),,,,) + ELSE + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & TEMP_USER(:TRIM(TEMP_USER)),%VAL(BRK$C_USERNAME) + & ,,,%VAL(BFLAG),,,,) + END IF + ELSE + CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + REWRITE (4,IOSTAT=IER) TEMP_USER//USER_ENTRY(13:) + END IF + ELSE IF (IER.NE.0.AND.BFLAG.NE.0) THEN + DELETE (UNIT=10) + END IF + IF (BFLAG.NE.0) THEN + DO WHILE (REC_LOCK(IER1)) + READ (10,IOSTAT=IER1) TEMP_USER + END DO + END IF + END DO + IF (BFLAG.NE.0) CALL CLOSE_BULLNOTIFY + CALL SYS$SETRWM(%VAL(0)) + END IF + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + ! Reobtain present values as calling programs still uses them + + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + + CALL CLOSE_BULLUSER + + RETURN + + END + + + + + + SUBROUTINE ADD_ENTRY +C +C SUBROUTINE ADD_ENTRY +C +C FUNCTION: Enters a new directory entry in the directory file. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY_TIME*32 + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + IF (REMOTE_SET) THEN + LOCAL = .TRUE. + IF (INCMD(:3).EQ.'ADD') LOCAL = CLI$PRESENT('LOCAL') + IF (LOCAL) THEN + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,0,0,0,0 + ELSE + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,CLI$PRESENT('BROADCAST'), + & CLI$PRESENT('BELL'),CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER') + END IF + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,TODAY_TIME,F1_NEWEST_BTIM,) + NEWEST_DATE = TODAY_TIME(1:11) + NEWEST_TIME = TODAY_TIME(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + CALL UPDATE_LOGIN(.TRUE.) + RETURN + END IF + + CALL SYS$ASCTIM(,TODAY_TIME,,) + DATE = TODAY_TIME(1:11) + TIME = TODAY_TIME(13:) + + CALL READDIR(0,IER) + + IF (IER.NE.1) THEN + NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = '00:00:00.00' + NBULL = 0 + NBLOCK = 0 + SHUTDOWN = 0 + NEMPTY = 0 + END IF + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + NBULL = NBULL + 1 + BLOCK = NBLOCK + 1 + NBLOCK = NBLOCK + LENGTH + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + CALL UPDATE_LOGIN(.TRUE.) + + CALL WRITEDIR(NBULL,IER) + + CALL WRITEDIR(0,IER) + + RETURN + END + + + + + INTEGER FUNCTION COMPARE_BTIM(BTIM1,BTIM2) +C +C FUNCTION COMPARE_BTIM +C +C FUCTION: Compares times in binary format to see which is farther in future. +C +C INPUTS: +C BTIM1 - First time in binary format +C BTIM2 - Second time in binary format +C OUTPUT: +C Returns +1 if first time is farther in future +C Returns -1 if second time is farther in future +C Returns 0 if equal time +C + IMPLICIT INTEGER (A - Z) + + DIMENSION BTIM1(2),BTIM2(2),DIFF(2) + + CALL LIB$SUBX(BTIM1,BTIM2,DIFF) + + IF (DIFF(2).LT.0) THEN + COMPARE_BTIM = -1 + ELSE IF (DIFF(2).GE.0) THEN + COMPARE_BTIM = +1 + END IF + + RETURN + END + + + + + + INTEGER FUNCTION MINUTE_DIFF(DATE2,DATE1) +C +C FUNCTION MINUTE_DIFF +C +C FUNCTION: Finds difference in minutes between 2 binary times. +C +C + IMPLICIT INTEGER (A-Z) + + DIMENSION DATE1(2),DATE2(2) + + CALL LIB$DAY(DAYS1,DATE1,MSECS1) + CALL LIB$DAY(DAYS2,DATE2,MSECS2) + + MINUTE_DIFF = (DAYS2-DAYS1)*24*60 + (MSECS2-MSECS1)/6000 + + RETURN + END + + + + + + + INTEGER FUNCTION COMPARE_DATE(DATE1,DATE2) +C +C FUNCTION COMPARE_DATE +C +C FUCTION: Compares dates to see which is farther in future. +C +C INPUTS: +C DATE1 - First date (dd-mm-yy) +C DATE2 - Second date (If is equal to ' ', then use present date) +C OUTPUT: +C Returns the difference in days between the two dates. +C If the DATE1 is farther in the future, the output is positive, +C else it is negative. +C + IMPLICIT INTEGER (A - Z) + + CHARACTER*(*) DATE1,DATE2 + INTEGER USER_TIME(2) + + CALL SYS_BINTIM(DATE1,USER_TIME) + + CALL VERIFY_DATE(USER_TIME) +C +C LIB$DAY crashes if date invalid, which happened once due to an unknown +C hardware or software error which created a date very far in the future. +C + CALL LIB$DAY(DAY1,USER_TIME) + + IF (DATE2.NE.' ') THEN + CALL SYS_BINTIM(DATE2,USER_TIME) + CALL VERIFY_DATE(USER_TIME) + ELSE + CALL SYS$GETTIM(USER_TIME) + END IF + + CALL LIB$DAY(DAY2,USER_TIME) + + COMPARE_DATE = DAY1 - DAY2 + + RETURN + END + + + + SUBROUTINE VERIFY_DATE(BTIM) + + IMPLICIT INTEGER (A-Z) + + DIMENSION BTIM(2),TEMP(2) + + CALL SYS_BINTIM(' 5-NOV-2011 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.GT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + CALL SYS_BINTIM(' 5-NOV-1955 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.LT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + RETURN + END + + + + INTEGER FUNCTION COMPARE_TIME(TIME1,TIME2) +C +C FUNCTION COMPARE_TIME +C +C FUCTION: Compares times to see which is farther in future. +C +C INPUTS: +C TIME1 - First time (hh:mm:ss.xx) +C TIME2 - Second time +C OUTPUT: +C Outputs (TIME1-TIME2) in seconds. Thus, if TIME1 is further +C in the future, outputs positive number, else negative. +C + + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) TIME1,TIME2 + CHARACTER*23 TODAY_TIME + CHARACTER*11 TEMP2 + + IF (TIME2.EQ.' ') THEN + CALL SYS$ASCTIM(,TODAY_TIME,,) + TEMP2 = TODAY_TIME(13:) + ELSE + TEMP2 = TIME2 + END IF + + COMPARE_TIME = 3600*10*(ICHAR(TIME1(1:1))-ICHAR(TEMP2(1:1))) + & +3600*(ICHAR(TIME1(2:2))-ICHAR(TEMP2(2:2))) + & +60*10*(ICHAR(TIME1(4:4))-ICHAR(TEMP2(4:4))) + & +60*(ICHAR(TIME1(5:5))-ICHAR(TEMP2(5:5))) + & +10*(ICHAR(TIME1(7:7))-ICHAR(TEMP2(7:7))) + & +(ICHAR(TIME1(8:8))-ICHAR(TEMP2(8:8))) + + IF (COMPARE_TIME.EQ.0) THEN + COMPARE_TIME = 10*(ICHAR(TIME1(10:10))-ICHAR(TEMP2(10:10))) + & +(ICHAR(TIME1(11:11))-ICHAR(TEMP2(11:11))) + IF (COMPARE_TIME.GT.0) THEN + COMPARE_TIME = 1 + ELSE IF (COMPARE_TIME.LT.0) THEN + COMPARE_TIME = -1 + END IF + END IF + + RETURN + END + +C------------------------------------------------------------------------- +C +C The following are subroutines to create a linked-list queue for +C temporary buffer storage of data that is read from files to be +C outputted to the terminal. This is done so as to be able to close +C the file as soon as possible. +C +C Each record in the queue has the following format. The first two +C words are used for creating a character variable. The first word +C contains the length of the character variable, the second contains +C the address. The address is simply the address of the 3rd word of +C the record. The last word in the record contains the address of the +C next record. Every time a record is written, if that record has a +C zero link, it adds a new record for the next write operation. +C Therefore, there will always be an extra record in the queue. To +C check for the end of the queue, the last word (link to next record) +C is checked to see if it is zero. +C +C------------------------------------------------------------------------- + SUBROUTINE INIT_QUEUE(HEADER,DATA) + CHARACTER*(*) DATA + INTEGER HEADER + IF (HEADER.NE.0) RETURN ! Queue already initialized + LENGTH = LEN(DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + CALL LIB$GET_VM(LENGTH+12,HEADER) + CALL MAKE_CHAR(%VAL(HEADER),LEN(DATA),LENGTH) + RETURN + END + + + SUBROUTINE WRITE_QUEUE(RECORD,NEXT,DATA) + INTEGER RECORD(1) + CHARACTER*(*) DATA + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,DATA,%VAL(%LOC(RECORD))) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + IF (NEXT.NE.0) RETURN + CALL LIB$GET_VM(LENGTH+12,NEXT) + CALL MAKE_CHAR(%VAL(NEXT),RECORD(1),LENGTH) + RECORD((LENGTH+12)/4) = NEXT + RETURN + END + + SUBROUTINE READ_QUEUE(RECORD,NEXT,DATA) + CHARACTER*(*) DATA + INTEGER RECORD(1) + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,%VAL(%LOC(RECORD)),DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + RETURN + END + + SUBROUTINE COPY_CHAR(LENGTH,INCHAR,OUTCHAR) + CHARACTER*(*) INCHAR,OUTCHAR + OUTCHAR = INCHAR(:LENGTH) + RETURN + END + + SUBROUTINE MAKE_CHAR(IARRAY,CHAR_LEN,REAL_LEN) + IMPLICIT INTEGER (A-Z) + DIMENSION IARRAY(1) + IARRAY(1) = CHAR_LEN + IARRAY(2) = %LOC(IARRAY(3)) + IARRAY(REAL_LEN/4+3) = 0 + RETURN + END + + + + SUBROUTINE DISABLE_PRIVS +C +C SUBROUTINE DISABLE_PRIVS +C +C FUNCTION: Disable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + DATA PRV_DEPTH /0/ + + COMMON /REALPROC/ REALPROCPRIV(2) + + PRV_DEPTH = PRV_DEPTH + 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(0),,,SETPRV) ! Get privileges + + SETPRV(1) = SETPRV(1).AND..NOT.REALPROCPRIV(1) + + CALL SYS$SETPRV(%VAL(0),SETPRV,,) ! Disable installed privs + + RETURN + END + + + + SUBROUTINE ENABLE_PRIVS +C +C SUBROUTINE ENABLE_PRIVS +C +C FUNCTION: Enable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + PRV_DEPTH = PRV_DEPTH - 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(1),SETPRV,,) ! Enable image privs + + RETURN + END + + + + SUBROUTINE CHECK_PRIV_IO(ERROR) +C +C SUBROUTINE CHECK_PRIV_IO +C +C FUNCTION: Checks SYS$OUTPUT and SYS$ERROR to see if they need +C privileges to output to. +C + + IMPLICIT INTEGER (A-Z) + + CALL DISABLE_PRIVS ! Disable SYSPRV + + OPEN (UNIT=6,FILE='SYS$OUTPUT',IOSTAT=IER,STATUS='NEW') + CLOSE (UNIT=6,STATUS='DELETE') + + OPEN (UNIT=4,FILE='SYS$ERROR',IOSTAT=IER1,STATUS='NEW') + IF (IER.NE.0.OR.IER1.NE.0) THEN + IF (IER1.EQ.0) WRITE (4,100) + IF (IER.EQ.0) WRITE (6,200) + ERROR = 1 + ELSE + CLOSE (UNIT=4,STATUS='DELETE') + ERROR = 0 + END IF + + CALL ENABLE_PRIVS ! Enable SYSPRV + +100 FORMAT(1X,'ERROR: SYS$OUTPUT cannot be opened.') +200 FORMAT(1X,'ERROR: SYS$ERROR cannot be opened.') + + RETURN + END + + + SUBROUTINE CHANGE_FLAG(CMD,FLAG) +C +C SUBROUTINE CHANGE_FLAG +C +C FUNCTION: Sets flags for specified folder. +C +C INPUTS: +C CMD - LOGICAL*4 value. If TRUE, set flag. +C If FALSE, clear flag. +C FLAG - If 1, modify NEW_FLAG, if 2, modify SET_FLAG +C If 3, modify BRIEF_FLAG, 4, modify NOTIFY_FLAG +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + + DATA CHANGE_FOLDER /.FALSE./ + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) + IF (IER) THEN + FOLDER_NUMBER_SAVE = FOLDER_NUMBER + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + CALL CLOSE_BULLFOLDER + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder found.'')') + RETURN + END IF + END IF + FOLDER_NUMBER = FOLDER1_NUMBER + CHANGE_FOLDER = .TRUE. + END IF + +C +C Find user entry in BULLUSER.DAT to update information. +C + + ENTRY CHANGE_FLAG_NOCMD(CMD,FLAG) + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.GT.0) THEN ! No entry (how did this happen??) + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's today + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) ! Fake new entry + CALL READ_USER_FILE_HEADER(IER) + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + ELSE + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + CALL CLOSE_FILE (4) + + IF (FLAG.EQ.4) THEN ! If notify, see if cluster + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',TEMP_USER) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',TEMP_USER) + END IF + READ (TEMP_USER(:1),'(I1)',IOSTAT=IER) BFLAG + IF (BTEST(BFLAG,1).AND.IER.EQ.0) THEN + CALL OPEN_BULLNOTIFY_SHARED + DO WHILE (REC_LOCK(IER)) + READ (10,IOSTAT=IER) TEMP_USER + END DO + IF (TEMP_USER.NE.'*') THEN + IF (CMD) THEN + WRITE (10,IOSTAT=IER) USERNAME + ELSE + DO WHILE (REC_LOCK(IER)) + READ (10,KEY=USERNAME,IOSTAT=IER) + END DO + IF (IER.EQ.0) DELETE (UNIT=10) + END IF + END IF + CALL CLOSE_BULLNOTIFY + END IF + END IF + + IF (CHANGE_FOLDER) THEN + FOLDER_NUMBER = FOLDER_NUMBER_SAVE + CHANGE_FOLDER = .FALSE. + END IF + + RETURN + + END + + + + + SUBROUTINE SET_VERSION +C +C SUBROUTINE SET_VERSION +C +C FUNCTION: Sets version number. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + +C +C Find user entry in BULLUSER.DAT to update information. +C + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.EQ.0) THEN + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY ! Write modified entry + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + CALL CLOSE_FILE (4) + RETURN + + END + + + + + + SUBROUTINE CONFIRM_PRIV(USERNAME,ALLOW) +C +C SUBROUTINE CONFIRM_PRIV +C +C FUNCTION: Confirms that given username has SETPRV. +C +C INPUTS: +C USERNAME - Username +C OUTPUTS: +C ALLOW - Returns 1 if account has SETPRV. +C returns 0 if account has no SETPRV. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + INCLUDE '($PRVDEF)' + + INCLUDE '($UAIDEF)' + + INTEGER DEF_PRIV(2) + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(8,UAI$_DEF_PRIV,%LOC(DEF_PRIV)) + CALL END_ITMLST(GETUAI_ITMLST) + + ALLOW = 0 ! Set return false + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) ! Read Record + IF (IER) THEN ! If username found + IF (BTEST(DEF_PRIV(1),PRV$V_SETPRV).OR. ! SETPRV or CMRKNL + & BTEST(DEF_PRIV(1),PRV$V_CMKRNL)) THEN ! privileges? + ALLOW = 1 ! Yep + END IF + END IF + + RETURN ! Return + END ! End + + + + + + SUBROUTINE CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) +C +C SUBROUTINE CHECK_NEWUSER +C +C FUNCTION: Checks flags for a new: Whether DISMAIL is set, +C and what the last password change was. +C +C INPUTS: +C USERNAME - Username +C OUTPUTS: +C DISMAIL - Returns 1 if account has DISMAIL. +C returns 0 if account has no DISMAIL. +C PASSCHANGE - Date of last password change. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + INTEGER PASSCHANGE(2) + + INCLUDE '($UAIDEF)' + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(8,UAI$_PWD_DATE,%LOC(PASSCHANGE)) + CALL END_ITMLST(GETUAI_ITMLST) + + DISMAIL = 0 ! Set return false + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) ! Read Record + IF (IER) THEN ! If username found + IF (BTEST(FLAGS,UAI$V_NOMAIL)) THEN ! DISMAIL SET? + DISMAIL = 1 ! Yep + END IF + END IF + + RETURN ! Return + END ! End + + + + INTEGER FUNCTION SYS_TRNLNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM = SYS$TRNLNM(,'LNM$FILE_DEV',INPUT(:TRIM(INPUT)),, + & %VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM) OUTPUT = OUTPUT(:OLEN) + + RETURN + END + + + + + INTEGER FUNCTION SYS_TRNLNM_SYSTEM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM_SYSTEM = SYS$TRNLNM(,'LNM$SYSTEM', + & INPUT(:TRIM(INPUT)),,%VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM_SYSTEM) OUTPUT = OUTPUT(:OLEN) + + RETURN + END + + + + INTEGER FUNCTION FILE_LOCK(IER,IER1) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($RMSDEF)' + + DATA INIT /.TRUE./ + + IF (INIT) THEN + FILE_LOCK = 1 + INIT = .FALSE. + ELSE + IF (IER.GT.0) THEN + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.RMS$_FLK) THEN + FILE_LOCK = 1 + CALL WAIT_SEC('01') + ELSE + FILE_LOCK = 0 + INIT = .TRUE. + END IF + ELSE + FILE_LOCK = 0 + IER1 = 0 + INIT = .TRUE. + END IF + END IF + + RETURN + END + + + + SUBROUTINE ENABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + QUIT = 1 + + ENTRY ENABLE_CTRL_EXIT + + QUIT = QUIT.AND.1 ! If called via entry, QUIT = 0 + IF (QUIT.EQ.1) LEVEL = LEVEL - 1 + + IF (LEVEL.LT.0.AND.QUIT.EQ.1) THEN + WRITE (6,'('' ERROR: Error in CTRL.'')') + END IF + + IF (LEVEL.EQ.0.OR.QUIT.EQ.0) THEN + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + END IF + + IF (QUIT.EQ.0) THEN + CALL UPDATE_USERINFO + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL EXIT + END IF + QUIT = 0 ! Reinitialize + + RETURN + END + + + SUBROUTINE DISABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + DATA LEVEL /0/ + + IF (LEVEL.EQ.0) CALL LIB$DISABLE_CTRL(CTRLY,) + LEVEL = LEVEL + 1 + + RETURN + END + + + + + SUBROUTINE CLEANUP_BULLFILE +C +C SUBROUTINE CLEANUP_BULLFILE +C +C FUNCTION: Searches for empty space in bulletin file and deletes it. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER FILENAME*132,BUFFER*128 + + CALL OPEN_BULLDIR_SHARED + +C +C NOTE: Can't use READDIR for reading header since it'll spawn a +C BULL/CLEANUP. (Fooey). +C + + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=HEADER_KEY,IOSTAT=IER) BULLDIR_HEADER + END DO + + IF (NEMPTY.EQ.0) THEN ! No cleanup necessary + CALL CLOSE_BULLDIR + RETURN + ELSE IF (NEMPTY.GT.0) THEN + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,,) + + OPEN (UNIT=11,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + 1 STATUS='UNKNOWN',IOSTAT=IER,DISPOSE='DELETE', + 1 RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',INITIALSIZE=((NBLOCK-NEMPTY)*128)/512) + ! Compressed version is number 1 + + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot open temporary file for'' + & ,'' compressing '',A)') FOLDER(:TRIM(FOLDER)) + CALL ERRSNS(IDUMMY,IER) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL CLOSE_BULLDIR + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + END IF + + CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL', + & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL') + + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + + NBLOCK = 0 + + DO I=1,NBULL ! Copy bulletins to new file + CALL READDIR(I,IER) + ICOUNT = BLOCK + DO J=1,LENGTH + NBLOCK = NBLOCK + 1 + DO WHILE (REC_LOCK(IER1)) + READ(1'ICOUNT,IOSTAT=IER1) BUFFER + END DO + IF (IER1.NE.0) THEN ! This file is corrupt + NBLOCK = NBLOCK - 1 + NBULL = I - 1 + GO TO 100 + END IF + WRITE(11) BUFFER + ICOUNT = ICOUNT + 1 + END DO + END DO + +100 CALL CLOSE_BULLFIL + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + RETURN + END IF + + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+1 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.NE.0) THEN + CLOSE (UNIT=11) + CALL CLOSE_BULLDIR + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + RETURN + END IF + END IF + + CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR', + & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR') + + NEMPTY = 0 + WRITE (12,IOSTAT=IER) BULLDIR_HEADER ! Write directory header + + NBLOCK = 0 ! Update directory entry pointers + DO I=1,NBULL + CALL READDIR(I,IER) + BLOCK = NBLOCK + 1 + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (12,IOSTAT=IER) BULLDIR_ENTRY + NBLOCK = NBLOCK + LENGTH + END DO + + CLOSE (UNIT=12,STATUS='KEEP') + CLOSE (UNIT=11,STATUS='KEEP') + + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + + NEMPTY = -1 ! Copying done, indicate that in case of crash + WRITE (2,IOSTAT=IER) BULLDIR_HEADER ! Write new directory header + + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + + RETURN + END + + + + + SUBROUTINE CLEANUP_DIRFILE(DELETE_ENTRY) +C +C SUBROUTINE CLEANUP_DIRFILE +C +C FUNCTION: Reorder directory file after deletions. +C Is called either directly after a deletion, or is +C called if it is detected that a deletion was not fully +C completed due to the fact that the deleting process +C was abnormally terminated. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + CHARACTER*11 DATE_SAVE,EXDATE_SAVE + CHARACTER*11 TIME_SAVE,EXTIME_SAVE + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + DATE_SAVE = DATE + TIME_SAVE = TIME + EXDATE_SAVE = EXDATE + EXTIME_SAVE = EXTIME + + NBULL = -NBULL ! Negative # Bulls signals deletion in progress + MOVE_TO = 0 ! Moving directory entries starting here + MOVE_FROM = 0 ! Moving directory entries from here + I = DELETE_ENTRY ! Start search point for first deleted entries + DO WHILE (MOVE_TO.EQ.0.AND.I.LE.NBULL) + CALL READDIR(I,IER) + IF (IER.NE.I+1) THEN ! Have we found a deleted entry? + MOVE_TO = I ! If so, start moving entries to here + J=I+1 ! Search for next entry in file + DO WHILE (MOVE_FROM.EQ.0.AND.J.LE.NBULL) + CALL READDIR(J,IER) + IF (IER.EQ.J+1) MOVE_FROM = J + J = J + 1 + END DO + IF (MOVE_FROM.EQ.0) THEN ! There are no more entries + NBULL = I - 1 ! so just update number of bulletins + CALL WRITEDIR(0,IER) + RETURN + END IF + LENGTH = -LENGTH ! Indicate starting point by writing + CALL WRITEDIR(I,IER) ! next entry into deleted entry + FIRST_DELETE = I ! with negative length + MOVE_FROM = MOVE_FROM + 1 ! Set up pointers to move rest of + MOVE_TO = MOVE_TO + 1 ! the entries + ELSE IF (LENGTH.LT.0) THEN ! If negative length found, deletion + FIRST_DELETE = I ! was previously in progress + J = I ! Try to find where entry came from + CALL INIT_QUEUE(ENTRY_Q1,BULLDIR_ENTRY) + ENTRY_Q = ENTRY_Q1 + DO K=J,NBULL + CALL READDIR(K,IER) + IF (IER.EQ.K+1) THEN + CALL WRITE_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + END IF + END DO + ENTRY_QLAST = ENTRY_Q + ENTRY_Q2 = ENTRY_Q1 + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q2.NE.ENTRY_QLAST) + CALL READ_QUEUE(%VAL(ENTRY_Q2),ENTRY_Q,BULLDIR_ENTRY) + ENTRY_Q2 = ENTRY_Q + BLOCK_SAVE = BLOCK + MSG_NUM_SAVE = MSG_NUM + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q.NE.ENTRY_QLAST) + ! Search for duplicate entries + CALL READ_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + IF (BLOCK_SAVE.EQ.BLOCK) THEN + MOVE_TO = MSG_NUM_SAVE + 1 + MOVE_FROM = MSG_NUM + 1 + END IF + END DO + ! If no duplicate entry found for this + ! entry, see if one exists for any + END DO ! of the other entries + END IF + I = I + 1 + END DO + + IF (I.LE.NBULL) THEN ! Move reset of entries if necessary + IF (MOVE_FROM.GT.0) THEN + DO J=MOVE_FROM,NBULL + CALL READDIR(J,IER) + IF (IER.EQ.J+1) THEN ! Skip any other deleted entries + CALL WRITEDIR(MOVE_TO,IER) + MOVE_TO = MOVE_TO + 1 + END IF + END DO + END IF + DO J=MOVE_TO,NBULL ! Delete empty records at end of file + CALL READDIR(J,IER) + DELETE(UNIT=2,IOSTAT=IER) + END DO + NBULL = MOVE_TO - 1 ! Update # bulletin count + END IF + + CALL READDIR(FIRST_DELETE,IER) + IF (IER.EQ.FIRST_DELETE+1.AND.LENGTH.LT.0) THEN + LENGTH = -LENGTH ! Fix entry which has negative length + CALL WRITEDIR(FIRST_DELETE,IER) + END IF + + CALL WRITEDIR(0,IER) + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + DATE = DATE_SAVE + TIME = TIME_SAVE + EXDATE = EXDATE_SAVE + EXTIME = EXTIME_SAVE + + RETURN + END + + + SUBROUTINE SHOW_FLAGS +C +C SUBROUTINE SHOW_FLAGS +C +C FUNCTION: Show user flags. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + +C +C Find user entry in BULLUSER.DAT to obtain flags. +C + + CALL OPEN_BULLUSER_SHARED ! Open user file + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + WRITE (6,'('' For the selected folder '',A)') FOLDER(1:TRIM(FOLDER)) + + IF (TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' NOTIFY is set.'')') + END IF + + IF (TEST2(SET_FLAG,FOLDER_NUMBER).AND. + & (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER))) THEN + WRITE (6,'('' READNEW is set.'')') + ELSE IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' BRIEF is set.'')') + ELSE IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' SHOWNEW is set.'')') + ELSE IF (.NOT.TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' No flags are set.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(2) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBSET(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + SUBROUTINE CLR2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBCLR(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + LOGICAL FUNCTION TEST2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + TEST2 = BTEST(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + + INTEGER FUNCTION GETUSERS(USERNAME,TERMINAL) +C +C FUNCTION GETUSERS +C +C FUNCTION: +C To get names of all users that are logged in. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CHARACTER USERNAME*(*),TERMINAL*(*) + + DATA WILDCARD /-1/ + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL ADD_2_ITMLST(LEN(TERMINAL),JPI$_TERMINAL,%LOC(TERMINAL)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = 1 + TERMINAL(1:1) = CHAR(0) + DO WHILE (IER.AND.TERMINAL(1:1).EQ.CHAR(0)) + ! Get next interactive process + IER = SYS$GETJPIW(,WILDCARD,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + + IF (.NOT.IER) WILDCARD = -1 + + GETUSERS = IER + + RETURN + END + + + + + + SUBROUTINE OPEN_USERINFO +C +C SUBROUTINE OPEN_USERINFO +C +C FUNCTION: Opens the file in SYS$LOGIN which contains user information. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /USERINFO/ USERINFO_READ,OLD_LAST_READ_BTIM(2,0:FOLDER_MAX-1) + DATA USERINFO_READ /.FALSE./ + + INTEGER TODAY_BTIM(2) + + CALL OPEN_BULLINF_SHARED + + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + + IF (IER.EQ.0) THEN ! Check to see if dates all in future + CALL SYS_BINTIM('-',TODAY_BTIM) ! Get today's date + DO I=1,FOLDER_MAX + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,I),TODAY_BTIM) + IF (DIFF.GE.0) THEN ! Must have been in a time wrap + LAST_READ_BTIM(1,I) = TODAY_BTIM(1) + LAST_READ_BTIM(2,I) = TODAY_BTIM(2) + END IF + END DO + END IF + + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2 ! Is this BULLCP process? + & .AND.CONFIRM_USER(USERNAME).NE.0) THEN ! Not real user? + USERNAME = 'DECNET' + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + + IF (IER.NE.0) THEN + OPEN (UNIT=10,FILE='SYS$LOGIN:BULLETIN.INF',STATUS='OLD', + & RECORDTYPE='FIXED',FORM='UNFORMATTED',IOSTAT=IER) + INQUIRE(UNIT=10,RECORDSIZE=INF_SIZE) + IF (IER.EQ.0) THEN + READ (10) + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,INF_SIZE/2) + CLOSE (UNIT=10,STATUS='DELETE') + ELSE + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Find user's info + CALL CLOSE_BULLUSER + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2) THEN ! BULLCP process? + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's date + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) + CALL READ_USER_FILE_HEADER(IER) + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + END IF + IF (IER.EQ.0) THEN + DO I=1,FOLDER_MAX + LAST_READ_BTIM(1,I) = READ_BTIM(1) + LAST_READ_BTIM(2,I) = READ_BTIM(2) + END DO + END IF + END IF + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + + CALL CLOSE_BULLINF + + CALL LIB$MOVC3(FOLDER_MAX*2*4,LAST_READ_BTIM,OLD_LAST_READ_BTIM) + + USERINFO_READ = .TRUE. + + RETURN + END + + + + SUBROUTINE UPDATE_USERINFO +C +C SUBROUTINE UPDATE_USERINFO +C +C FUNCTION: Updates the latest message read times for each folder. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /USERINFO/ USERINFO_READ,OLD_LAST_READ_BTIM(2,0:FOLDER_MAX-1) + + IF (.NOT.USERINFO_READ) RETURN + + DIFF = .FALSE. + FNUM = 0 + + DO WHILE (.NOT.DIFF.AND.FNUM.LT.FOLDER_MAX) + DIFF = LAST_READ_BTIM(1,FNUM).NE.OLD_LAST_READ_BTIM(1,FNUM) + IF (.NOT.DIFF) THEN + DIFF = LAST_READ_BTIM(2,FNUM).NE.OLD_LAST_READ_BTIM(2,FNUM) + END IF + FNUM = FNUM + 1 + END DO + + IF (.NOT.DIFF) RETURN + + CALL OPEN_BULLINF_SHARED + + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) REWRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + + CALL CLOSE_BULLINF + + RETURN + END + + + INTEGER FUNCTION SYS_BINTIM(TIME,BTIM) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*(*) TIME + + IF (TRIM(TIME).EQ.20) THEN + SYS_BINTIM = SYS$BINTIM(TIME//'.00',BTIM) + ELSE + SYS_BINTIM = SYS$BINTIM(TIME,BTIM) + END IF + + RETURN + END + + + + + SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C FUNCTION: +C +C Update user's last read bulletin date. If new bulletins have been +C added since the last time bulletins have been read, position bulletin +C pointer so that next bulletin read is the first new bulletin, and +C alert user. If READNEW set and no new bulletins, just exit. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /POINT/ BULL_POINT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM + + COMMON /LOGIN_BTIM/ LOGIN_BTIM_SAVE(2) + + IF (.NOT.LOGIN_SWITCH) THEN + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + CALL UPDATE_READ(0) ! Update login time + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL SELECT_FOLDER(.TRUE.,IER) + IF (IER) RETURN + END IF + CALL READ_IN_FOLDERS ! Read folder info + ELSE + LOGIN_SWITCH = .FALSE. ! So LOGIN_FOLDER entry doesn't + END IF ! think it's called via LOGIN + + FOLDER_Q = SAVE_FOLDER_Q1 + + DO FOLDER_NUMBER = 0,SAVE_FOLDER_NUM-1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + CALL CLR2(NEW_MSG,FOLDER_NUMBER) ! Clear new message flag + IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL SET2(NEW_MSG,FOLDER_NUMBER) + ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & (FOLDER_NUMBER.GT.0.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND.READIT.EQ.1)) THEN + IF (READIT.EQ.1.AND.SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM, + & F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.READIT.EQ.1) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.DIFF.GE.0) THEN + IER = MINUTE_DIFF(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + IF (IER.LE.15) DIFF = -1 + END IF + END IF + END IF + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN ! If new unread messages + CALL SET2(NEW_MSG,FOLDER_NUMBER) ! Set new message flag + END IF + END IF + END DO + + FOLDER_Q = SAVE_FOLDER_Q1 + + IF (READIT.EQ.0) THEN ! If not in READNEW mode + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + NEW_MESS = .FALSE. + DO FOLDER_NUMBER = 1,SAVE_FOLDER_NUM-1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN ! Are there unread messages? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_NOSYS_BTIM) + IF (DIFF.GT.0) THEN ! Unread non-system messages? + DIFF = COMPARE_BTIM(LOGIN_BTIM,F_NEWEST_BTIM) + ! No. Unread system messages? + IF (DIFF.GT.0) THEN ! No, update last read time. + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(2) + END IF + END IF + IF (DIFF.LT.0) THEN + WRITE (6,'('' There are new messages in '', + & ''folder '',A,''.'',$)') FOLDER(1:TRIM(FOLDER)) + NEW_MESS = .TRUE. + END IF + END IF + END IF + END DO + IF (NEW_MESS) THEN + WRITE (6,'('' Type SELECT followed by foldername to'', + & '' read above messages.'')') + END IF + SAVE_FOLDER_Q1 = 0 + FOLDER_NUMBER = 0 + CALL SELECT_FOLDER(.FALSE.,IER) + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN + CALL FIND_NEWEST_BULL ! See if there are new messages + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new GENERAL messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + END IF + ELSE ! READNEW mode. + DO FOLDER_NUMBER = 0,SAVE_FOLDER_NUM-1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + CALL SELECT_FOLDER(.FALSE.,IER) + IF (IER) THEN + IF (SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + END IF + IF (DIFF.LT.0) THEN + IF (FOLDER_NUMBER.GT.0) CALL LOGIN_FOLDER + IF (BULL_POINT.NE.-1) THEN + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + IF (FOLDER_NUMBER.GT.0) THEN + WRITE (6,'('' There are new messages in folder '', + & A,''.'')') FOLDER(1:TRIM(FOLDER)) + END IF + ELSE IF (FOLDER_NUMBER.EQ.0.OR. + & .NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + SAVE_BULL_POINT = BULL_POINT + REDO = .TRUE. + DO WHILE (REDO) + REDO = .FALSE. + CALL READNEW(REDO) + IF (REDO) CALL REDISPLAY_DIRECTORY + BULL_POINT = SAVE_BULL_POINT + END DO + END IF + END IF + END IF + END IF + END IF + END DO + CALL EXIT + END IF + + RETURN + END + + + + + SUBROUTINE READ_IN_FOLDERS + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM + DATA SAVE_FOLDER_Q1/0/,SAVE_FOLDER_NUM/0/ + + COMMON /READIT/ READIT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL INIT_QUEUE(SAVE_FOLDER_Q1,FOLDER_COM) + FOLDER_Q = SAVE_FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Go find folders + + FOLDER_NUMBER = 0 + CALL READ_FOLDER_FILE_KEYNUM(FOLDER_NUMBER,IER) + DO WHILE (IER.EQ.0) + IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ELSE IF ((NEW_FLAG(1).LT.142.OR.NEW_FLAG(1).GT.143).AND. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + CALL CHANGE_FLAG_NOCMD(0,3) + CALL SET_VERSION + ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & (FOLDER_NUMBER.GT.0.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND.READIT.EQ.1)) THEN +C +C Unknown problem caused system folder flag in folder file to disappear +C so this tests to see if the flag has disappeared and resets if needed. +C + IF (TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND. + & .NOT.BTEST(FOLDER_FLAG,2).AND.IER.EQ.0) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + CALL REWRITE_FOLDER_FILE + END IF + IF (IER.NE.0) THEN + CALL CHANGE_FLAG_NOCMD(0,2) + CALL CHANGE_FLAG_NOCMD(0,3) + CALL CHANGE_FLAG_NOCMD(0,4) + IF (TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + FOLDER_FLAG = 0 + CALL MODIFY_SYSTEM_LIST(0) + END IF + END IF + END IF + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + FOLDER_NUMBER = FOLDER_NUMBER + 1 + CALL READ_FOLDER_FILE_KEYNUM(FOLDER_NUMBER,IER) + END DO + + CALL CLOSE_BULLFOLDER + + SAVE_FOLDER_NUM = FOLDER_NUMBER + + FOLDER_Q = SAVE_FOLDER_Q1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + RETURN + END + + + + + SUBROUTINE DISCONNECT_REMOTE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + WRITE (6,'('' ERROR: Connection to remote folder disconnected.'')') + + FOLDER_NUMBER = -1 + FOLDER1 = 'GENERAL' + + CALL SELECT_FOLDER(.FALSE.,IER) + + WRITE (6,'('' Resetting to GENERAL folder.'')') + + RETURN + END diff --git a/decus/vax90a/bulletin/bulletin8.for b/decus/vax90a/bulletin/bulletin8.for new file mode 100644 index 0000000..64a3bb0 --- /dev/null +++ b/decus/vax90a/bulletin/bulletin8.for @@ -0,0 +1,1567 @@ +C +C BULLETIN8.FOR, Version 3/22/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE START_DECNET + + IMPLICIT INTEGER (A - Z) + + CHARACTER NAMEDESC*9 /'BULLETIN1'/ + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for + INTEGER*2 MBX_IOSB ! terminal QIO calls. + LOGICAL*1 MBX_BUF + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + DIMENSION NFBDESC(2) + LOGICAL*1 NFB(5) + + EXTERNAL IO$_ACPCONTROL + + PARAMETER NFB$C_DECLNAME = '15'X + + IF (CONFIRM_USER('DECNET').EQ.0) THEN + CALL SETDEFAULT('DECNET') + END IF + +C CALL SET_TIMER('02') + + IER = SYS$CREMBX(%VAL(0),MBX_CHAN,%VAL(132),%VAL(528),,, + & 'BULL_MBX') + IF (.NOT.IER) CALL EXIT(IER) + + IER = SYS$ASSIGN('_NET:',DCL_CHAN,,'BULL_MBX') ! Assign net device + IF (.NOT.IER) CALL EXIT(IER) + + NFBDESC(1) = 5 + NFBDESC(2) = %LOC(NFB) + + NFB(1) = NFB$C_DECLNAME + + IER = SYS$QIOW(,%VAL(DCL_CHAN),IO$_ACPCONTROL,,,, + & NFBDESC,NAMEDESC,,,,) + IF (.NOT.IER) CALL EXIT(IER) + + DO I=1,MAXLINK + CALL LIB$GET_EF(READ_EFS(I)) + CALL LIB$GET_EF(WRITE_EFS(I)) + END DO + + CALL READ_MBX + + RETURN + END + + + SUBROUTINE SETDEFAULT(USERNAME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LNMDEF)' + + INCLUDE '($PSLDEF)' + + INCLUDE '($UAIDEF)' + + CHARACTER DEFDIR*64,DEFDEV*16,USERNAME*(*),ACCOUNT*9 + 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 + + IMPLICIT INTEGER (A-Z) + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + 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) + + IER = SYS$QIO(%VAL(MBX_EF),%VAL(MBX_CHAN),IO$_READVBLK,MBX_IOSB, + & MBX_AST,,MBX_BUF,%VAL(132),,,,) + IF (.NOT.IER) CALL EXIT(IER) + + RETURN + + END + + + + + SUBROUTINE MBX_AST + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($MSGDEF)' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + 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*6,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 CONNECT(NODENAME,USERNAME,FROMNAME) + ELSE IF ((MBXMSG.EQ.MSG$_INTMSG.OR.MBXMSG.EQ.MSG$_REJECT.OR. + & MBXMSG.EQ.MSG$_CONFIRM).AND.MBX_IOSB(1)) THEN + CALL READ_MBX + 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 + END IF + + RETURN + END + + + + + SUBROUTINE READ_CHAN(CHAN,UNIT_INDEX) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + EXTERNAL READ_AST + + EXTERNAL IO$_READVBLK + + IER = SYS$QIO(%VAL(READ_EFS(UNIT_INDEX)),%VAL(CHAN),IO$_READVBLK, + & READ_IOSB(1,UNIT_INDEX),READ_AST, + & %VAL(UNIT_INDEX),READ_BUF(1,UNIT_INDEX),%VAL(200),,,,) + + RETURN + + END + + + + + SUBROUTINE WRITE_CHAN(NUM,OUTPUT,UNIT_INDEX,IER) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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)) + + IER = SYS$QIO(%VAL(WRITE_EFS(UNIT_INDEX)), + & %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 WRITE_AST(ASTPRM) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) + COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,FROM_SAVE*12,NODE_SAVE*12 + + CHARACTER*128 INPUT + + 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) + END IF + + RETURN + END + + + + SUBROUTINE READ_AST(ASTPRM) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) + + UNIT_INDEX = %LOC(ASTPRM) + + IF (.NOT.READ_IOSB(1,UNIT_INDEX)) RETURN + + IO(UNIT_INDEX) = IO(UNIT_INDEX) + 1 + + CALL EXECUTE_COMMAND(UNIT_INDEX) + + CALL READ_CHAN(DEVS(UNIT_INDEX),UNIT_INDEX) + + RETURN + END + + + + + + SUBROUTINE CONNECT(NODENAME,USERNAME,FROMNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /ANY_ACTIVITY/ CONNECT_COUNT + DATA CONNECT_COUNT /0/ + + CHARACTER*(*) USERNAME,FROMNAME + + EXTERNAL IO$_ACCESS,IO$M_ABORT + + CONNECT_COUNT = CONNECT_COUNT + 1 + + IO_REJECT = %LOC(IO$_ACCESS)+%LOC(IO$M_ABORT) + + CALL CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, + & NODENAME,USERNAME,FROMNAME) + + IF (REJECT.NE.IO_REJECT) THEN + CALL READ_CHAN(CHAN,UNIT_INDEX) + END IF + + CALL READ_MBX + + RETURN + END + + + SUBROUTINE CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, + & NODENAME,USERNAME,FROMNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for + INTEGER*2 MBX_IOSB ! terminal QIO calls. + LOGICAL*1 MBX_BUF + + PARAMETER MAXLINK = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,FROM_SAVE*12,NODE_SAVE*12 + + 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 + ELSE + IER = SYS$ASSIGN('_NET:',DEV_CHAN,,'BULL_MBX') + + 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).GT.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 + 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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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 + + IF (UNITS(UNIT_INDEX).EQ.0) RETURN + + CALL SYS$DASSGN(%VAL(DEVS(UNIT_INDEX))) + + CALL UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + COUNT = COUNT - 1 + DEVS(UNIT_INDEX) = 0 + UNITS(UNIT_INDEX) = 0 + + 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 TIMBUF*13,MIN*2 + DATA TIMBUF/'0 00:00:00.00'/ + + EXTERNAL CHECK_CONNECTIONS + + CALL LIB$GET_EF(WAITEFN) + + TIMBUF(6:7) = MIN + + IER=SYS$BINTIM(TIMBUF,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 = 10 + + COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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) + + 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 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(200,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,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 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + DIMENSION SCRATCH(MAXLINK),OUT_HEAD(MAXLINK) + DATA SCRATCH/MAXLINK*0/,OUT_HEAD/MAXLINK*0/ + + EXTERNAL ENABLE_CTRL_EXIT,SS$_NOSUCHNODE,SS$_NOSUCHOBJ + + PARAMETER TIMEOUT = -10*1000*1000*30 + DIMENSION TIMEBUF(2) + DATA TIMEBUF /TIMEOUT,-1/, TIMEEFN/0/ + + CHARACTER BUFFER*(FOLDER_RECORD+16),DESCRIP_TEMP*53 + CHARACTER NODENAME*6,BULLCP_USER*12,INQUEUE*128 + + EQUIVALENCE (BUFFER,CMD_TYPE),(BUFFER,INQUEUE) + + INTEGER BULLCP_PRIV(2) + + BULLCP_PRIV(1) = PROCPRIV(1) + BULLCP_PRIV(2) = PROCPRIV(2) + + ILEN = READ_IOSB(2,UNIT_INDEX) + CALL LIB$MOVC3(ILEN,READ_BUF(1,UNIT_INDEX),%REF(BUFFER)) + + REC_SAVE(UNIT_INDEX) = 0 + USERNAME = USER_SAVE(UNIT_INDEX) + FOLDER = FOLDER_NAME(UNIT_INDEX) + FOLDER_NUMBER = FOLDER_NUM(UNIT_INDEX) + NODENAME = NODE_SAVE(UNIT_INDEX) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,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) THEN ! Do we need priv info? + IF (PROCPRIV(1).EQ.0.AND.PROCPRIV(2).EQ.0) THEN + CALL GET_USER_PRIV(USERNAME,PRIV_SAVE(1,UNIT_INDEX)) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,UNIT_INDEX) + IF ( (PROCPRIV(1).AND.NEEDPRIV(1)).EQ.0.AND. + & (PROCPRIV(2).AND.NEEDPRIV(2)).EQ.0) THEN + CALL CHECK_BULLETIN_PRIV(USERNAME) + PRIV_SAVE(1,UNIT_INDEX) = PROCPRIV(1) + PRIV_SAVE(2,UNIT_INDEX) = PROCPRIV(2) + END IF + END IF + END IF + + IF (CMD_TYPE.EQ.1) THEN ! Select folder + FOLDER1 = BUFFER(5:ILEN) + FOLDER_NUMBER = -2 + CALL SELECT_FOLDER(.FALSE.,IER) + CALL LIB$MOVC3(4,IER,%REF(BUFFER(1:1))) + CALL LIB$MOVC3(4,READ_ONLY,%REF(BUFFER(5: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13:13))) + ELSE + CALL LIB$MOVC3(8,LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & %REF(BUFFER(9: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13:13))) + END IF + BUFFER = BUFFER(:16)//FOLDER_COM + CALL WRITE_CHAN(16+LEN(FOLDER_COM),BUFFER,UNIT_INDEX,IER1) + IF (IER.AND.IER1) THEN + FOLDER_NAME(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(53,%REF(BUFFER(5:5)),%REF(DESCRIP)) + CALL LIB$MOVC3(11,%REF(BUFFER(58:58)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(69:69)),%REF(EXTIME)) + CALL LIB$MOVC3(4,%REF(BUFFER(80:80)),SYSTEM) + 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.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.NE.0.AND..NOT.SETPRV_PRIV()) THEN ! Priv test + IF (FOLDER_OWNER.NE.USERNAME) THEN + SYSTEM = 0 + ELSE ! Allow permanent if + SYSTEM = SYSTEM.AND.2 ! owner of folder + END IF + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + 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(84:84)),BROAD) + IF (BROAD.AND..NOT.SETPRV_PRIV().AND..NOT.OPER_PRIV()) THEN + BROAD = 0 + END IF + CALL LIB$MOVC3(4,%REF(BUFFER(88:88)),BELL) + CALL LIB$MOVC3(4,%REF(BUFFER(92:92)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(97:97)),CLUSTER) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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 + 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 (1) + 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:).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 + IER = SYS$SETIMR(%VAL(TIMEEFN),TIMEBUF,ENABLE_CTRL_EXIT, + & %VAL(1)) + 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 + IER = SYS$CANTIM(%VAL(1),) + END DO + ELSE IF (CMD_TYPE.EQ.8) THEN ! Read directory entry + CALL LIB$MOVC3(4,%REF(BUFFER(5:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + IF (ICOUNT.GE.0) THEN + CALL READDIR(ICOUNT,IER) + ELSE + CALL LIB$MOVC3(8,%REF(BUFFER(9:9)),%REF(MSG_KEY(1:1))) + CALL READDIR_KEYGE(IER) + END IF + CALL CLOSE_BULLDIR + CALL LIB$MOVC3(4,IER,%REF(BUFFER(1: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:5)),SBULL) + CALL LIB$MOVC3(4,%REF(BUFFER(9:9)),EBULL) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),BULL_DELETE) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR + CALL LIB$MOVC3(53,%REF(BUFFER(5:5)),%REF(DESCRIP_TEMP)) + CALL LIB$MOVC3(4,%REF(BUFFER(58:58)),ICOUNT) + 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(53,%REF(BUFFER(62:62)),%REF(DESCRIP)) + CALL LIB$MOVC3(4,%REF(BUFFER(115:115)),%REF(MSGTYPE)) + CALL LIB$MOVC3(11,%REF(BUFFER(119:119)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(130:130)),%REF(EXTIME)) + 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:5)),BULL_DELETE) + DESCRIP_TEMP = BUFFER(9:61) + 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(11,%REF(BUFFER(62:62)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(73:73)),%REF(EXTIME)) + 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 + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) + CALL GET_NEWEST_MSG(%REF(BUFFER(5: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: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:5)),BLENGTH) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:13)), + & %VAL(SCRATCH(UNIT_INDEX)+START-1)) + ELSE + CALL LIB$MOVC3(BLENGTH,%VAL(SCRATCH(UNIT_INDEX)), + & %REF(BMESSAGE(1:1))) + CALL LIB$MOVC3(4,%REF(BUFFER(13:13)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(17:17)),CLUSTER) + CALL LIB$FREE_VM(BRDCST_LIMIT,SCRATCH(UNIT_INDEX)) + IF (ILEN.GT.20) THEN + CALL LIB$MOVC3(4,%REF(BUFFER(21:21)),FOLDER_NUMBER) + FOLDER = BUFFER(25:) + GO TO 100 + ELSE IF (SETPRV_PRIV().OR.OPER_PRIV()) THEN + CALL BROADCAST(ALL,CLUSTER) + END IF + END IF + END IF + +1000 PROCPRIV(1) = BULLCP_PRIV(1) + PROCPRIV(2) = BULLCP_PRIV(2) + + RETURN + END + + + + SUBROUTINE UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) + COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDER_NAME(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) + CHARACTER USER_SAVE*12,FOLDER_NAME*25,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.GE.0) RETURN + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = LAST_SAVE(1,UNIT_INDEX) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = LAST_SAVE(2,UNIT_INDEX) + 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 + + END + + + + + SUBROUTINE CHECK_BULLETIN_PRIV(USERNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + INCLUDE 'BULLFILES.INC' + + 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) THEN + PROCPRIV(1) = NEEDPRIV(1) + PROCPRIV(2) = NEEDPRIV(2) + END IF + 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 + REC_LOCK = 1 + 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) + + CHARACTER*80 MESSAGE + + 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 + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER LOCAL_NODE*32,NODE_TEMP*256 + + 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)) + IF (INDEX(NODES(NODE_NUM),'::').GT.0) THEN ! Remove :: if + NLEN = INDEX(NODES(NODE_NUM),'::') - 1 ! addedd + END IF + IF (LOCAL_NODE(1:L_NODE).EQ.NODES(NODE_NUM)(1:NLEN)) THEN + NODE_NUM = NODE_NUM - 1 + LOCAL_NODE_FOUND = .TRUE. + ELSE + POINT_NODE = NODE_NUM + OPEN (UNIT=9+NODE_NUM,NAME=NODES(NODE_NUM)(1: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 diff --git a/decus/vax90a/bulletin/bulletin9.for b/decus/vax90a/bulletin/bulletin9.for new file mode 100644 index 0000000..b4ae874 --- /dev/null +++ b/decus/vax90a/bulletin/bulletin9.for @@ -0,0 +1,1860 @@ +C +C BULLETIN9.FOR, Version 2/6/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE DELETE_NODE +C +C SUBROUTINE DELETE_NODE +C +C FUNCTION: Deletes files sent via ADD/NODES at remote hosts. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER PASSWORD*31,INLINE*80,DEFAULT_USER*12 + + CALL GET_NODE_INFO + + IF (NODE_ERROR) GO TO 940 + + IF (NODE_NUM.EQ.0.OR.LOCAL_NODE_FOUND) THEN + WRITE (6,'('' ERROR: Cannot specify local node.'')') + GO TO 999 + END IF + + IER = CLI$GET_VALUE('USERNAME',DEFAULT_USER) + IF (.NOT.IER) DEFAULT_USER = USERNAME + IER = CLI$GET_VALUE('SUBJECT',DESCRIP) + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + SEMI = INDEX(NODES(POINT_NODE),'::') ! Look for semicolon after node + NLEN = TRIM(NODES(POINT_NODE)) ! Length of node name + IF (SEMI.GT.0) THEN ! Is semicolon present? + IF (NLEN.GT.SEMI+1) THEN ! Yes, is username after node? + TEMP_USER = NODES(POINT_NODE)(SEMI+2:) ! Yes, set username + NLEN = SEMI - 1 ! Remove semicolon + ELSE ! No username after nodename + TEMP_USER = DEFAULT_USER ! Set username to default + NLEN = SEMI - 1 ! Remove semicolon + SEMI = 0 ! Indicate no username + END IF + ELSE ! No semicolon present + TEMP_USER = DEFAULT_USER ! Set username to default + END IF + INLINE = 'DELETE/SUBJECT="'//DESCRIP(:TRIM(DESCRIP))// + & '"/USERNAME='//TEMP_USER(:TRIM(TEMP_USER)) + IF (CLI$PRESENT('USERNAME').OR.SEMI.GT.0) THEN ! If username was + IER = 1 ! specified, prompt for password + DO WHILE (IER.NE.0) + WRITE(6,'('' Enter password for node '',2A)') + & NODES(POINT_NODE),CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) GO TO 910 + OPEN (UNIT=10+NODE_NUM,NAME=NODES(POINT_NODE)(:NLEN) + & //'"'//TEMP_USER(1:TRIM(TEMP_USER))//' '// + & PASSWORD(1:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10+NODE_NUM) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + END IF + END DO + END IF + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INLINE + IF (INLINE.EQ.'END') THEN + WRITE (6,'('' Message successfully deleted from node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while deleting message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INLINE + END IF + END DO + + GO TO 999 + +910 WRITE (6,1010) + GO TO 999 + +940 WRITE (6,1015) NODES(POINT_NODE) + +999 DO WHILE (NODE_NUM.GT.0) + CLOSE(UNIT=9+NODE_NUM) + NODE_NUM = NODE_NUM - 1 + END DO + + RETURN + +1010 FORMAT (' ERROR: Deletion aborted.') +1015 FORMAT (' ERROR: Unable to reach node ',A) + + END + + + + + SUBROUTINE SET_FOLDER_FLAG(SETTING,FLAG,FLAGNAME) +C +C SUBROUTINE SET_FOLDER_FLAG +C +C FUNCTION: Sets or clears specified flag for folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*(*) FLAGNAME + + IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (SETTING) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,FLAG) + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,FLAG) + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + WRITE (6,'(1X,A,'' has been modified for folder.'')') + & FLAGNAME + ELSE + WRITE (6,'(1X,'' You are not authorized to modify '',A)') + & FLAGNAME//'.' + END IF + + RETURN + END + + + + + SUBROUTINE SET_FOLDER_EXPIRE_LIMIT(LIMIT) +C +C SUBROUTINE SET_FOLDER_EXPIRE_LIMIT +C +C FUNCTION: Sets folder expiration limit. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (LIMIT.LT.0) THEN + WRITE (6,'('' ERROR: Invalid expiration length specified.'')') + ELSE IF (FOLDER_OWNER.EQ.USERNAME.OR.SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + F_EXPIRE_LIMIT = LIMIT + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + WRITE (6,'('' Folder expiration date modified.'')') + ELSE + WRITE (6,'('' You are not allowed to modify folder.'')') + END IF + + RETURN + END + + + + + + SUBROUTINE MERGE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + ENTRY INITIALIZE_MERGE(IER1) + + DO WHILE (FILE_LOCK(IER1,IER2)) + OPEN (UNIT=13,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER1.NE.0) RETURN + + NBULL = 0 + + WRITE(13,IOSTAT=IER1) BULLDIR_HEADER + CALL CONVERT_HEADER_FROMBIN + + TO_POINTER = 1 + + RETURN + + ENTRY ADD_MERGE_TO(IER1) + + IER1 = 0 + + DO WHILE (IER1.EQ.0) + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + + CALL READDIR(TO_POINTER,IER) + + DIFF = COMPARE_BTIM(%REF(BULLDIR_ENTRY_SAVE),MSG_BTIM) + IF (DIFF.LT.0.OR.TO_POINTER+1.NE.IER) THEN + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + CALL CONVERT_ENTRY_FROMBIN + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + END DO + + CLOSE (UNIT=13) + + RETURN + + ENTRY ADD_MERGE_FROM(IER1) + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + BLOCK = NBLOCK - LENGTH + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + RETURN + + ENTRY ADD_MERGE_REST(IER1) + + CALL UPDATE_LOGIN(.TRUE.) + + DO WHILE (IER1.EQ.0) + + CALL READDIR(TO_POINTER,IER) + IF (TO_POINTER+1.NE.IER) THEN + READ (13,KEYID=0,KEY=0,IOSTAT=IER1) + CALL CONVERT_HEADER_TOBIN + REWRITE(13,IOSTAT=IER1) BULLDIR_HEADER + IF (IER1.EQ.0) THEN + CLOSE (UNIT=13,DISPOSE='KEEP') + CALL LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.TMPDIR',FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR') + ELSE + CLOSE (UNIT=13) + END IF + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + END DO + + CLOSE (UNIT=13) + + RETURN + END + + + + + SUBROUTINE SET_NOKEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + INCLUDE '($SMGDEF)' + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'SET KEYPAD',) + + RETURN + END + + + + + + SUBROUTINE SET_KEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + INCLUDE '($SMGDEF)' + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF1',,,,'GOLD') + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'HELP',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2','GOLD',TERM,'SET NOKEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3',,,'EXTRACT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3','GOLD',,'FILE ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4',,TERM,'SHOW KEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4','GOLD',TERM, + & 'SHOW KEYPAD/PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0',,TERM, + & 'SHOW FOLDER/FULL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0','GOLD',TERM,'SHOW FLAGS',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1',,TERM,'BACK',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1','GOLD',TERM,'NEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2',,TERM,'PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2','GOLD',TERM,'PRINT/NONOTIFY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3',,TERM,'DIR',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3','GOLD',TERM,'DIR/FOLDER',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4',,TERM,'CURRENT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4','GOLD',TERM,'CURRENT/EDIT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5',,TERM,'RESPOND',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5','GOLD',TERM,'RESP/EDIT/TEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP6',,TERM,'LAST',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7',,TERM,'ADD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7','GOLD',TERM,'ADD/EDIT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8',,TERM,'REPLY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8','GOLD',TERM,'REPL/EDIT/TEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9',,TERM,'MAIL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9','GOLD',TERM,'MAIL/NOHEAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS',,TERM,'READ/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS','GOLD',TERM,'SHOW NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA',,TERM,'DIR/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA','GOLD',TERM,'INDEX',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD',,TERM,'DELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD','GOLD',TERM,'UNDELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'ENTER','GOLD',,'SELECT ',) + + RETURN + END + + + + SUBROUTINE SHOW_KEYPAD(LIBRARY) + + IMPLICIT INTEGER (A-Z) + EXTERNAL LIB$PUT_OUTPUT,PRINT_OUTPUT + CHARACTER*(*) LIBRARY + + INCLUDE '($HLPDEF)' + + IF (CLI$PRESENT('PRINT')) THEN + OPEN (UNIT=8,STATUS='NEW',FILE='SYS$LOGIN:KEYPAD.DAT', + & IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR WHILE OPENING FILE TO PRINTER.'')') + ELSE + CALL LBR$OUTPUT_HELP(PRINT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + CLOSE (UNIT=8,DISP='PRINT/DELETE') + END IF + ELSE + CALL LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + END IF + + RETURN + END + + INTEGER FUNCTION PRINT_OUTPUT(INPUT) + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) INPUT + WRITE (8,'(1X,A)',IOSTAT=IER) INPUT(:TRIM(INPUT)) + IF (IER.EQ.0) PRINT_OUTPUT = 1 + RETURN + END + + + + SUBROUTINE OUTPUT_HELP(PARAMETER,LIBRARY) +C +C SUBROUTINE OUTPUT_HELP +C +C FUNCTION: +C To create interactive help session. Prompting is enabled. +C INPUTS: +C PARAMETER - Character string. Optional input parameter +C containing a list of help keys. +C LIBRARY - Character string. Name of help library. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LBRDEF)' + + COMMON /HELP/ HELP_PAGE,DISPLAY_ID,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID + CHARACTER*80 HELP_INPUT + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + + EXTERNAL PUT_OUTPUT + + CHARACTER*(*) LIBRARY,PARAMETER + + CHARACTER*80 PROMPT + + DATA DISPLAY_ID/0/,KEYBOARD_ID/0/ + + IER = SMG$CREATE_PASTEBOARD(PASTEBOARD_ID) ! Initialize terminal + IF (DISPLAY_ID.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_DISPLAY(PAGE_LENGTH, + & PAGE_WIDTH,DISPLAY_ID) + END IF + IER = SMG$PASTE_VIRTUAL_DISPLAY(DISPLAY_ID,PASTEBOARD_ID,1,1) + + IF (KEYBOARD_ID.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + END IF + + CALL STR$TRIM(HELP_INPUT,PARAMETER,HELP_INPUT_LEN) ! Trim input + + CALL LBR$INI_CONTROL(LINDEX,LBR$C_READ) ! Init library read + CALL LBR$OPEN(LINDEX,LIBRARY) ! Specify library name + + DO I=1,10 ! Initialize key lengths + KEYL(I) = 0 + END DO + + NKEY = 0 ! Number of help keys + + DO WHILE (1) ! Do until CTRL-Z entered or no more keys + + HELP_PAGE = 0 ! Init line counter + NEED_ERASE = .TRUE. ! Need to erase screen + + OLD_NKEY = NKEY ! Save old key count + EXACT = .TRUE. ! Exact key match + + DO WHILE (NKEY.LT.10.AND.HELP_INPUT_LEN.GT.0.AND. + & HELP_INPUT(:1).NE.'?') + ! Break input into keys + NKEY = NKEY + 1 ! Increment key counter + + DO WHILE (HELP_INPUT(1:1).EQ.' '.AND.HELP_INPUT_LEN.GT.0) + HELP_INPUT = HELP_INPUT(2:HELP_INPUT_LEN) ! Strip spaces + HELP_INPUT_LEN = HELP_INPUT_LEN - 1 ! at start of input + END DO + + NEXT_KEY = 2 + + DO WHILE (NEXT_KEY.LE.HELP_INPUT_LEN ! Search for + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.' ' ! space or + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.'/') ! backslash + NEXT_KEY = NEXT_KEY + 1 ! indicating start of next key + END DO + + IF (NEXT_KEY.GT.HELP_INPUT_LEN) THEN ! Found the last key + KEY(NKEY) = HELP_INPUT(:HELP_INPUT_LEN) ! Key string + KEYL(NKEY) = HELP_INPUT_LEN ! Key length + HELP_INPUT_LEN = 0 + ELSE ! Found the next key + KEY(NKEY) = HELP_INPUT(:NEXT_KEY-1) + HELP_INPUT = HELP_INPUT(NEXT_KEY:HELP_INPUT_LEN) + KEYL(NKEY) = NEXT_KEY - 1 + HELP_INPUT_LEN = HELP_INPUT_LEN - NEXT_KEY + 1 + END IF + END DO + HELP_INPUT_LEN = 0 + IER = LBR$GET_HELP(LINDEX,,PUT_OUTPUT,, ! Display help + & KEY(1)(:KEYL(1)),KEY(2)(:KEYL(2)), + & KEY(3)(:KEYL(3)),KEY(4)(:KEYL(4)),KEY(5)(:KEYL(5)), + & KEY(6)(:KEYL(6)),KEY(7)(:KEYL(7)),KEY(8)(:KEYL(8)), + & KEY(9)(:KEYL(9)),KEY(10)(:KEYL(10))) + + IF (IER.EQ.0.AND.HELP_INPUT_LEN.GT.0) IER = 1 + ! IER = 0 special case means input given to full screen prompt + + IF (KEY(NKEY).EQ.'*'.OR..NOT.EXACT) THEN ! If not exact match + DO I=OLD_NKEY+1,NKEY ! then don't update + KEYL(I) = 0 ! new keys + END DO + NKEY = OLD_NKEY + END IF + + DO WHILE (HELP_INPUT_LEN.EQ.0.AND.IER.AND.NKEY.GE.0) + IF (NKEY.EQ.0) THEN ! If top level, prompt for topic + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Topic? ',HELP_INPUT_LEN) + ELSE ! If not top level, prompt for subtopic + LPROMPT = 0 ! Create subtopic prompt line + DO I=1,NKEY ! Put spaces in between keys + PROMPT = PROMPT(:LPROMPT)//KEY(I)(:KEYL(I))//' ' + LPROMPT = LPROMPT + KEYL(I) + 1 + END DO + PROMPT = PROMPT(:LPROMPT)//'Subtopic? ' + LPROMPT = LPROMPT + 10 + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,PROMPT(:LPROMPT),HELP_INPUT_LEN) + END IF + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) + IF (IER.AND.HELP_INPUT_LEN.EQ.0) THEN ! If RETURN entered + KEYL(NKEY) = 0 ! Back up one key level + NKEY = NKEY - 1 + END IF + END DO + + IF (.NOT.IER.OR.NKEY.LT.0) THEN ! If CTRL-Z above top level, + CALL LBR$CLOSE(LINDEX) ! then close library, + CALL SMG$UNPASTE_VIRTUAL_DISPLAY(DISPLAY_ID,PASTEBOARD_ID) + ! remove virtual display + RETURN ! and end help session. + END IF + + END DO + + END + + + + INTEGER FUNCTION PUT_OUTPUT(INPUT,INFO,DATA,LEVEL) +C +C FUNCTION PUT_OUTPUT +C +C FUNCTION: +C Output routine for input from LBR$GET_HELP. Displays +C help text on terminal with full screen prompting. +C INPUTS: +C INPUT - Character string. Line of input text. +C INFO - Longword. Contains help flag bits. +C DATA - Longword. Not presently used. +C LEVEL - Longword. Contains current key level. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($HLPDEF)' + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + COMMON /HELP/ HELP_PAGE,DISPLAY_ID,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID + CHARACTER*80 HELP_INPUT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + + CHARACTER INPUT*(*) + + CHARACTER SPACES*20 + DATA SPACES /' '/ + + IF ((INFO.AND.HLP$M_NOHLPTXT).NE.0) THEN ! Key cannot be found + NEED_ERASE = .FALSE. ! Don't erase screen + IF (HELP_PAGE.EQ.0) THEN ! If first line of help text + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were inputted, as they are + END DO ! not valid, as no match + NKEY = OLD_NKEY ! could be found. + END IF + ELSE IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0.AND.NKEY.GT.0.AND. + & LEVEL.GT.OLD_NKEY.AND.KEY(NKEY)(:KEYL(NKEY)).NE.'*'.AND. + & %LOC(INPUT).NE.0) THEN ! If text contains key names + ! Update if not wildcard search and they are new keys + IF (KEYL(LEVEL).GT.0) THEN ! If key already updated + EXACT = .FALSE. ! Must be more than one match possible + END IF ! so indicate not exact match. + START_KEY = 1 ! String preceeding spaces. + DO WHILE (INPUT(START_KEY:START_KEY).EQ.' ') + START_KEY = START_KEY + 1 + END DO + KEY(LEVEL) = INPUT(START_KEY:) ! Store new key + CALL STR$TRIM(KEY(LEVEL),KEY(LEVEL),KEYL(LEVEL)) ! & key length + ELSE IF (HELP_PAGE.EQ.0) THEN ! If first line of text, + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were just inputted, allowing + END DO ! this routine to fill them. + END IF + + IF (NEED_ERASE) THEN ! Need to erase screen? + IER = SMG$ERASE_DISPLAY(DISPLAY_ID) ! i.e. start of new topic. + NEED_ERASE = .FALSE. + END IF + + HELP_PAGE = HELP_PAGE + 1 ! Increment screen counter + IF (PAGING.AND.HELP_PAGE.GT.PAGE_LENGTH-2) THEN ! End of page? + HELP_PAGE = 0 ! Reinitialize screen counter + CALL LIB$PUT_OUTPUT(' ') ! Skip line and prompt for next screen + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Press RETURN to continue ... ',HELP_INPUT_LEN) + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) ! Trim input + IF (.NOT.IER.OR.HELP_INPUT_LEN.GT.0) THEN ! CTRL-Z or Text input? + EXACT = .TRUE. ! If more than one match was found and being + ! displayed, text input specifies that the + ! current displayed match is desired. + PUT_OUTPUT = 0 ! Stop any more of current help display. + ELSE ! Else if RETURN entered + IER = SMG$ERASE_DISPLAY(DISPLAY_ID) ! Erase display + NSPACES = LEVEL*2 ! Number of spaces to indent output + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + ! Key name lines are indented 2 less than help description. + IF (NSPACES.GT.0) THEN ! Add spaces if present to output + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE ! Else just output text. + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + HELP_PAGE = 1 ! Increment page counter. + END IF + ELSE ! Else if not end of page + NSPACES = LEVEL*2 ! Just output text line + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + IF (NSPACES.GT.0) THEN + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_VERSION + + IMPLICIT INTEGER (A-Z) + + CHARACTER VERSION*10,DATE*23 + + CALL READ_HEADER(VERSION,DATE) + + WRITE (6,'(A)') ' BULLETIN Version '//VERSION(:TRIM(VERSION)) + + WRITE (6,'(A)') ' Linked on '//DATE(:TRIM(DATE)) + + RETURN + END + + + + + + + SUBROUTINE TAG(ADD_OR_DEL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + DATA BULL_TAG /.FALSE./,READ_TAG /.FALSE./ + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + IF (.NOT.BULL_TAG) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + IF (.NOT.CLI$PRESENT('NUMBER')) THEN + IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER) + ELSE + CALL DEL_TAG(IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Message was not marked.'')') + END IF + END IF + RETURN + END IF + + CALL OPEN_BULLDIR_SHARED + + IER1 = 0 + DO WHILE (CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + & .NE.%LOC(CLI$_ABSENT).AND.IER1.EQ.0) ! Get the specified messages + + DECODE(LEN_P,'(I)',BULL_PARAMETER) MESSAGE_NUMBER + + CALL READDIR(MESSAGE_NUMBER,IER) ! Get info for bulletin + + IF (IER.NE.MESSAGE_NUMBER+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER1) + ELSE + CALL DEL_TAG(IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Message '',I, + & '' was not marked.'')') MESSAGE_NUMBER + END IF + END IF + END DO + + CALL CLOSE_BULLDIR + + RETURN + +1010 FORMAT(' ERROR: You have not read any message.') +1030 FORMAT(' ERROR: Message was not found.') + + END + + + + SUBROUTINE ADD_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER*12 TAG_KEY + + WRITE (13,IOSTAT=IER) TAG_KEY(FOLDER_NUMBER,MSG_KEY) + + IF (IER.EQ.FOR$IOS_INCKEYCHG) THEN + WRITE (6,'('' Message was already marked.'')') + ELSE IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Unable to add mark.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + END IF + + RETURN + END + + + + + SUBROUTINE DEL_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER*12 TAG_KEY + + DO WHILE (REC_LOCK(IER)) + READ (13,KEYEQ=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) + END DO + IF (IER.NE.0) RETURN + + DELETE (UNIT=13,IOSTAT=IER) + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Unable to delete mark.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + END IF + + RETURN + END + + + + + + SUBROUTINE OPEN_OLD_TAG + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + IF (.NOT.IER) RETURN + + NTRIES = 0 + + DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) + OPEN (UNIT=13,FILE='BULL_MARK:'// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + NTRIES = NTRIES + 1 + END DO + + IF (IER.NE.0.AND.IER.NE.FOR$IOS_FILNOTFOU) THEN + WRITE (6,'('' Unable to open mark file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + RETURN + END IF + + IF (IER.EQ.0) BULL_TAG = .TRUE. + + RETURN + END + + + + + SUBROUTINE OPEN_NEW_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*64 BULL_MARK + + IER = SYS_TRNLNM('BULL_MARK',BULL_MARK) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: BULL_MARK must be defined.'', + & '' See HELP MARK.'')') + RETURN + ELSE + IER1 = SYS_TRNLNM_SYSTEM('BULL_MARK',BULL_PARAMETER) + IF (.NOT.IER1.OR.BULL_MARK.NE.BULL_PARAMETER) THEN + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + CALL DISABLE_PRIVS + IER1 = 0 + END IF + OPEN (UNIT=13,FILE='BULL_MARK:'// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & RECORDSIZE=3, + & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + IF (.NOT.IER1) CALL ENABLE_PRIVS + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot create mark file.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + IER = 0 + ELSE + CALL SYS_GETMSG(IER1) + IER = IER1 + END IF + ELSE + BULL_TAG = .TRUE. + IER = 1 + END IF + END IF + + RETURN + END + + + + CHARACTER*12 FUNCTION TAG_KEY(FOLDER_NUMBER,MSG_KEY) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) MSG_KEY + + CALL LIB$MOVC3(4,FOLDER_NUMBER,%REF(TAG_KEY)) + + CALL GET_MSGKEY(%REF(MSG_KEY),TAG_KEY(5:)) + + RETURN + END + + + + + SUBROUTINE GET_FIRST_TAG(FOLDER_NUMBER,IER,MESSAGE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + CHARACTER*12 TAG_KEY,INPUT_KEY + + IF (.NOT.BULL_TAG) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + MSG_KEY = BULLDIR_HEADER + + HEADER = .TRUE. + GO TO 10 + + ENTRY GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) + + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + + ENTRY GET_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) + + HEADER = .FALSE. + +10 DO WHILE (1) + DO WHILE (REC_LOCK(IER)) + READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) + & INPUT_KEY + END DO + + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),MSG_KEY) + CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER) + END IF + + IF (FOLDER1_NUMBER.NE.FOLDER_NUMBER.OR.IER.NE.0) THEN + IER = 1 + UNLOCK 13 + RETURN + ELSE + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL OPEN_BULLDIR + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),INPUT_KEY(5:)) + IF (IER.NE.0.AND.MSG_KEY.EQ.INPUT_KEY(5:)) THEN + UNLOCK 13 + MESSAGE = MSG_NUM + IF (HEADER) THEN + MESSAGE = MESSAGE - 1 + MSG_KEY = BULLDIR_HEADER + END IF + IER = 0 + RETURN + ELSE + DELETE (UNIT=13) + IER = 1 + END IF + END IF + + END DO + + END + + + + + + + SUBROUTINE FULL_DIR(INDEX_COUNT) +C +C Add INDEX command to BULLETIN, display directories of ALL +C folders. Added per request of a faculty member for his private +C board. Changes to BULLETIN.FOR should be fairly obvious. +C +C Brian Nelson, Brian@uoft02.bitnet (or .ccnet, node 8.2) +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + INCLUDE 'BULLFILES.INC' + INCLUDE 'BULLFOLDER.INC' + INCLUDE 'BULLUSER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /TAGS/ BULL_TAG,READ_TAG + + DATA FOLDER_Q1/0/ + + BULL_POINT = 0 + + IF (NUM_FOLDERS.GT.0.AND..NOT.CLI$PRESENT('RESTART') + & .AND.INDEX_COUNT.EQ.1) THEN + INDEX_COUNT = 2 + DIR_COUNT = 0 + END IF + + IF (INDEX_COUNT.EQ.1) THEN + CALL INIT_QUEUE(FOLDER_Q1,FOLDER1_COM) + + FOLDER_Q = FOLDER_Q1 + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0) THEN + IF (BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + WRITE (6,1000) + WRITE (6,1020) + DO J = 1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + WRITE (6,1030) FOLDER1(:15),F1_NBULL, + & FOLDER1_DESCRIP(:MIN(TRIM(FOLDER1_DESCRIP),59)) + END DO + WRITE (6,1060) + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + INDEX_COUNT = 2 + DIR_COUNT = 0 + READ_TAG = .FALSE. + IF (CLI$PRESENT('MARKED')) READ_TAG = .TRUE. + RETURN + ELSE IF (INDEX_COUNT.EQ.2) THEN + IF (DIR_COUNT.EQ.0) THEN + F1_NBULL = 0 + DO WHILE (NUM_FOLDERS.GT.0.AND.F1_NBULL.EQ.0) + NUM_FOLDERS = NUM_FOLDERS - 1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + IF (F1_NBULL.GT.0) THEN + FOLDER_NUMBER = -1 + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) F1_NBULL = 0 + END IF + END DO + + IF (F1_NBULL.EQ.0) THEN + WRITE (6,1050) + INDEX_COUNT = 0 + RETURN + END IF + END IF + + IF (READ_TAG) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + END IF + + CALL DIRECTORY(DIR_COUNT) + IF (DIR_COUNT.GT.0) RETURN + + IF (NUM_FOLDERS.GT.0) THEN + WRITE (6,1040) + ELSE + INDEX_COUNT = 0 + END IF + END IF + + RETURN + +1000 FORMAT (' The following folders are present'/) +1020 FORMAT (' Name Count Description'/) +1030 FORMAT (1X,A15,I5,1X,A) +1040 FORMAT (' Type Return to continue to the next folder...') +1050 FORMAT (' End of folder search.') +1060 FORMAT (' Type Return to continue...') + + END + + + + + SUBROUTINE SHOW_USER +C +C SUBROUTINE SHOW_USER +C +C FUNCTION: Shows information for specified users. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + DIMENSION NOLOGIN_BTIM(2) + + CHARACTER*17 DATETIME + + ALL = CLI$PRESENT('NOLOGIN').OR.CLI$PRESENT('ALL') + & .OR.CLI$PRESENT('LOGIN') + IF (.NOT.ALL) THEN + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + IF (.NOT.IER) TEMP_USER = USERNAME + END IF + + IF (.NOT.SETPRV_PRIV().AND.(ALL.OR.USERNAME.NE.TEMP_USER)) THEN + WRITE (6,'('' ERROR: No privs to user command.'')') + RETURN + END IF + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + + CALL OPEN_BULLUSER_SHARED + + IF (.NOT.ALL) THEN + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + IF (IER.EQ.0) THEN + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + WRITE (6,'('' NOLOGIN set for specified user.'')') + ELSE + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'('' User last logged in at '',A,''.'')') + & DATETIME + END IF + ELSE + WRITE (6,'('' Entry for specified user not found.'')') + END IF + ELSE + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + CALL READ_USER_FILE(IER) + IF (IER.EQ.0.AND.TEMP_USER(:1).NE.':'.AND. + & TEMP_USER(:1).NE.'*') THEN + IER1 = COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM) + IF (.NOT.CLI$PRESENT('LOGIN').AND.IER1.GE.0) THEN + WRITE (6,'('' NOLOGIN set for '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)) + ELSE IF (.NOT.CLI$PRESENT('NOLOGIN').AND.IER1.LT.0) THEN + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'(1X,A,'' last logged in at '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)),DATETIME + END IF + END IF + END DO + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + SUBROUTINE INIT_MESSAGE_ADD(IN_FOLDER,IN_FROM,IN_DESCRIP,IER) +C +C SUBROUTINE INIT_MESSAGE_ADD +C +C FUNCTION: Opens specified folder in order to add message. +C +C INPUTS: +C IN_FOLDER - Character string containing folder name +C IN_FROM - Character string containing name of owner of message. +C If empty, the message is searched for either a +C Reply-to: field or a From: field. If none, then +C the owner of the process is used. If IN_FROM +C ends with a %, it is assumed that it is simply +C the prefix that should be when responding to the +C address via MAIL. I.e. the PMDF interface sends +C IN%, so when the From: field is found, the message +C owner becomes IN%"from-address". +C IN_DESCRIP - Character string containing subject of message. +C If empty, the message is searched for a line +C which starts with "Subj:" or "Subject:". +C OUTPUTS: +C IER - Error status. True if properly connected to folder. +C False if folder not found. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + DATA LPRO/0/ + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + CHARACTER*(*) IN_FOLDER,IN_FROM,IN_DESCRIP + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + COMMON /LAST_BUFFER/ OLD_BUFFER + CHARACTER*(LINE_LENGTH) OLD_BUFFER + + COMMON /OLD_BUFFER_FROM/ OLD_BUFFER_FROM + DATA OLD_BUFFER_FROM /.FALSE./ + + BULLCP = 1 ! Inhibit folder cleanup subprocess + + CALL OPEN_BULLFOLDER ! Get folder file + + CALL READ_FOLDER_FILE_KEYNAME(IN_FOLDER(:TRIM(IN_FOLDER)),IER) + + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + RETURN + ELSE + IER = 1 + END IF + + ENTRY INIT_MESSAGE_ADD_BBOARD(IN_FROM,IN_DESCRIP,IER) + + TEXT = .FALSE. ! No text written, as of yet + + FIRST_BREAK = .TRUE. + + IF (FOLDER_NUMBER.EQ.0) THEN ! If GENERAL folder + FOLDER_SET = .FALSE. ! indicate it + ELSE ! Else it's another folder + FOLDER_SET = .TRUE. ! indicate it + END IF + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER ! set folder file names + + ENTRY INIT_MESSAGE_ADD_DIGEST(IN_FROM,IN_DESCRIP,IER) + + CALL OPEN_BULLDIR ! Open directory file + + CALL OPEN_BULLFIL ! Open data file + + CALL READDIR(0,IER1) ! Get NBLOCK + IF (IER1.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + NBLOCK = NBLOCK + 1 + LENGTH = NBLOCK ! Initialize line count + + LEN_FROM = TRIM(IN_FROM) + + IF (IN_FROM(LEN_FROM:LEN_FROM).EQ.'%') THEN ! Just protocol + PROTOCOL = IN_FROM(:LEN_FROM)//'"' + LPRO = LEN_FROM + 1 + LEN_FROM = 0 + END IF + + IF (LEN_FROM.GT.0) THEN + INFROM = IN_FROM + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_FROM(INFROM,LEN_FROM) + ELSE IF (INDEX(INFROM,'%"').GT.0) THEN ! Store any protocol + LPRO = INDEX(INFROM,'%"') + 1 + PROTOCOL = INFROM(:LPRO) + END IF + LEN_DESCRP = TRIM(IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + ELSE + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH,IOSTAT=IER1) + IF (IER1.NE.0) THEN + OPEN (UNIT=3,STATUS='SCRATCH',FILE='BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) + END IF + SAVE_IN_DESCRIP = IN_DESCRIP + SAVE_IN_FROM = ' ' + END IF + + CALL STRIP_HEADER(INPUT,0,IER1) + + OLD_BUFFER = ' ' + + OLD_BUFFER_FROM = .FALSE. + + RETURN + END + + + + SUBROUTINE WRITEOUT_STORED + + CHARACTER*255 BUFFER + + REWIND (UNIT=3) + + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(A)',IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + CALL WRITE_MESSAGE_LINE(BUFFER) + END IF + END DO + + CLOSE (UNIT=3) + + RETURN + END + + + + SUBROUTINE WRITE_MESSAGE_LINE(BUFFER) +C +C SUBROUTINE WRITE_MESSAGE_LINE +C +C FUNCTION: Writes one line of message into folder. +C +C INPUTS: +C BUFFER - Character string containing line to be put into message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + DATA FIRST_BREAK/.TRUE./ + + COMMON /STRIP_HEADER/ STRIP + DATA STRIP/.TRUE./ + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + CHARACTER*(*) BUFFER + + COMMON /LAST_BUFFER/ OLD_BUFFER + CHARACTER*(LINE_LENGTH) OLD_BUFFER + + COMMON /OLD_BUFFER_FROM/ OLD_BUFFER_FROM + DATA OLD_BUFFER_FROM /.FALSE./ + + LEN_BUFFER = TRIM(BUFFER) + + IF (LEN_FROM.EQ.0) THEN + WRITE (3,'(A)') BUFFER(:LEN_BUFFER) + IF (OLD_BUFFER_FROM.AND.BUFFER(:1).EQ.' ') THEN + SAVE_IN_FROM = + & SAVE_IN_FROM(:TRIM(SAVE_IN_FROM))//BUFFER + OLD_BUFFER_FROM = .FALSE. + ELSE IF (BUFFER(:5).EQ.'From:'.AND.SAVE_IN_FROM.EQ.' ') THEN + IF (LEN_BUFFER.GE.7) SAVE_IN_FROM = BUFFER(7:) + OLD_BUFFER_FROM = .TRUE. + RETURN + ELSE IF (BUFFER(:9).EQ.'Subject: ') THEN + LDESCR = LEN_BUFFER - 9 + INDESCRIP = BUFFER(10:) + ELSE IF (BUFFER(:9).EQ.'Reply-to:'.OR.LEN_BUFFER.EQ.0) THEN + IF (BUFFER(:9).EQ.'Reply-to:') THEN + IF (LEN_BUFFER.GE.11) SAVE_IN_FROM = BUFFER(11:) + OLD_BUFFER_FROM = .TRUE. + RETURN + ELSE IF (LEN_BUFFER.EQ.0.AND.SAVE_IN_FROM.EQ.' ') THEN + CALL GETUSER(SAVE_IN_FROM) + END IF + LEN_FROM = TRIM(SAVE_IN_FROM) + IF (LEN_FROM.GT.0) THEN + OLD_BUFFER_FROM = .FALSE. + INFROM = SAVE_IN_FROM + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_FROM(INFROM,LEN_FROM) + ELSE IF (INDEX(INFROM,'%"').GT.0) THEN + LPRO = INDEX(INFROM,'%"') + 1 + PROTOCOL = INFROM(:LPRO) + END IF + IF (LDESCR.GT.0) THEN + LEN_DESCRP = LDESCR + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + ELSE + LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = SAVE_IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + END IF + CALL WRITEOUT_STORED + END IF + END IF + OLD_BUFFER_FROM = .FALSE. + RETURN + END IF + IF (BTEST(FOLDER_FLAG,5)) THEN + IF (INDEX(BUFFER,'-------------').EQ.1) THEN + BREAK = .TRUE. + DO I=1,LEN_BUFFER + IF (BUFFER(I:I).NE.'-') BREAK = .FALSE. + END DO + ELSE + BREAK = .FALSE. + END IF + IF (BREAK) THEN + IF (.NOT.FIRST_BREAK) THEN + CALL FINISH_MESSAGE_ADD + CALL INIT_MESSAGE_ADD_DIGEST(INFROM,INDESCRIP,IER) + ELSE + FIRST_BREAK = .FALSE. + END IF + LFROM = 0 + LDESCR = 0 + RETURN + ELSE IF (.NOT.FIRST_BREAK) THEN + IF (LDESCR.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + LDESCR = LEN_BUFFER - 9 + CALL STORE_DESCRP(BUFFER(10:),LDESCR) + IF (LFROM.EQ.0) THEN + LFROM = LEN_FROM + CALL STORE_FROM(INFROM,LFROM) + END IF + ELSE IF (BUFFER(:6).EQ.'From: ') THEN + LFROM = LEN_BUFFER - 6 + IF (LFROM.LE.0) THEN + LFROM = TRIM(SAVE_IN_FROM) + IF (LPRO.GT.0) THEN + LFROM = LFROM + LPRO + 1 + CALL STORE_FROM(PROTOCOL(:LPRO)// + & SAVE_IN_FROM//'"',LFROM) + ELSE + CALL STORE_FROM(SAVE_IN_FROM,LFROM) + END IF + ELSE IF (LPRO.GT.0) THEN + LFROM = LFROM + LPRO + 1 + CALL STORE_FROM(PROTOCOL(:LPRO)// + & BUFFER(7:LEN_BUFFER)//'"',LFROM) + ELSE + CALL STORE_FROM(BUFFER(7:),LFROM) + END IF + END IF + RETURN + END IF + ELSE + RETURN + END IF + END IF + + IF (LEN_BUFFER.EQ.0) THEN ! If empty line + IF (.NOT.STRIP) THEN + CALL STORE_BULL(1,' ',NBLOCK) ! just store one space + ELSE + CALL STRIP_HEADER(BUFFER,LEN_BUFFER,IER) + OLD_BUFFER = ' ' + END IF + ELSE + IF (LEN_DESCRP.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + DESCRIP = BUFFER(INDEX(BUFFER,' ')+1:) + LEN_DESCRP = LEN_BUFFER + END IF + END IF + IF (STRIP) THEN + CALL STRIP_HEADER(BUFFER,LEN_BUFFER,IER) + IF (IER) THEN + OLD_BUFFER = BUFFER + RETURN + ELSE + IF (TRIM(OLD_BUFFER).GT.0) THEN + CALL STORE_BULL(TRIM(OLD_BUFFER),OLD_BUFFER,NBLOCK) + END IF + STRIP = .FALSE. + END IF + END IF + CALL STORE_BULL(MIN(LEN_BUFFER,LINE_LENGTH),BUFFER,NBLOCK) + TEXT = .TRUE. + END IF + + RETURN + END + + + + + SUBROUTINE FINISH_MESSAGE_ADD +C +C SUBROUTINE FINISH_MESSAGE_ADD +C +C FUNCTION: Writes message entry into directory file and closes folder +C +C NOTE: Only should be run if INIT_MESSAGE_ADD was successful. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + COMMON /STRIP_HEADER/ STRIP + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + IF (LEN_FROM.EQ.0) THEN + CALL GETUSER(FROM) + INFROM = FROM + LEN_FROM = TRIM(INFROM) + LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = SAVE_IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + CALL WRITEOUT_STORED + END IF + + STRIP = .TRUE. ! Reset strip flag + + CALL FLUSH_BULL(NBLOCK) + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + IF ((BTEST(FOLDER_FLAG,5).AND.LDESCR.EQ.0).OR. ! End of digest msg + & .NOT.TEXT) THEN ! or no message text found + CALL CLOSE_BULLDIR ! then don't add message entry + RETURN + END IF + + IF (FOLDER_BBEXPIRE.EQ.-1) THEN ! Folder has expiration time? + EXDATE = '5-NOV-2000' ! no, so set date far in future + SYSTEM = 2 ! indicate permanent message + ELSE ! Else set expiration date + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + SYSTEM = 0 + END IF + EXTIME = '00:00:00.00' + + LENGTH = NBLOCK - LENGTH + 1 ! Number of records + + CALL ADD_ENTRY ! Add the new directory entry + + CALL CLOSE_BULLDIR ! Totally finished with add + + CALL UPDATE_FOLDER + + RETURN + END + + + + + SUBROUTINE STORE_FROM(IFROM,LEN_INFROM) + + IMPLICIT INTEGER (A-Z) + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) IFROM + + CHARACTER*(LINE_LENGTH) INFROM + + INFROM = IFROM + + IF (LPRO.GT.0) THEN ! Protocol present? + I = INDEX(INFROM,'%"') + 2 ! Make usable for VMS MAIL + IF (I.EQ.2) THEN + INFROM = PROTOCOL(:LPRO)//INFROM(:LEN_INFROM)//'"' + I = LPRO + 1 + LEN_INFROM = LEN_INFROM + LPRO + 1 + END IF + DO WHILE (I.LT.LEN_INFROM) + IF (INFROM(I:I).EQ.'"') THEN + INFROM(I:I) = '''' + ELSE IF (INFROM(I:I).EQ.'\') THEN + INFROM(I+1:) = '\'//INFROM(I+1:) + LEN_INFROM = LEN_INFROM + 1 + I = I + 1 + ELSE IF (INFROM(I:I).EQ.'''') THEN + INFROM(I:) = '\s'//INFROM(I+1:) + LEN_INFROM = LEN_INFROM + 1 + I = I + 2 + END IF + I = I + 1 + END DO + END IF + + DO I=1,LEN_INFROM ! Remove control characters + IF (INFROM(I:I).LT.' ') INFROM(I:I) = ' ' + END DO + + DO WHILE (LEN_INFROM.GT.0.AND.INFROM(:1).EQ.' ') + INFROM = INFROM(2:) + LEN_INFROM = LEN_INFROM - 1 + END DO + + TWO_SPACE = INDEX(INFROM,' ') + DO WHILE (TWO_SPACE.GT.0.AND.TWO_SPACE.LT.LEN_INFROM) + INFROM = INFROM(:TWO_SPACE)//INFROM(TWO_SPACE+2:) + LEN_INFROM = LEN_INFROM - 1 + TWO_SPACE = INDEX(INFROM,' ') + END DO + + CALL STORE_BULL(6+LEN_INFROM,'From: '//INFROM(:LEN_INFROM), + & NBLOCK) + + IF (INDEX(INFROM,'%"').GT.0) ! Strip off protocol program + & INFROM = INFROM(INDEX(INFROM,'%"')+2:) + + IF (INDEX(INFROM,'::').GT.0) ! Strip off node name + & INFROM = INFROM(INDEX(INFROM,'::')+2:) ! I.e. HOST::USER + + DO WHILE (INDEX(INFROM,'!').GT.0.AND. ! Unix address go backwards. + & INDEX(INFROM,'!').LT.INDEX(INFROM,'@')) + INFROM = INFROM(INDEX(INFROM,'!')+1:) ! I.e. host!user + END DO + + IF (INDEX(INFROM,'<').GT.0) THEN ! Name may be of form + INFROM = INFROM(INDEX(INFROM,'<'):) ! personal-name + END IF + + IF (INDEX(INFROM,'(').GT.0.AND. ! personal-name (net-name) + & INDEX(INFROM,'@').GT.INDEX(INFROM,'(')) THEN + INFROM = INFROM(INDEX(INFROM,'(')+1:) + END IF + + I = 1 ! Trim username to start at first alpha character + DO WHILE (I.LE.LEN_INFROM.AND.(INFROM(I:I).EQ.' '.OR. + & INFROM(I:I).EQ.'%'.OR.INFROM(I:I).EQ.'.'.OR. + & INFROM(I:I).EQ.'@'.OR.INFROM(I:I).EQ.'<'.OR. + & INFROM(I:I).EQ.'"')) + I = I + 1 + END DO + INFROM = INFROM(I:) + + I = 1 ! Trim username to end at a alpha character + DO WHILE (I.LE.12.AND.INFROM(I:I).NE.' '.AND. + & INFROM(I:I).NE.'%'.AND.INFROM(I:I).NE.'.'.AND. + & INFROM(I:I).NE.'@'.AND.INFROM(I:I).NE.'<'.AND. + & INFROM(I:I).NE.'"') + I = I + 1 + END DO + FROM = INFROM(:I-1) + + DO J=2,I-1 + IF ((FROM(J:J).GE.'A'.AND.FROM(J:J).LE.'Z').AND. + & ((FROM(J-1:J-1).GE.'A'.AND.FROM(J-1:J-1).LE.'Z').OR. + & (FROM(J-1:J-1).GE.'a'.AND.FROM(J-1:J-1).LE.'z'))) THEN + FROM(J:J) = CHAR(ICHAR(FROM(J:J))-ICHAR('A')+ICHAR('a')) + END IF + END DO + + RETURN + END + + + + + SUBROUTINE STORE_DESCRP(INDESCRIP,LEN_DESCRP) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) INDESCRIP + + CALL CONVERT_TABS(INDESCRIP,LEN_DESCRP) + + DO I=1,LEN_DESCRP ! Remove control characters + IF (INDESCRIP(I:I).LT.' ') INDESCRIP(I:I) = ' ' + END DO + + DO WHILE (LEN_DESCRP.GT.0.AND.INDESCRIP(:1).EQ.' ') + INDESCRIP = INDESCRIP(2:) + LEN_DESCRP = LEN_DESCRP - 1 + END DO + + IF (LEN_DESCRP.GT.LEN(DESCRIP)) THEN + ! Is length > allowable subject length? + CALL STORE_BULL(6+LEN_DESCRP,'Subj: '// + & INDESCRIP(:LEN_DESCRP),NBLOCK) + END IF + + DESCRIP = INDESCRIP(:MIN(LEN_DESCRP,LEN(DESCRIP))) + + RETURN + END + + + + + + SUBROUTINE STRIP_HEADER(BUFFER,BLEN,IER) +C +C SUBROUTINE STRIP_HEADER +C +C FUNCTION: Indicates whether line is part of mail message header. +C +C INPUTS: +C BUFFER - Character string containing input line of message. +C BLEN - Length of character string. If = 0, initialize subroutine. +C +C OUTPUTS: +C IER - If true, line should be stripped. Else, end of header. +C + IMPLICIT INTEGER (A - Z) + + CHARACTER*(*) BUFFER + + INCLUDE 'BULLFOLDER.INC' + + IF (.NOT.BTEST(FOLDER_FLAG,4).OR.TRIM(BUFFER).EQ.0) THEN + ! If STRIP not set for folder or empty line + IER = .FALSE. + CONT_LINE = .FALSE. + RETURN + END IF + + IF (BLEN.EQ.0) CONT_LINE = .FALSE. + + IER = .TRUE. + + IF (CONT_LINE.AND.(BUFFER(:1).EQ.' '.OR. ! If line is continuation + & BUFFER(:1).EQ.CHAR(9))) RETURN ! of previous header line + + I = 1 + DO WHILE (I.LE.BLEN.AND.BUFFER(I:I).NE.' ') + IF (BUFFER(I:I).EQ.':') THEN ! Header line found + CONT_LINE = .TRUE. ! Next line might be continuation + RETURN + ELSE + I = I + 1 + END IF + END DO + + IER = .FALSE. + CONT_LINE = .FALSE. + + RETURN + END diff --git a/decus/vax90a/bulletin/bullmain.cld b/decus/vax90a/bulletin/bullmain.cld new file mode 100644 index 0000000..6f23cd7 --- /dev/null +++ b/decus/vax90a/bulletin/bullmain.cld @@ -0,0 +1,26 @@ + MODULE BULLETIN_MAINCOMMANDS + DEFINE VERB BULLETIN + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER ALL + QUALIFIER BBOARD + QUALIFIER BULLCP + QUALIFIER CLEANUP, LABEL=CLEANUP, VALUE(REQUIRED) + QUALIFIER EDIT + QUALIFIER KEYPAD + QUALIFIER LOGIN + QUALIFIER MARKED + QUALIFIER PAGE, DEFAULT + QUALIFIER READNEW + QUALIFIER REVERSE +! +! The following line causes a line to be outputted separating system notices. +! The line consists of a line of all "-"s, i.e.: +!-------------------------------------------------------------------------- +! If you want a different character to be used, simply put in the desired one +! in the following line. If you want to disable the feature, remove the +! DEFAULT at the end of the line. (Don't remove the whole line!) +! + QUALIFIER SEPARATE, VALUE(DEFAULT="-"), DEFAULT + QUALIFIER STARTUP + QUALIFIER STOP + QUALIFIER SYSTEM, VALUE(TYPE=$NUMBER,DEFAULT="7") diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/allmacs.mar b/decus/vax90b1/bulletin/vlt90b/bulletin/allmacs.mar new file mode 100644 index 0000000..f8a6793 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/allmacs.mar @@ -0,0 +1,270 @@ +; +; Name: SETACC.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: Jan 26, 1983 +; +; Purpose: To set the account name of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETACC(account) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; account - Character string containing account name +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETACC + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF + $JIBDEF +; +; local variables: +; + + .PSECT DATA,NOEXE + +NEWACC: .BLKB 12 ; Contains new account name +; +; Executable: +; + .PSECT CODE,EXE,NOWRT ; Executable code + + .ENTRY SETACC,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R6 ; Get number of arguments + CMPL R6,#1 ; Correct number of arguments? + BNEQ 5$ ; If not, return + MOVZBL @4(AP),R6 ; Get size of string + MOVL 4(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#8,NEWACC ; Get new account name string + $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R6 ; Address of current process + MOVL PCB$L_JIB(R6),R6 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + MOVC3 #8,NEWACC,JIB$T_ACCOUNT(R6) ; change account JIB + MOVC3 #8,NEWACC,CTL$T_ACCOUNT ; change account in P1 + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +; +; Name: SETUIC.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: May 31, 1983 +; +; Purpose: To set the UIC of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETUIC(group number, user number) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; group number - longword containing UIC group number +; user number - longword containing UIC user number +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETUIC Set uic + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF +; +; Executable: +; + .PSECT SETUIC_CODE,EXE,NOWRT ; Executable code + + .ENTRY SETUIC,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R2 ; Get number of arguments + CMPL R2,#2 ; Are there 2 arguments + BNEQ 5$ ; If not, return + MOVL @4(AP),R3 ; Group number into R3 + ROTL #16,R3,R3 ; Move to upper half of R3 + ADDL2 @8(AP),R3 ; User number to top half of R3 + $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R2 ; Address of current process + MOVL R3,PCB$L_UIC(R2) ; Set UIC to specified + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +; +; Name: SETUSER.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: Jan 26, 1983 +; +; Purpose: To set the Username of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETUSER(username) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; username - Character string containing username +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETUSER Set uic + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF + $JIBDEF +; +; local variables: +; + + .PSECT SETUSER_DATA,NOEXE + +NEWUSE: .BLKB 12 ; Contains new username +OLDUSE: .BLKB 12 ; Contains old username +; +; Executable: +; + .PSECT SETUSER_CODE,EXE,NOWRT ; Executable code + + .ENTRY SETUSER,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R8 ; Get number of arguments + CMPL R8,#1 ; Correct number of arguments + BLSS 5$ ; If not, return + MOVZBL @4(AP),R6 ; Get size of string + MOVL 4(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#12,NEWUSE ; Get new username string + CMPL R8,#2 ; Old username given? + BLSS 2$ ; No + MOVZBL @8(AP),R6 ; Get size of string + MOVL 8(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#12,OLDUSE ; Get old username string + $CMKRNL_S ROUTIN=20$ ; Must run in kernel mode + TSTL R0 ; If old username is checks with + BEQL 2$ ; present process name, change + MOVL #2,R0 ; to new username, else flag + RET ; error and return +2$: $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R7 ; Address of current process + MOVL PCB$L_JIB(R7),R7 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + MOVC3 #12,NEWUSE,JIB$T_USERNAME(R7) ; change username JIB + MOVC3 #12,NEWUSE,CTL$T_USERNAME ; change username in P1 + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +20$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R7 ; Address of current process + MOVL PCB$L_JIB(R7),R7 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + CMPC R6,OLDUSE,JIB$T_USERNAME(R7) ; change username JIB + RET + + + .TITLE READ_HEADER - Read Image Header + .IDENT /1-001/ + +; This subroutine returns the image identification and link time. +; +; Format: +; +; status.wlc.v = READ_HEADER( ident.wt.ds [,time.wt.ds] ) +; +; Parameters: +; +; ident The image identification text. +; +; time The image link time (text format). + + +; Date By Comments +; 4/10/87 D.E. Greenwood Originally written by John Miano, 24-June-1986 - +; obtained from April 87 DECUS L&T Sig Newsletter + .LIBRARY "SYS$LIBRARY:LIB" + + $DSCDEF + $IHDDEF + $IHIDEF + $SSDEF + +; Argument pointer offsets + + $OFFSET 4,POSITIVE, + + .PSECT READ_HEADER, RD, NOWRT, EXE, LONG + .ENTRY READ_HEADER, ^M< R2, R3, R4, R5, R6, R7, R8, R11 > + + CMPL (AP),#1 ; Make sure that there is at least + BGEQ ENOUGH_ARGUMENTS ; one argument to this routine + MOVL #SS$_INSFARG, R0 + RET + +ENOUGH_ARGUMENTS: + +; Get the identification of the image. + + MOVL @#CTL$GL_IMGHDRBF, R11 ; R11 - Address of image buffer + MOVL (R11), R6 ; R6 - Address of image header + + CVTWL IHD$W_IMGIDOFF(R6), R7 + MOVAB (R6)[R7], R7 ; R7 - Address of ID Block + + CVTBL IHI$T_IMGID(R7),R0 ; Length of the ID string + MOVL IDENT(AP), R8 + MOVC5 R0, (R7), #32, - + DSC$W_LENGTH(R8), @DSC$A_POINTER(R8) + + CMPL (AP), #2 + BGEQ RETURN_TIME + MOVZBL #1, R0 + RET + +RETURN_TIME: + +; Get the time the image was linked and convert it to ASCII + + $ASCTIM_S - + TIMBUF=@TIME(AP), - + TIMADR=IHI$Q_LINKTIME(R7) + + RET + + .END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulldir.inc b/decus/vax90b1/bulletin/vlt90b/bulletin/bulldir.inc new file mode 100644 index 0000000..640dc6c --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulldir.inc @@ -0,0 +1,33 @@ + PARAMETER DIR_RECORD_LENGTH = ((97+3)/4)*4 + + COMMON /BULL_DIR/ MSG_BTIM,MSG_NUM,DESCRIP,FROM,LENGTH,EX_BTIM + & ,SYSTEM,BLOCK,HEADER_BTIM,HEADER_NUM,NEWEST_EXBTIM,NEWEST_MSGBTIM + & ,NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_BTIM,NEMPTY + & ,DATE,TIME,EXDATE,EXTIME,NEWEST_EXDATE,NEWEST_EXTIME + & ,NEWEST_DATE,NEWEST_TIME,SHUTDOWN_DATE,SHUTDOWN_TIME + CHARACTER*53 DESCRIP + CHARACTER*12 FROM + LOGICAL SYSTEM + + CHARACTER*11 DATE,EXDATE,NEWEST_EXDATE,NEWEST_DATE,SHUTDOWN_DATE + CHARACTER*11 TIME,EXTIME,NEWEST_EXTIME,NEWEST_TIME,SHUTDOWN_TIME + + INTEGER MSG_BTIM(2),EX_BTIM(2),HEADER_BTIM(2) + INTEGER NEWEST_EXBTIM(2),NEWEST_MSGBTIM(2),SHUTDOWN_BTIM(2) + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY + EQUIVALENCE (MSG_BTIM,BULLDIR_ENTRY) + + CHARACTER*52 BULLDIR_HEADER + EQUIVALENCE (HEADER_BTIM,BULLDIR_HEADER) + + DATA HEADER_BTIM/0,0/,HEADER_NUM/0/ + + CHARACTER MSG_KEY*8 + + EQUIVALENCE (MSG_BTIM,MSG_KEY) + + PARAMETER LINE_LENGTH=255 + + COMMON /INPUT_BUFFER/ INPUT + CHARACTER INPUT*(LINE_LENGTH) diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin.for new file mode 100644 index 0000000..01ad989 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin.for @@ -0,0 +1,1623 @@ +C +C BULLETIN.FOR, Version 11/27/90 +C Purpose: Bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /POINT/ BULL_POINT + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING /.FALSE./ + + COMMON /CTRLY/ CTRLY + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + EXTERNAL ERROR_TRAP + EXTERNAL BULLETIN_SUBCOMMANDS,LIB$GET_INPUT + EXTERNAL BULLETIN_MAINCOMMANDS,ENABLE_CTRL_EXIT + EXTERNAL CLI$_ABSENT,CLI$_NOCOMD,CLI$_NEGATED + + PARAMETER PCB$M_BATCH = '4000'X + PARAMETER PCB$M_NETWRK = '200000'X + PARAMETER LIB$M_CLI_CTRLY = '2000000'X + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER HELP_DIRECTORY*64,SAVE_FOLDER*25 + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + COMMON /DCL/ DCL_CMD,DCL_COMMAND + CHARACTER*132 DCL_CMD + + CHARACTER*42 PROMPT + + DCL_COMMAND = 0 + CALL LIB$ESTABLISH(ERROR_TRAP) + IF (.NOT.CLI$GET_VALUE('PROMPT',COMMAND_PROMPT,ILEN)) THEN + CALL LIB$GET_FOREIGN(INCMD) + DCL_COMMAND = INDEX(INCMD,'"') + IF (DCL_COMMAND.EQ.0) THEN + CALL CLI$DCL_PARSE('BULLETIN '//INCMD,BULLETIN_MAINCOMMANDS) + ELSE + CALL CLI$DCL_PARSE('BULLETIN '//INCMD(:DCL_COMMAND-1), + & BULLETIN_MAINCOMMANDS) + DCL_CMD = INCMD(DCL_COMMAND+1:) + IF (DCL_CMD(TRIM(DCL_CMD):).EQ.'"') THEN + DCL_CMD = DCL_CMD(:TRIM(DCL_CMD)-1) + END IF + END IF + CALL CLI$GET_VALUE('$LINE',COMMAND_PROMPT,ILEN) + END IF + CALL LIB$REVERT + + READIT = 0 + LOGIN_SWITCH = CLI$PRESENT('LOGIN') + SYSTEM_SWITCH = CLI$PRESENT('SYSTEM') + REVERSE_SWITCH = CLI$PRESENT('REVERSE') + + IER = LIB$SYS_TRNLOG('BULL_DISABLE',LEN_P,BULL_PARAMETER) + IF (IER.EQ.1.AND.LEN_P.GT.0.AND..NOT.CLI$PRESENT('STOP')) THEN + IF (.NOT.LOGIN_SWITCH) THEN + WRITE (6,'('' BULLETIN temporarily disabled. Try later.'')') + END IF + CALL EXIT + END IF + + CALL SYS$SETDFPROT(,ORIGINAL_DEF_PROT) + ! Save original default protection in case it gets changed + + CALL DCLEXH(%LOC(ENABLE_CTRL_EXIT)) ! Declare exit handler + +C +C Check to see if CONTROL Y disabled. If so, then never disable CONTROL Y. +C Disabling and enabling CONTROL Y is done so that a person can not break +C while one of the data files is opened, as that would not allow anyone +C else to modify the files. However, if CONTROL Y is already disabled, +C this is not necessary, and should not be done! +C + + CALL LIB$DISABLE_CTRL(LIB$M_CLI_CTRLY,CTRLY) ! Disable CTRL-Y & -C + CTRLY = CTRLY .AND. LIB$M_CLI_CTRLY + CALL GETPRIV ! Check privileges + CALL CHECK_PRIV_IO(ERR) ! Check privileges on output I/O + CALL LIB$ENABLE_CTRL(CTRLY,) ! Renable CTRLY-Y & -C + + IF (ERR.EQ.1) CALL EXIT ! I/O privilege error, so exit + + CALL GETUSER(USERNAME) ! Get the process's username + IF (.NOT.LOGIN_SWITCH) CALL CHECK_BULLETIN_PRIV(USERNAME) + ! Check if has bulletin privileges + + I = 1 ! Strip off folder name if specified + DO WHILE (I.LE.ILEN) + IF (COMMAND_PROMPT(I:I).EQ.' ') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + I = ILEN + 1 + ELSE + I = I + 1 + END IF + END DO + ILEN = 1 ! Get executable name to use as prompt + DO WHILE (ILEN.GT.0) + ILEN = MAX(INDEX(COMMAND_PROMPT,':'),INDEX(COMMAND_PROMPT,']')) + IF (ILEN.GT.0) THEN + COMMAND_PROMPT = COMMAND_PROMPT(ILEN+1:) + ELSE + DO I=TRIM(COMMAND_PROMPT),1,-1 + IF (COMMAND_PROMPT(I:I).LT.'A'.OR. + & COMMAND_PROMPT(I:I).GT.'Z') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + END IF + END DO + END IF + END DO + COMMAND_PROMPT = COMMAND_PROMPT(:TRIM(COMMAND_PROMPT))//'> ' + IF (COMMAND_PROMPT.EQ.'RUN> ') COMMAND_PROMPT = 'BULLETIN> ' + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + + CALL CLI$GET_VALUE('SEPARATE',SEPARATE) + + IF (CLI$PRESENT('EDIT')) EDIT_DEFAULT = .TRUE. ! /EDIT switch test + + CALL FIND_BULLCP ! See if BULLCP is running + + IF (CLI$PRESENT('CLEANUP')) THEN ! Test for /CLEANUP switch + CALL CLI$GET_VALUE('CLEANUP',BULL_PARAMETER,LEN_P) ! Get folder # + READ (BULL_PARAMETER,'(I)') FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + CALL EXIT ! all done with cleanup + ELSE IF (CLI$PRESENT('BBOARD')) THEN ! Test for /BBOARD switch + CALL BBOARD ! look for BBOARD mail + CALL EXIT ! all done with BBOARD + ELSE IF (CLI$PRESENT('STARTUP').OR. ! BULLCP process control + & CLI$PRESENT('STOP')) THEN + CALL CREATE_BULLCP + ELSE IF (CLI$PRESENT('BULLCP')) THEN ! This is BULLCP, so start + CALL RUN_BULLCP ! doing what BULLCP does! + END IF + + CALL GETSTS(STS) ! Get process status word + + IF (SYSTEM_SWITCH.OR.LOGIN_SWITCH) THEN ! If BULLETIN/LOGIN or /SYSTEM + IF ((STS.AND.PCB$M_BATCH).GT.0) CALL EXIT ! If BATCH, exit + CALL CRELNM('SYS$INPUT','TT') ! Take input from terminal + END IF + + IF ((STS.AND.PCB$M_NETWRK).EQ.0) THEN + DECNET_PROC = .FALSE. + ERROR_UNIT = 6 + + CALL ASSIGN_TERMINAL ! Assign terminal + + IF (.NOT.LOGIN_SWITCH) THEN + INCMD = 'SELECT' ! Causes nearest folder name to be selected + CALL SELECT_FOLDER(.FALSE.,IER) ! Select GENERAL folder + IF (.NOT.IER) RETURN ! If can't access, exit + + IF (.NOT.TEST_BULLCP()) CALL DELETE_EXPIRED + ! Delete expired messages + END IF + +C +C Get page size for the terminal. +C + + CALL GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) + + IER = CLI$GET_VALUE('WIDTH',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + DECODE(LEN_P,'(I)',BULL_PARAMETER) PAGE_WIDTH + END IF + + IF (CLI$PRESENT('PAGE')) PAGING = .TRUE. + + IF (SYSTEM_SWITCH) THEN + IER = CLI$GET_VALUE('SYSTEM',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Days specified? + CALL SUBTIME(SYSTEM_LOGIN_BTIM,BULL_PARAMETER(:LEN_P),IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Invalid parameter in /SYSTEM.'')') + CALL EXIT + END IF + END IF + IF (.NOT.LOGIN_SWITCH) THEN + CALL MODIFY_SYSTEM_LIST(0) + CALL SHOW_SYSTEM + CALL EXIT + END IF + END IF + +C +C Get user info stored in SYS$LOGIN. Currently, this simply stores +C the time of the latest message read for each folder. +C + + CALL OPEN_USERINFO + +C +C If /LOGIN, display SYSTEM bulletins and subject of non-SYSTEM bulletins. +C + + IF (LOGIN_SWITCH.OR.SYSTEM_SWITCH) THEN ! Is /LOGIN present? + CALL LOGIN ! Display SYSTEM bulletins + IF (READIT.EQ.0) CALL EXIT ! If no READNEWs not set, exit + END IF + +C +C If new bulletins have been added since the last time bulletins have been +C read, position bulletin pointer so that next bulletin read is the first new +C bulletin, and alert user. If READNEW set and no new bulletins, just exit. +C + + IF (DCL_COMMAND.EQ.0) CALL NEW_MESSAGE_NOTIFICATION + + CALL OPEN_OLD_TAG + + ELSE + IF (TEST_BULLCP()) CALL EXIT + DECNET_PROC = .TRUE. + ERROR_UNIT = 5 + END IF + +C +C The MAIN loop for processing bulletin commands. +C + + DIR_COUNT = 0 ! # directory entry to continue bulletin read from + READ_COUNT = 0 ! # block that bulletin READ is to continue from + FOLDER_COUNT = 0 ! # folder entry to continue SHOW/ALL folder from + INDEX_COUNT = 0 + + IER = LIB$SYS_TRNLOG('BULL_HELP',HLEN,HELP_DIRECTORY) + IF (IER.NE.1) THEN + HELP_DIRECTORY = 'SYS$HELP:' + HLEN = 9 + ELSE IF (HELP_DIRECTORY(HLEN:HLEN).NE.':'.AND. + & HELP_DIRECTORY(HLEN:HLEN).NE.']') THEN + HELP_DIRECTORY = HELP_DIRECTORY(:HLEN)//':' + HLEN = HLEN + 1 + END IF + + LPROMPT = TRIM(COMMAND_PROMPT) + PROMPT = CHAR(10)//COMMAND_PROMPT(:LPROMPT)//' ' + LPROMPT = LPROMPT + 2 + + DO WHILE (1) + + IF (DCL_COMMAND.EQ.0) THEN + CALL GET_INPUT_PROMPT(INCMD,IER,PROMPT(:LPROMPT)) + ELSE + IF (INDEX(DCL_CMD,';').GT.0) THEN + INCMD = DCL_CMD(:INDEX(DCL_CMD,';')-1) + DCL_CMD = DCL_CMD(INDEX(DCL_CMD,';')+1:) + ELSE + INCMD = DCL_CMD + DCL_CMD = ' ' + END IF + IER = TRIM(INCMD) + END IF + + IF (IER.EQ.-2) THEN + IER = RMS$_EOF + ELSE IF (IER.LE.0) THEN + IER = %LOC(CLI$_NOCOMD) + ELSE + DO WHILE (IER.GT.0.AND.INCMD(:1).EQ.' ') + INCMD = INCMD(2:IER) + IER = IER - 1 + END DO + DO WHILE (IER.GT.0.AND. + & INCMD(IER:IER).GE.'0'.AND.INCMD(IER:IER).LE.'9') + IER = IER - 1 + END DO + IF (IER.EQ.0) INCMD = 'READ '//INCMD + IER=CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS,LIB$GET_INPUT) + END IF + + IF (IER.EQ.RMS$_EOF) THEN + CALL EXIT ! If no command, exit + ELSE IF (IER.EQ.%LOC(CLI$_NOCOMD)) THEN ! If just RETURN entered + LEN_P = 0 ! Indicate no parameter in command + IF (DIR_COUNT.GT.0) THEN ! If still more dir entries + CALL DIRECTORY(DIR_COUNT) ! continue outputting them + ELSE IF (INDEX_COUNT.GT.0) THEN + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (FOLDER_COUNT.GT.0) THEN ! If more folder entries + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! continue outputting them + ELSE ! Else try to read next bulletin + CALL READ(READ_COUNT,BULL_POINT+1) ! or finish old one + DIR_COUNT = 0 + FOLDER_COUNT = 0 + INDEX_COUNT = 0 + END IF + GO TO 100 ! Loop to read new command + ELSE IF (.NOT.IER) THEN ! If command has error + GO TO 100 ! ask for new command + END IF + + IER = MIN(INDEX(INCMD(:TRIM(INCMD)),' '),INDEX(INCMD,'/')) + IF (IER.GT.0) INCMD = ' '//INCMD(IER:) ! Save qualifiers + CALL CLI$GET_VALUE('$VERB',INCMD(:4)) ! Get user's command. + + IF (INCMD(:4).EQ.'BACK'.AND.DIR_COUNT.NE.0) THEN + DIR_COUNT = -1 + CALL DIRECTORY(DIR_COUNT) + INCMD = ' ' + ELSE IF (INCMD(:4).EQ.'BACK'.AND.FOLDER_COUNT.NE.0) THEN + FOLDER_COUNT = -1 + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) + INCMD = ' ' + ELSE + DIR_COUNT = 0 ! Reinit display pointers + READ_COUNT = 0 + FOLDER_COUNT = 0 + INDEX_COUNT = 0 + END IF + + IF (READ_ONLY.AND.(INCMD(:3).EQ.'ADD'.OR.INCMD(:3).EQ.'DEL' + & .OR.INCMD(:3).EQ.'CHA'.OR.INCMD(:3).EQ.'REP')) THEN + ! FOLDER can only be read? + WRITE (6,'('' ERROR: Access to folder limited to reading.'')') + ELSE IF (INCMD(:3).EQ.'ADD') THEN ! ADD? + CALL ADD + ELSE IF (INCMD(:3).EQ.'ATT') THEN ! ATTACH? + CALL ATTACH + ELSE IF (INCMD(:4).EQ.'BACK') THEN ! BACK? + IF (BULL_POINT.LE.1) THEN + WRITE(6,1060) + ELSE + CALL READ(READ_COUNT,BULL_POINT-1) ! Try to read previous bull + END IF + ELSE IF (INCMD(:4).EQ.'CHAN') THEN ! CHANGE? + CALL REPLACE ! Replace old bulletin + ELSE IF (INCMD(:4).EQ.'COPY') THEN ! COPY? + CALL MOVE(.FALSE.) + ELSE IF (INCMD(:4).EQ.'CREA') THEN ! CREATE? + CALL CREATE_FOLDER ! Go create the folder + ELSE IF (INCMD(:4).EQ.'CURR') THEN ! CURRENT? + READ_COUNT = -1 ! Reread current message from beginning. + CALL READ(READ_COUNT,BULL_POINT) + ELSE IF (INCMD(:4).EQ.'DELE') THEN ! DELETE? + CALL DELETE ! Go delete bulletin + ELSE IF (INCMD(:4).EQ.'DIRE') THEN ! DIRECTORY? + IF (CLI$PRESENT('FOLDER')) THEN ! /FOLDER specified? + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! Show all folders + ELSE IF (CLI$PRESENT('SELECT_FOLDER')) THEN! Folder specified? + CALL SELECT_FOLDER(.TRUE.,IER) ! Try to select folder + IF (IER) THEN ! If successful + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE IF (INCMD(:4).EQ.'FILE'.OR. + & INCMD(:4).EQ.'EXTR') THEN ! FILE? + CALL FILE ! Copy bulletin to file + ELSE IF (INCMD(:1).EQ.'E'.OR. + & INCMD(:4).EQ.'QUIT') THEN ! EXIT? + CALL EXIT ! Exit from program + ELSE IF (INCMD(:4).EQ.'HELP') THEN ! HELP? + CALL HELP(HELP_DIRECTORY(:HLEN)//'BULL.HLB') ! Get help + ELSE IF (INCMD(:3).EQ.'IND') THEN ! INDEX? + INDEX_COUNT = 1 + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (INCMD(:4).EQ.'LAST') THEN ! LAST? + READ_COUNT = -1 + BULL_READ = 99999 + CALL READ(READ_COUNT,BULL_READ) + ELSE IF (INCMD(:4).EQ.'MARK') THEN ! MARK? + CALL TAG(.TRUE.) + ELSE IF (INCMD(:4).EQ.'MAIL') THEN ! MAIL? + CALL MAIL(MAIL_STATUS) + ELSE IF (INCMD(:3).EQ.'MOD') THEN ! MODIFY? + CALL MODIFY_FOLDER + ELSE IF (INCMD(:4).EQ.'MOVE') THEN ! MOVE? + CALL MOVE(.TRUE.) + ELSE IF (INCMD(:4).EQ.'NEXT') THEN ! NEXT? + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + ELSE IF (INCMD(:4).EQ.'POST') THEN ! POST? + CALL RESPOND(MAIL_STATUS) + ELSE IF (INCMD(:4).EQ.'PRIN') THEN ! PRINT? + CALL PRINT ! Printout bulletin + ELSE IF (INCMD(:4).EQ.'READ') THEN ! READ? + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Bulletin specified? + DECODE(LEN_P,'(I)',BULL_PARAMETER) BULL_READ ! Yes + READ_COUNT = -1 + CALL READ(READ_COUNT,BULL_READ) + ELSE + CALL READ(READ_COUNT,BULL_POINT+1) + END IF + ELSE IF (INCMD(:3).EQ.'REM') THEN ! REMOVE? + CALL REMOVE_FOLDER + ELSE IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + CALL REPLY + ELSE IF (INCMD(:3).EQ.'RES') THEN ! RESPOND? + CALL RESPOND(MAIL_STATUS) + ELSE IF (INCMD(:3).EQ.'SEA') THEN ! SEARCH? + CALL SEARCH(READ_COUNT) + ELSE IF (INCMD(:3).EQ.'SEL') THEN ! SELECT? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (INCMD(:3).EQ.'SET') THEN ! SET? + CALL CLI$GET_VALUE('SET_PARAM1',BULL_PARAMETER) + IF (BULL_PARAMETER(:1).EQ.'F') THEN ! SET FOLDER? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRI') THEN ! SET PRIVS? + CALL SET_PRIV + ELSE IF (BULL_PARAMETER(:2).EQ.'PA') THEN ! SET PAGE? + PAGING = .TRUE. + WRITE (6,'('' PAGE has been set.'')') + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SET KEYPAD? + CALL SET_KEYPAD + ELSE IF (BULL_PARAMETER(:3).EQ.'NOK') THEN ! SET NOKEYPAD? + CALL SET_NOKEYPAD + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPA') THEN ! SET NOPAGE? + PAGING = .FALSE. + WRITE (6,'('' NOPAGE has been set.'')') + ELSE IF (FOLDER_NUMBER.EQ.-1) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + ELSE IF (BULL_PARAMETER(:2).EQ.'SY') THEN ! SET SYSTEM? + CALL SET_SYSTEM(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOSY') THEN ! SET NOSYSTEM? + CALL SET_SYSTEM(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'BB') THEN ! SET BBOARD? + CALL SET_BBOARD(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBB') THEN ! SET NOBBOARD? + CALL SET_BBOARD(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'DU') THEN ! SET DUMP? + CALL SET_FOLDER_FLAG(.TRUE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODU') THEN ! SET NODUMP? + CALL SET_FOLDER_FLAG(.FALSE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:2).EQ.'ST') THEN ! SET STRIP? + CALL SET_FOLDER_FLAG(.TRUE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOST') THEN ! SET NOSTRIP? + CALL SET_FOLDER_FLAG(.FALSE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:2).EQ.'DI') THEN ! SET DIGEST? + CALL SET_FOLDER_FLAG(.TRUE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODI') THEN ! SET NODIGEST? + CALL SET_FOLDER_FLAG(.FALSE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOTI') THEN ! SET NOTIFY? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(1,-1,-1) + ELSE + CALL SET_USER_FLAG(1,-1,-1) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'E') THEN ! SET EXPIRE? + IER = CLI$GET_VALUE('EXPIRATION',BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.3) THEN + READ (BULL_PARAMETER,'(I)') LIMIT + CALL SET_FOLDER_EXPIRE_LIMIT(LIMIT) + ELSE + WRITE (6,'('' ERROR: Invalid expiration specified.'')') + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NODE') THEN ! SET NODE? + CALL SET_NODE(.TRUE.) + ELSE IF (BULL_PARAMETER(:6).EQ.'NONODE') THEN ! SET NONODE? + CALL SET_NODE(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOE') THEN ! SET NOEXPIRE? + CALL SET_FOLDER_EXPIRE_LIMIT(0) + ELSE IF (BULL_PARAMETER(:5).EQ.'NONOT') THEN ! SET NONOTIFY? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(0,-1,-1) + ELSE + CALL SET_USER_FLAG(0,-1,-1) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'S') THEN ! SET SHOWNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,1) + ELSE + CALL SET_USER_FLAG(-1,0,1) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOS') THEN ! SET NOSHOWNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE + CALL SET_USER_FLAG(-1,0,0) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'R') THEN ! SET READNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,1,0) + ELSE + CALL SET_USER_FLAG(-1,1,0) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOR') THEN ! SET NOREADNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE + CALL SET_USER_FLAG(-1,0,0) + END IF + ELSE IF (BULL_PARAMETER(:2).EQ.'BR') THEN ! SET BRIEF? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,1,1) + ELSE + CALL SET_USER_FLAG(-1,1,1) + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBR') THEN ! SET NOBRIEF? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE + CALL SET_USER_FLAG(-1,0,0) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'A') THEN ! SET ACCESS? + CALL SET_ACCESS(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOA') THEN ! SET NOACCESS? + CALL SET_ACCESS(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'C') THEN ! SET CONTINUOUS_BRIEF + CALL SET_BRIEF_CONTINUOUS(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOC') THEN ! SET NOCONTINUOUS_BRIEF + CALL SET_BRIEF_CONTINUOUS(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'G') THEN ! SET GENERIC? + CALL SET_GENERIC(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOG') THEN ! SET NOGENERIC? + CALL SET_GENERIC(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'L') THEN ! SET LOGIN? + CALL SET_LOGIN(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOL') THEN ! SET NOLOGIN? + CALL SET_LOGIN(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRO') THEN ! SET PROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.FALSE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPR') THEN ! SET NOPROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.TRUE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:3).EQ.'DEF') THEN ! SET DEFAULT_EXPIRE? + CALL SET_DEFAULT_EXPIRE + END IF + ELSE IF (INCMD(:4).EQ.'SHOW') THEN ! SHOW? + CALL CLI$GET_VALUE('SHOW_PARAM1',BULL_PARAMETER,LEN_P) + IF (BULL_PARAMETER(:2).EQ.'FL') THEN ! SHOW FLAGS? + CALL SHOW_FLAGS + ELSE IF (BULL_PARAMETER(:2).EQ.'FO') THEN ! SHOW FOLDER? + CALL SHOW_FOLDER + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SHOW KEYPAD + CALL SHOW_KEYPAD(HELP_DIRECTORY(:HLEN)//'BULL.HLB') + ELSE IF (BULL_PARAMETER(:1).EQ.'N') THEN ! SHOW NEW? + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + SAVE_FOLDER = FOLDER + DO FOLDER_NUMBER = 0,FOLDER_MAX-1 + IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + CALL SELECT_FOLDER(.FALSE.,IER) + IF (NBULL.GT.0) THEN + DIFF = COMPARE_BTIM( + & LAST_READ_BTIM(1,FOLDER_NUMBER+1),F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN + WRITE (6,'('' There are new messages in folder '' + & ,A,''.'')') FOLDER(:TRIM(FOLDER)) + END IF + END IF + END IF + END DO + FOLDER1 = SAVE_FOLDER + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE IF (BULL_PARAMETER(:1).EQ.'P') THEN ! SHOW PRIVILEGES? + CALL SHOW_PRIV + ELSE IF (BULL_PARAMETER(:1).EQ.'U') THEN ! SHOW USER? + CALL SHOW_USER + ELSE IF (BULL_PARAMETER(:1).EQ.'V') THEN ! SHOW VERSION? + CALL SHOW_VERSION + END IF + ELSE IF (INCMD(:4).EQ.'SPAW') THEN ! SPAWN command? + CALL SPAWN_PROCESS + ELSE IF (INCMD(:4).EQ.'UNDE') THEN ! UNDELETE? + CALL UNDELETE + ELSE IF (INCMD(:3).EQ.'UNM') THEN ! UNMARK? + CALL TAG(.FALSE.) + END IF + +100 CONTINUE + + IF (DCL_COMMAND.GT.0.AND.TRIM(DCL_CMD).EQ.0) CALL EXIT + + END DO + +1010 FORMAT(Q,A) +1060 FORMAT(' ERROR: There are no more messages.') + + END + + + + + + SUBROUTINE ADD +C +C SUBROUTINE ADD +C +C FUNCTION: Adds bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER INEXDATE*11,INEXTIME*11 + CHARACTER*(LINE_LENGTH) INDESCRIP + + CHARACTER INLINE*80,OLD_FOLDER*25,LOCAL_NODE*8 + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + IF (CLI$PRESENT('EXTRACT')) THEN + IF (.NOT.((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If no /EDIT + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)))) THEN + WRITE (6,'('' ERROR: Cannot extract text without /EDIT.'')') + RETURN + END IF + END IF + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + ALLOW = SETPRV_PRIV() + + OLD_FOLDER_NUMBER = FOLDER_NUMBER + OLD_FOLDER = FOLDER + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + CALL DISABLE_PRIVS + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD',READONLY, + & SHARED,ERR=920,FORM='FORMATTED') ! Try opening the file + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + ELSE IF (CLI$PRESENT('EXTRACT')) THEN + BULL_PARAMETER = 'SYS$LOGIN:BULL.SCR' + LEN_P = TRIM(BULL_PARAMETER) + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH, + & STATUS='NEW',CARRIAGECONTROL='LIST',FORM='FORMATTED') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + +90 CALL CLOSE_BULLFIL + END IF + + SELECT_FOLDERS = .FALSE. + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL GET_FOLDER_INFO(IER) + IF (.NOT.IER) GO TO 910 + SELECT_FOLDERS = .TRUE. + ELSE + NODE_NUM = 1 + NODES(1) = OLD_FOLDER + END IF + + IF (FOLDER_NUMBER.GT.0.AND. ! If folder set and + & CLI$PRESENT('NODES')) THEN ! Decnet nodes specified? + WRITE (6,'('' ERROR: /NODES cannot be used with folder set.'')') + GO TO 910 + END IF + + IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0.AND. + & (CLI$PRESENT('SYSTEM').OR. ! Is /SYSTEM switch present? + & CLI$PRESENT('BROADCAST').OR. ! Is /BROADCAST swtich present? + & CLI$PRESENT('SHUTDOWN'))) THEN ! Is /SHUTDOWN switch present? + WRITE (6,'('' ERROR: Folder is not a SYSTEM folder.'')') + GO TO 910 + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN ! Is /SYSTEM switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1070) ! Tell user + GO TO 910 ! and abort + END IF + SYSTEM = 1 ! Set system bit + ELSE + SYSTEM = 0 ! Clear system bit + END IF + + IF (CLI$PRESENT('BROADCAST')) THEN ! Is /BROADCAST switch present? + IF (.NOT.(ALLOW.OR.OPER_PRIV())) THEN ! If no privileges + WRITE(ERROR_UNIT,1080) ! Tell user + GO TO 910 ! and abort + ELSE IF (CLI$PRESENT('CLUSTER')) THEN + SYSTEM = SYSTEM.OR.8 + END IF + END IF + + IF (CLI$PRESENT('PERMANENT')) THEN ! Is /PERMANENT switch present? + IF (.NOT.ALLOW.AND..NOT.FOLDER_SET) THEN ! If no privileges + WRITE(ERROR_UNIT,1081) ! Tell user + GO TO 910 ! and abort + ELSE IF (F_EXPIRE_LIMIT.GT.0.AND..NOT. ! Expiration limit present + & FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE(ERROR_UNIT,1083) + GO TO 910 + ELSE + SYSTEM = SYSTEM.OR.2 ! Set permanent bit + INEXDATE = '5-NOV-2000' + INEXTIME = '00:00:00.00' + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN ! Is /SHUTDOWN switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1082) ! Tell user + GO TO 910 ! and abort + ELSE + IER = CLI$GET_VALUE('SHUTDOWN',INLINE) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (REMOTE_SET) THEN ! Can't specify node name if + WRITE (6,1090) ! remote folder, as no code + GO TO 910 ! present to send the name. + END IF + CALL GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,INLINE) + IF (NODE_AREA.EQ.0) GO TO 910 ! Invalid node name + ELSE + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + END IF + SYSTEM = SYSTEM.OR.4 ! Set shutdown bit + INEXDATE = '5-NOV-2000' + WRITE (INEXTIME,'(I4)') NODE_NUMBER + WRITE (INEXTIME(7:),'(I4)') NODE_AREA + DO I=1,11 + IF (INEXTIME(I:I).EQ.' ') INEXTIME(I:I) = '0' + END DO + INEXTIME = INEXTIME(1:2)//':'//INEXTIME(3:4)//':'// + & INEXTIME(7:8)//'.'//INEXTIME(9:10) + END IF + END IF + + SELECT_NODES = .FALSE. + IF (CLI$PRESENT('NODES')) THEN + CALL GET_NODE_INFO + IF (NODE_ERROR) GO TO 940 + SELECT_NODES = .TRUE. + END IF + + IF ((SYSTEM.AND.7).LE.1) THEN ! Not permanent or shutdown + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + + IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + INDESCRIP = DESCRIP ! Use description with RE:, + LENDES = TRIM(INDESCRIP) ! filled in by main subroutine + ELSE IF (CLI$PRESENT('SUBJECT')) THEN ! /SUBJECT specified + CALL CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + ELSE + WRITE(6,1050) ! Request header for bulletin + CALL GET_LINE(INDESCRIP,LENDES) ! Get input line + IF (LENDES.LE.0) GO TO 910 + END IF + + LENDES = MIN(LEN(INDESCRIP)-6,LENDES) ! Make room for "Subj: " + +C +C If file specified in ADD command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)).AND. + & .NOT.DECNET_PROC) THEN + IF (LEN_P.EQ.0) THEN ! If no file param specified + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + LEN_P = 1 + ELSE + CLOSE (UNIT=3) + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + END IF + END IF + + ICOUNT = 0 ! Line count for bulletin + + IF (LEN_P.GT.0) THEN ! If file param in ADD command + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + ICOUNT = ICOUNT + 1 + MIN(ILEN,80) + IF (ILEN.EQ.0) ICOUNT = ICOUNT + 1! COPY_BULL writes line with + END DO ! 1 space for blank line + ELSE ! If no input file + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) ! Temp file to save message + WRITE (6,1000) ! Request input from terminal + ILEN = LINE_LENGTH + 1 ! Length of input line + ICOUNT = 0 ! Character count counter + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Input line too long + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput:'')') LINE_LENGTH + ELSE IF (ILEN.GE.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN ! Update counter + WRITE(3,2010) INPUT(:ILEN) ! Save line in scratch file + END IF + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + REWIND (UNIT=3) + + IF (SELECT_NODES.AND.NODE_NUM.GT.0) THEN + INLINE = 'ADD' + IF (CLI$PRESENT('SYSTEM')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SYSTEM' + IF (CLI$PRESENT('BROADCAST')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BROADCAST' + IF (CLI$PRESENT('PERMANENT')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/PERMANENT' + IF (CLI$PRESENT('SHUTDOWN')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SHUTDOWN' + IF (CLI$PRESENT('BELL')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BELL' + + LEN_INLINE = STR$POSITION(INLINE,' ') - 1 + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + INLINE = INLINE(:LEN_INLINE) + + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + IF ((SYSTEM.AND.7).LE.1) + ! If not permanent or shutdown specify date + & WRITE (POINT_NODE+9,'(A)',ERR=940) INEXDATE//' '//INEXTIME + WRITE (POINT_NODE+9,'(A)',ERR=940) INDESCRIP(:LENDES) + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + ILEN = MIN(ILEN,LINE_LENGTH) + IF (IER.EQ.0) THEN + WRITE (POINT_NODE+9,'(A)',ERR=940) INPUT(:ILEN) + END IF + END DO + WRITE (POINT_NODE+9,'(A)',ERR=940) CHAR(26) + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INPUT + IF (INPUT.EQ.'END') THEN + WRITE (6,'('' Message successfully sent to node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while sending message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INPUT(:80) + GO TO 940 + END IF + REWIND (UNIT=3) + END DO + END IF + + IF (SELECT_NODES.AND..NOT.LOCAL_NODE_FOUND) GO TO 95 + ! Exit if local node not specified. + + IF (.NOT.SELECT_FOLDERS) THEN + NODE_NUM = 1 ! No folders specified so just + NODES(1) = FOLDER ! add to select folder + END IF + + IER = SYS_TRNLNM('SYS$NODE',LOCAL_NODE) + LNODE = TRIM(LOCAL_NODE) + LUSER = TRIM(USERNAME) + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + BRDCST = .FALSE. + + DO I = 1,NODE_NUM + + IF (FOLDER.NE.NODES(I)) THEN + FOLDER_NUMBER = -1 + FOLDER1 = NODES(I) + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE + IER = 1 + END IF + + IF (IER) THEN + CALL OPEN_BULLDIR ! Prepare to add dir entry + + DESCRIP=INDESCRIP(:LENDES) ! Description header + EXDATE=INEXDATE ! Expiration date + EXTIME=INEXTIME + FROM = USERNAME ! Username + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + REWIND (UNIT=3) + OBLOCK = NBLOCK+1 + CALL STORE_BULL(LNODE+LUSER+6,'From: '// + & LOCAL_NODE(:LNODE)//USERNAME(:LUSER),OBLOCK) + IF (LENDES.GT.LEN(DESCRIP)) THEN + CALL STORE_BULL(LENDES+6, + & 'Subj: '//INDESCRIP(:LENDES),OBLOCK) + END IF + CALL COPY_BULL(3,1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) GO TO 930 ! Error in creating bulletin + LENGTH = OCOUNT - (NBLOCK+1) + 1 +C +C Broadcast the bulletin if requested. +C + IF (.NOT.BRDCST.AND.CLI$PRESENT('BROADCAST').AND. + & (.NOT.REMOTE_SET.OR.FOLDER_NUMBER.GT.0)) THEN + CALL GET_BROADCAST_MESSAGE(CLI$PRESENT('BELL')) + BRDCST = .TRUE. + IF (.NOT.CLI$PRESENT('LOCAL')) THEN + CALL BROADCAST_ALL_NODES(CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER')) + END IF + CALL BROADCAST( + & CLI$PRESENT('ALL'),CLI$PRESENT('CLUSTER')) + END IF + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CALL ADD_ENTRY ! Add the new directory entry + + IF (FOLDER_NUMBER.GE.0) THEN + CALL UPDATE_FOLDER ! Update info in folder file +C +C If user is adding message, update that user's last read time for +C folder, so user is not alerted of new message which is owned by user. +C + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + ELSE + WRITE (6,'('' ERROR: Unable to add message to '',A)') + & NODES(I) + END IF + END DO + +95 CLOSE (UNIT=3) ! Close the input file + IF (DECNET_PROC) WRITE(5,'(''END'')') ! DECNET operation worked + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + DO I=10,NODE_NUM+9 + CLOSE (UNIT=I) + END DO + + IF (FOLDER_NUMBER.NE.OLD_FOLDER_NUMBER) THEN + FOLDER_NUMBER = OLD_FOLDER_NUMBER + FOLDER1 = OLD_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + + IF (CLI$PRESENT('EXTRACT')) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + +910 WRITE(ERROR_UNIT,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(6,1020) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + GOTO 100 + +930 WRITE (ERROR_UNIT,1025) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + +940 WRITE (6,1015) NODES(POINT_NODE) + WRITE (6,1018) + CLOSE (UNIT=3) + GO TO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1010 FORMAT (' No message was added.') +1015 FORMAT (' ERROR: Unable to reach node ',A) +1018 FORMAT (' Try using /FOLDER instead of /NODE.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1025 FORMAT (' ERROR: Unable to add message to file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1070 FORMAT (' ERROR: SETPRV privileges are needed for system + & messages.') +1080 FORMAT (' ERROR: SETPRV privileges are needed to broadcast + & messages.') +1081 FORMAT (' ERROR: SETPRV privileges are needed to permanent + & messages.') +1082 FORMAT (' ERROR: SETPRV privileges are needed to shutdown + & messages.') +1083 FORMAT (' ERROR: Folder has expiration limit.') +1090 FORMAT (' ERROR: Nodename cannot be specified for shutdown + & if folder is remote.') +2010 FORMAT(A) +2020 FORMAT(1X,A) + + END + + + SUBROUTINE SUBTIME(BTIM,DAYS_BEFORE_TODAY,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER DAYS_BEFORE_TODAY*(*),TODAY_DATE*23 + + INTEGER BTIM(2),TODAY_BTIM(2) + + IER = SYS$BINTIM(DAYS_BEFORE_TODAY,BTIM) + IF (.NOT.IER) RETURN + + BTIM(1) = -BTIM(1) ! Convert to negative delta time + BTIM(2) = -BTIM(2)-1 + + IER = SYS$ASCTIM(TLEN,TODAY_DATE,,) + CALL SYS$BINTIM(TODAY_DATE(:TLEN),TODAY_BTIM) + + CALL LIB$SUBX(TODAY_BTIM,BTIM,BTIM) + + RETURN + END + + + + SUBROUTINE BROADCAST_ALL_NODES(ALL,CLUSTER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + COMMON /BROAD_MESSAGE/ BMESSAGE,BLENGTH + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER LOCALNODE*8,RESPONSE*1 + + IF (.NOT.TEST_BULLCP().OR.REMOTE_SET) RETURN + + CALL OPEN_BULLUSER_SHARED + + REMOTE_FOUND = .FALSE. + TEMP_USER = ':' + + DO WHILE (.NOT.REMOTE_FOUND) + DO WHILE (REC_LOCK(IER)) + READ (4,KEYGT=TEMP_USER,IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM,NEW_FLAG + END DO + IF (TEMP_USER(:1).NE.':') THEN + CALL CLOSE(4) + RETURN + END IF + REMOTE_FOUND = TEST2(NEW_FLAG,FOLDER_NUMBER) + END DO + + CALL CLOSE (4) + +100 OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=NODENAME(:TRIM(NODENAME))//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IER = 0 + I = 1 + DO WHILE (IER.EQ.0.AND.I.LT.BLENGTH) + WRITE (17,'(4A)',IOSTAT=IER) + & 15,-1,I,BMESSAGE(I:MIN(BLENGTH,I+127)) + I = I + 128 + END DO + IF (IER.EQ.0) WRITE (17,'(7A)',IOSTAT=IER) + & 15,BLENGTH,I,ALL,CLUSTER,FOLDER_NUMBER,FOLDER + ELSE + WRITE (6,'('' BULLCP not responding to request to'', + & '' broadcast to other nodes.'')') + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Want to try again? (Y/N with Y as default): ') + IF (RESPONSE.NE.'n'.AND.RESPONSE.NE.'N') THEN + WRITE (6,'('' Trying again...'')') + GO TO 100 + ELSE + WRITE (6,'('' Broadcast aborting. '', + & ''Continuing with message addition.'')') + END IF + END IF + + CLOSE (UNIT=17) + + RETURN + END + + + + + INTEGER FUNCTION ERROR_TRAP + + ERROR_TRAP = 1 + + RETURN + END + + + + SUBROUTINE REPLY + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLDIR.INC' + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + WRITE (6,'('' Adding REPLY message with the subject:'')') + CALL STR$UPCASE(BULL_PARAMETER,DESCRIP) + IF (BULL_PARAMETER(:3).NE.'RE:') THEN + DESCRIP = 'RE: '//DESCRIP + ELSE + DESCRIP = 'RE:'//DESCRIP(4:) + END IF + WRITE (6,'(1X,A)') DESCRIP + CALL ADD + + RETURN + END + + + + + SUBROUTINE CRELNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PSLDEF)' + + INCLUDE '($LNMDEF)' + + CHARACTER*(*) INPUT,OUTPUT + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT)) + CALL END_ITMLST(CRELNM_ITMLST) + + IER = SYS$CRELNM(,'LNM$PROCESS',INPUT,PSL$C_USER, + & %VAL(CRELNM_ITMLST)) + + RETURN + END + + + + SUBROUTINE GETPRIV +C +C SUBROUTINE GETPRIV +C +C FUNCTION: +C To get process privileges. +C OUTPUTS: +C PROCPRIV - Returned privileges +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /REALPROC/ REALPROCPRIV(2) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(8,JPI$_PROCPRIV,%LOC(PROCPRIV)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + REALPROCPRIV(1) = PROCPRIV(1) + REALPROCPRIV(2) = PROCPRIV(2) + + RETURN + END + + + + + LOGICAL FUNCTION SETPRV_PRIV + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + DATA NEEDPRIV/0,0/ + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (NEEDPRIV(1).EQ.0.AND.NEEDPRIV(2).EQ.0) THEN + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + CALL CLOSE_BULLUSER + NEEDPRIV(1) = USERPRIV(1) + NEEDPRIV(2) = USERPRIV(2) + END IF + + IF ((PROCPRIV(1).AND.NEEDPRIV(1)).GT.0.OR. + & (PROCPRIV(2).AND.NEEDPRIV(2)).GT.0) THEN + SETPRV_PRIV = .TRUE. + ELSE + SETPRV_PRIV = .FALSE. + END IF + + RETURN + END + + + + LOGICAL FUNCTION OPER_PRIV + IMPLICIT INTEGER (A-Z) + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + INCLUDE '($PRVDEF)' + OPER_PRIV = BTEST(PROCPRIV(1),PRV$V_OPER) + RETURN + END + + + + SUBROUTINE GETUSER(USERNAME) +C +C SUBROUTINE GETUSER +C +C FUNCTION: +C To get username of present process. +C OUTPUTS: +C USERNAME - Username owner of present process. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + CHARACTER*(*) USERNAME ! Limit is 12 characters + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + RETURN + END + + + SUBROUTINE SPAWN_PROCESS + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($UAIDEF)' + + COMMON /KEYPAD/ KEYPAD_MODE + + CHARACTER*255 COMMAND + + DATA CAPTIVE /0/ + + IF (CAPTIVE.EQ.0) THEN + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL END_ITMLST(GETUAI_ITMLST) ! Get address of itemlist + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) + CAPTIVE = 1 + IF ((FLAGS.AND.UAI$M_CAPTIVE).NE.0) CAPTIVE = -1 + END IF + + IF (CAPTIVE.EQ.-1) THEN + WRITE (6,'('' ERROR: SPAWN not allowed from CAPTIVE account.'')') + RETURN + END IF + + CALL DISABLE_PRIVS + + SAVE_KEYPAD_MODE = KEYPAD_MODE + IF (KEYPAD_MODE.EQ.0) CALL SET_KEYPAD + + IF (CLI$PRESENT('COMMAND')) THEN + CALL CLI$GET_VALUE('COMMAND',COMMAND,CLEN) + CALL LIB$SPAWN('$'//COMMAND(:CLEN)) + ELSE + CALL LIB$SPAWN() + END IF + + IF (SAVE_KEYPAD_MODE.EQ.0) CALL SET_NOKEYPAD + + CALL ENABLE_PRIVS + + RETURN + END + + + SUBROUTINE ATTACH + + IMPLICIT INTEGER (A - Z) + + COMMON /KEYPAD/ KEYPAD_MODE + + COMMON /TERM_CHAN/ TERM_CHAN + + INCLUDE '($JPIDEF)' + + CHARACTER*15 PROCESS + + IF (CLI$PRESENT('PROCESS')) THEN + CALL CLI$GET_VALUE('PROCESS',PROCESS,PLEN) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,JPI$_PID,%LOC(PROCESS_ID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,PROCESS(:PLEN),%VAL(GETJPI_ITMLST),,,,) + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,JPI$_OWNER,%LOC(PROCESS_ID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) + END IF + + IER = SYS$CANCEL(%VAL(TERM_CHAN)) + + SAVE_KEYPAD_MODE = KEYPAD_MODE + IF (KEYPAD_MODE.EQ.0) CALL SET_KEYPAD + + IF (IER) IER = LIB$ATTACH(PROCESS_ID) + IF (.NOT.IER) CALL SYS_GETMSG(IER) + + IF (SAVE_KEYPAD_MODE.EQ.0) CALL SET_NOKEYPAD + + RETURN + END + + + + + + SUBROUTINE GET_BROADCAST_MESSAGE(RING_BELL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($BRKDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + +C +C The largest message that can be broadcasted is dependent on system +C and user quotas. The following limit is 12 lines of ( 80 characters + +C CR/LF ) + 2 bells. This should be more than enough room, as broadcasts +C shouldn't be too large anyway. +C + + PARAMETER CR=CHAR(13),LF=CHAR(10),BELL=CHAR(7) + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BROAD + + COMMON /BROAD_MESSAGE/ BROAD,BLENGTH + + IF (RING_BELL) THEN ! Include BELL in message? + BROAD(:36) = ! Say who the bulletin is from + & BELL//BELL//CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 37 ! Start adding next line here + ELSE + BROAD(:34) = ! Say who the bulletin is from + & CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 35 ! Start adding next line here + END IF + + IF (REMOTE_SET) REWIND (UNIT=3) + + END = 0 + ILEN = LINE_LENGTH + 1 + I = 0 + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (REMOTE_SET) THEN + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0) RETURN + ELSE + CALL GET_BULL_LINE(NBLOCK+1,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0) I = I + 1 + IF (ILEN.GT.0.AND.(I.GT.2.OR.(INPUT(:6).NE.'From: '.AND. + & INPUT(:6).NE.'Subj: '))) THEN + END = BLENGTH + ILEN - 1 + 2 ! Check how long string will be + IF (END.GT.BRDCST_LIMIT) RETURN ! String too long? + BROAD(BLENGTH:END) = CR//LF//INPUT(:ILEN)! Else add new input + BLENGTH = END + 1 ! Reset pointer + END IF + END DO + + RETURN + + ENTRY BROADCAST(ALL,CLUSTER) + + CALL SYS$SETRWM(%VAL(1)) ! Don't wait if can't broadcast + + IF (ALL) THEN ! Should we broadcast to ALL? + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,,,,,) + END IF + ELSE ! Else just broadcast to users. + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,,,,,) + END IF + END IF + + CALL SYS$SETRWM(%VAL(0)) + + RETURN + END + + + SUBROUTINE GET_FOLDER_INFO(IER) +C +C SUBROUTINE GET_FOLDER_INFO +C +C FUNCTION: Obtains & verifies folder names from command line. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + CHARACTER NODE_TEMP*256 + + NODE_NUM = 0 ! Initialize number of nodes + DO WHILE (CLI$GET_VALUE('SELECT_FOLDER',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(:COMMA-1) + NODE_TEMP = NODE_TEMP(COMMA+1:) + ELSE + NODES(NODE_NUM) = NODE_TEMP + NODE_TEMP = ' ' + END IF + NLEN = TRIM(NODES(NODE_NUM)) + IF (NODES(NODE_NUM)(NLEN-1:NLEN).EQ.'::') THEN + NODES(NODE_NUM) = NODES(NODE_NUM)(:NLEN)//'GENERAL' + END IF + FOLDER_NUMBER = -1 + FOLDER1 = NODES(NODE_NUM) + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' Unable to access folder '',A)') + & NODES(NODE_NUM) + RETURN + ELSE IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No write access for folder '',A)') + & NODES(NODE_NUM) + IER = 0 + RETURN + END IF + END DO + END DO + + IER = 1 + + RETURN + END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin0.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin0.for new file mode 100644 index 0000000..51b0be0 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin0.for @@ -0,0 +1,1636 @@ +C +C BULLETIN0.FOR, Version 11/27/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE DELETE +C +C SUBROUTINE DELETE +C +C FUNCTION: Deletes a bulletin entry from the bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER ANSWER*1,REMOTE_USER*12,SUBJECT*53 + + INTEGER NOW(2) + + IMMEDIATE = 0 + IF (CLI$PRESENT('IMMEDIATE')) IMMEDIATE = 1 + + IF (CLI$PRESENT('NODES')) THEN ! Delete messages on DECNET node? + CALL DELETE_NODE ! Yes... + RETURN + ELSE IF (DECNET_PROC) THEN ! Is this from remote node? + IER = CLI$GET_VALUE('SUBJECT',SUBJECT,SLEN) + CALL STR$UPCASE(SUBJECT,SUBJECT) + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + DEL_BULL = 0 + IER = 1 + DO WHILE (DEL_BULL+1.EQ.IER) + DEL_BULL = DEL_BULL + 1 + CALL READDIR(DEL_BULL,IER) + CALL STR$UPCASE(DESCRIP,DESCRIP) + IF (DEL_BULL+1.EQ.IER.AND.USERNAME.EQ.FROM + & .AND.INDEX(DESCRIP,SUBJECT(:SLEN)).GT.0) THEN + CALL REMOVE_ENTRY(DEL_BULL,DEL_BULL,DEL_BULL,IMMEDIATE) + CALL CLOSE_BULLDIR + WRITE (5,'(''END'')') ! Tell DECNET that delete went ok. + RETURN + END IF + END DO + CALL CLOSE_BULLDIR ! Specified message not found, + WRITE(ERROR_UNIT,1030) ! so error out. + RETURN + END IF + +C +C Get the bulletin number to be deleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT ! Delete the file we are reading + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1020) + RETURN + ELSE IF (EBULL.GT.F_NBULL.AND..NOT.REMOTE_SET.AND. + & SBULL.NE.EBULL) THEN + WRITE (6,'('' Last message specified > number in folder.'')') + WRITE (6,'('' Do you want to delete to end of folder? '',$)') + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') THEN + WRITE (6,'('' Deletion aborted.'')') + RETURN + ELSE + EBULL = F_NBULL + END IF + END IF + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + IF (REMOTE_SET) THEN + IF (SBULL.NE.EBULL) THEN + WRITE (6,1025) + RETURN + END IF + IF (SBULL.NE.BULL_POINT) CALL READDIR(SBULL,IER) + WRITE(REMOTE_UNIT,'(4A)',IOSTAT=IER) + & 4,SBULL,IMMEDIATE,DESCRIP + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,INPUT,F1_NEWEST_BTIM,) + NEWEST_EXDATE = INPUT(1:11) + NEWEST_EXTIME = INPUT(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + RETURN + END IF + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + DO BULL_DELETE = SBULL,EBULL + CALL READDIR(BULL_DELETE,IER) ! Get info for bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges? + & (.NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER) + & .AND.FOLDER_SET)) THEN + WRITE(6,1040) ! No, then error out. + CALL CLOSE_BULLDIR + RETURN + ELSE IF (SBULL.EQ.EBULL) THEN + CALL CLOSE_BULLDIR + WRITE (6,1050) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') RETURN + CALL OPEN_BULLDIR + CALL READDIR(BULL_DELETE,IER) + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + END IF + +C +C Delete the bulletin directory entry. +C + CALL REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + END DO + + CALL CLOSE_BULLDIR + RETURN + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1025 FORMAT(' ERROR: Cannot delete multiple messages in remote folder.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not deleted. Not owned by you.') +1050 FORMAT(' Message is not owned by you.', + & ' Are you sure you want to delete it? ',$) + + END + + + + SUBROUTINE REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + INTEGER NOW(2) + + IF (IMMEDIATE.EQ.1) THEN ! Delete it immediately + + CALL DELETE_ENTRY(BULL_DELETE) ! Delete the directory entry + + IF ((SYSTEM.AND.4).EQ.4) THEN ! Was entry shutdown bulletin? + SHUTDOWN = SHUTDOWN - 1 ! Decrement shutdown count + END IF + ELSE ! Delete it eventually +C +C Change year of expiration date of message to 100 years less, +C to indicate that message is to be deleted. Then, set expiration date +C in header of folder to 15 minutes from now. Thus, the folder will be +C checked in 15 minutes (or more), and will delete the messages then. +C +C NOTE: If some comic set their expiration date to > 1999, then +C the deleted date will be set to 1899 since can't specify date <1859. +C + + IF ((SYSTEM.AND.7).LE.1) THEN ! General or System message + EXDATE = EXDATE(1:7)//'18'//EXDATE(10:) + IF (EXDATE(10:10).LT.'6') EXDATE(10:11) = '99' + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(1:6)//'19'//EXDATE(9:) + ELSE + EXDATE = EXDATE(1:7)//'19'//EXDATE(10:) + END IF + END IF + + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + + IER = SYS$BINTIM('0 0:15',EX_BTIM) ! Get time 15 minutes from now + IER = SYS$GETTIM(NOW) + IER = LIB$SUBX(NOW,EX_BTIM,EX_BTIM) + IER = SYS$ASCTIM(,INPUT,EX_BTIM,) + + END IF + + IF (IMMEDIATE.NE.1.AND.BULL_DELETE.EQ.EBULL) THEN + CALL READDIR(0,IER) ! Get header + + NEWEST_EXDATE = INPUT(1:11) ! and store new expiration date + NEWEST_EXTIME = INPUT(13:) + + CALL WRITEDIR(0,IER) + ELSE IF (BULL_DELETE.EQ.EBULL) THEN + CALL CLEANUP_DIRFILE(SBULL) ! Reorder directory file + + CALL UPDATE_ALWAYS ! Somewhat a kludgey way of updating latest + ! bulletin and expired dates. + + IF (SBULL.LE.BULL_POINT) THEN + IF (BULL_POINT.GT.EBULL) THEN + BULL_POINT = BULL_POINT - (EBULL - SBULL + 1) + ELSE + BULL_POINT = SBULL + END IF + END IF ! Readjust where which bulletin to read next + ! if deletion causes messages to be moved. + END IF + + RETURN + END + + + + + + SUBROUTINE GET_2_VALS(INPUT,ILEN,SVAL,EVAL,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + CHARACTER*(*) INPUT + + DELIM = MAX(INDEX(INPUT,':'),INDEX(INPUT,'-')) + + IF (DELIM.EQ.0) THEN + DECODE(ILEN,'(I)',INPUT,IOSTAT=IER) SVAL + EVAL = SVAL + ELSE + DECODE(DELIM-1,'(I)',INPUT,IOSTAT=IER) SVAL + CALL STR$UPCASE(INPUT,INPUT) + IF (IER.NE.0) THEN + IF (INDEX('CURRENT',INPUT(:DELIM-1)).EQ.1) THEN + SVAL = BULL_POINT + IER = 0 + END IF + END IF + IF (IER.EQ.0) THEN + ILEN = ILEN - DELIM + DECODE(ILEN,'(I)',INPUT(DELIM+1:),IOSTAT=IER) EVAL + IF (IER.NE.0) THEN + IF (INDEX('LAST',INPUT(DELIM+1:TRIM(INPUT))).EQ.1) THEN + EVAL = F_NBULL + IER = 0 + ELSE IF (INDEX('CURRENT', + & INPUT(DELIM+1:TRIM(INPUT))).EQ.1) THEN + EVAL = BULL_POINT + IER = 0 + END IF + END IF + END IF + IF (EVAL.LT.SVAL) IER = 2 + END IF + + RETURN + END + + + + SUBROUTINE DIRECTORY(DIR_COUNT) +C +C SUBROUTINE DIRECTORY +C +C FUNCTION: Display directory of messages. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + DATA SCRATCH_D1/0/ + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /CLOSE_FILES_INFO/ CLOSED_FILES + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED,CLI$_PRESENT,CLOSE_FILES + + CHARACTER START_PARAMETER*16,DATETIME*23,SEARCH_STRING*80 + + INTEGER TODAY(2) + + CHARACTER*9 EXPIRES + + CHARACTER TIMBUF*13 + DATA TIMBUF/'0 00:00:05.00'/ + + INTEGER TIMADR(2) ! Buffer containing time + + DATA WAITEFN /0/ + + IF (WAITEFN.EQ.0) CALL LIB$GET_EF(WAITEFN) + IER=SYS$BINTIM(TIMBUF,TIMADR) + + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + IF (INCMD(:3).EQ.'DIR'.AND..NOT.READ_TAG) THEN + SUBJECT = CLI$PRESENT('SUBJECT') + REPLY = CLI$PRESENT('REPLY') + REPLY_FIRST = REPLY + SEARCH = CLI$PRESENT('SEARCH') + IF (.NOT.CLI$PRESENT('SELECT_FOLDER').AND. + & CLI$PRESENT('MARKED')) THEN + IF (FOLDER_NUMBER.GE.0) THEN + READ_TAG = .TRUE. + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + ELSE + WRITE (6,'('' ERROR: Cannot use /MARKED with'', + & '' remote folder.'')') + RETURN + END IF + END IF + END IF + +C +C Directory listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C directory file, and to avoid the possibility of the user holding the screen, +C and thus causing the directory file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + CALL INIT_QUEUE(SCRATCH_D1,BULLDIR_ENTRY) + SCRATCH_D = SCRATCH_D1 + + CALL OPEN_BULLDIR_SHARED ! Get directory file + + CALL READDIR(0,IER) ! Does directory header exist? + IF (IER.EQ.1.AND.NBULL.GT.0) THEN ! And are there messages? + IF (DIR_COUNT.EQ.0) THEN + EXPIRATION = CLI$PRESENT('EXPIRATION') + IF (CLI$PRESENT('START')) THEN ! Start number specified? + IER = CLI$GET_VALUE('START',START_PARAMETER,ILEN) + DECODE(ILEN,'(I)',START_PARAMETER) DIR_COUNT + IF (DIR_COUNT.GT.NBULL) THEN + DIR_COUNT = NBULL + ELSE IF (DIR_COUNT.LT.1) THEN + WRITE (6,'('' ERROR: Invalid starting message.'')') + CALL CLOSE_BULLDIR + DIR_COUNT = 0 + RETURN + END IF + ELSE IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + IF (CLI$PRESENT('SINCE')) THEN ! Was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present in'', + & '' folder '',A,''.'')') FOLDER(:TRIM(FOLDER)) + CALL CLOSE_BULLDIR + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + END IF + + CALL READDIR_KEYGE(IER) + + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + CALL CLOSE_BULLDIR + RETURN + ELSE + DIR_COUNT = IER + END IF + ELSE + DIR_COUNT = BULL_POINT + IF (DIR_COUNT.EQ.0) DIR_COUNT = 1 + END IF + + IF (CLI$PRESENT('SEARCH')) THEN + IER1 = CLI$GET_VALUE('SEARCH',SEARCH_STRING,SLEN) + ELSE IF (CLI$PRESENT('SUBJECT')) THEN + IER1 = CLI$GET_VALUE('SUBJECT',SEARCH_STRING,SLEN) + ELSE IF (CLI$PRESENT('REPLY')) THEN + SEARCH_STRING = ' ' + END IF + + IF (READ_TAG) THEN + IF (SUBJECT.OR.REPLY.OR.SEARCH) THEN + WRITE (6,'('' ERROR: Qualifier not valid when '', + & ''displaying only MARKED messages.'')') + SUBJECT = .FALSE. + REPLY = .FALSE. + SEARCH = .FALSE. + CALL CLOSE_BULLDIR + RETURN + END IF + IF (.NOT.(CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW') + & .OR.CLI$PRESENT('START'))) THEN + DIR_COUNT = 1 + END IF + CALL READDIR(DIR_COUNT,IER1) + IF (IER1.EQ.DIR_COUNT+1) IER1 = 0 + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + END IF + + IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + ELSE IF (NBULL-DIR_COUNT+1.LE.PAGE_LENGTH-5) THEN + EBULL = NBULL + SBULL = NBULL - (PAGE_LENGTH-5) + 1 + IF (SBULL.LT.1) SBULL = 1 + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + END IF + ELSE IF (DIR_COUNT.EQ.-1.AND..NOT.READ_TAG) THEN + SUBJECT = .FALSE. + REPLY = .FALSE. + SEARCH = .FALSE. + SBULL = (SBULL - 1) - ((PAGE_LENGTH - 7) - 1) + IF (SBULL.LT.1) SBULL = 1 + EBULL = SBULL + (PAGE_LENGTH - 7) - 1 + IF (NBULL-SBULL+1.LE.PAGE_LENGTH-5) THEN + SBULL = NBULL - (PAGE_LENGTH-5) + 1 + EBULL = NBULL + IF (SBULL.LT.1) SBULL = 1 + END IF + ELSE IF (DIR_COUNT.EQ.-1.AND.READ_TAG) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,FIRST_BULL) + FIRST_BULL = FIRST_BULL + 1 + IER1 = 0 + IER = 0 + FBULL = 0 + DO WHILE (SBULL.GT.FIRST_BULL.AND.IER.EQ.0) + SBULL = SBULL - 1 + CALL READDIR(SBULL,IER) + IF (IER.EQ.SBULL+1) THEN + CALL GET_THIS_TAG(FOLDER_NUMBER,IER,DIR_COUNT) + IF (IER.EQ.0) THEN + IF (FBULL.EQ.0) THEN + EBULL = DIR_COUNT + FBULL = EBULL + 1 + END IF + FBULL = FBULL - 1 + IF (EBULL-FBULL.EQ.(PAGE_LENGTH-7)-1) THEN + IER = 1 + END IF + ELSE + IER = 0 + END IF + ELSE + IER = 1 + END IF + END DO + IF (FBULL.EQ.FIRST_BULL) THEN + CALL READDIR(EBULL,IER) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DIR_COUNT) + DO WHILE (IER.EQ.0.AND.EBULL-FBULL.LT.(PAGE_LENGTH-7)-1) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DIR_COUNT) + IF (IER.EQ.0) EBULL = EBULL + 1 + END DO + DO I=1,3 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DIR_COUNT) + END DO + IF (IER.NE.0) EBULL = DIR_COUNT + END IF + CALL READDIR(EBULL,IER) + IF (EBULL+1.NE.IER) THEN + EBULL = EBULL + 1 + ELSE + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DUMMY) + IF (IER.NE.0) EBULL = EBULL + 1 + END IF + CALL READDIR(SBULL,IER) + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + END IF + IF (.NOT.PAGING) THEN + EBULL = NBULL + END IF + IF (SUBJECT.OR.REPLY.OR.SEARCH) THEN + CONTINUE + ELSE IF (.NOT.REMOTE_SET.AND..NOT.READ_TAG) THEN + DO I = SBULL,EBULL + CALL READDIR(I,IER) ! Into the queue + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + END DO + ELSE IF (READ_TAG) THEN + I = 0 + DO WHILE (I.LE.EBULL.AND.IER1.EQ.0) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,DIR_COUNT) + IF (I.EQ.0.AND.IER1.EQ.0) THEN + SBULL = DIR_COUNT + I = SBULL + END IF + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + I = I + 1 + END DO + EBULL = I - 1 + IF (IER1.NE.0) THEN + EBULL = EBULL - 1 + ELSE + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,DUMMY) + IF (IER1.EQ.0) THEN + IER = 0 + EBULL_SAVE = EBULL + DO I=1,2 + IF (IER.EQ.0) THEN + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D, + & BULLDIR_ENTRY) + EBULL = EBULL + 1 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DUMMY) + END IF + END DO + IF (IER.NE.0) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,FIRST_BULL) + IF (SBULL.NE.FIRST_BULL+1) EBULL = EBULL_SAVE + IER1 = 1 + ELSE + EBULL = EBULL_SAVE + END IF + END IF + END IF + ELSE + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,SBULL,EBULL + IF (IER.EQ.0) THEN + I = SBULL + DO WHILE (IER.EQ.0.AND.I.LE.EBULL) + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + I = I + 1 + END DO + END IF + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + RETURN + END IF + END IF + ELSE + NBULL = 0 + END IF + + IF (NBULL.EQ.0) THEN + CALL CLOSE_BULLDIR ! We don't need file anymore + WRITE (6,'('' There are no messages present.'')') + RETURN + END IF + +C +C Directory entries are now in queue. Output queue entries to screen. +C + + FLEN = TRIM(FOLDER) + WRITE(6,'(X,A)') FOLDER(:FLEN) + IF (EXPIRATION) THEN + WRITE(6,1005) ! Write header + ELSE + WRITE(6,1000) ! Write header + END IF + N = 3 + + IF (.NOT.(SUBJECT.OR.REPLY.OR.SEARCH).AND. + & BULL_TAG.AND..NOT.READ_TAG) THEN + IF (INCMD(1:3).NE.' ') THEN + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + DO I=SBULL,EBULL + SAVE_SCRATCH_D = SCRATCH_D + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + IF (BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG) THEN + MSG_NUM = -MSG_NUM + CALL WRITE_QUEUE(%VAL(SAVE_SCRATCH_D),DUMMY,BULLDIR_ENTRY) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + END DO + END IF + + CALL CLOSE_BULLDIR ! We don't need file anymore + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + + I = SBULL + START_SEARCH = I + IF (.NOT.REPLY_FIRST) START_SEARCH = I - 1 + IF (SUBJECT.OR.REPLY.OR.SEARCH) THEN + CALL OPEN_BULLDIR_SHARED + IF (SEARCH) CALL OPEN_BULLFIL_SHARED + CLOSED_FILES = .FALSE. + END IF + DO WHILE (I.LE.EBULL) + IF (.NOT.(SUBJECT.OR.REPLY.OR.SEARCH)) THEN + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + ELSE + IF (CLOSED_FILES) THEN + CLOSED_FILES = .FALSE. + CALL OPEN_BULLDIR_SHARED + IF (SEARCH) CALL OPEN_BULLFIL_SHARED + END IF + CALL GET_SEARCH(FOUND,SEARCH_STRING,START_SEARCH,.FALSE. + & ,SUBJECT,REPLY_FIRST,.FALSE.,.TRUE.) + IF (INCMD(1:3).NE.' '.AND.BULL_TAG.AND.FOUND.GT.0) THEN + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + CALL READDIR(FOUND,IER) + END IF + REPLY_FIRST = .FALSE. + IF (FOUND.GT.0) THEN + SEARCH_STRING = ' ' + START_SEARCH = FOUND + IF (BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG) THEN + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + CALL READDIR(FOUND,IER) + MSG_NUM = -MSG_NUM + END IF + ELSE + I = EBULL + 1 + END IF + IER = SYS$SETIMR(%VAL(WAITEFN),TIMADR,CLOSE_FILES,) + END IF + IF (I.LE.EBULL) THEN + CALL CONVERT_ENTRY_FROMBIN + IF (MSG_NUM.LT.0.OR.READ_TAG) THEN + WRITE (6,'('' *'',$)') + IF (MSG_NUM.LT.0) MSG_NUM = -MSG_NUM + ELSE + WRITE (6,'('' '',$)') + END IF + IF (MSG_NUM.GT.999) N = 4 + IF (MSG_NUM.GT.9999) N = 5 + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM,'(DELETED)' + ELSE IF (EXPIRATION) THEN + IF ((SYSTEM.AND.4).EQ.4) THEN ! Shutdown bulletin? + EXPIRES = 'Shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Permanent bulletin? + EXPIRES = 'Permanent' + ELSE + EXPIRES = EXDATE(1:7)//EXDATE(10:11) + END IF + WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM,EXPIRES + ELSE + WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM, + & DATE(1:7)//DATE(10:11) + END IF + END IF + I = I + 1 + IF (SUBJECT.OR.REPLY.OR.SEARCH) IER = SYS$CANTIM(,) + END DO + + DIR_COUNT = MSG_NUM + 1 ! Update directory counter + + IF (SEARCH.OR.REPLY.OR.SUBJECT) THEN + IF (SEARCH) CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + IF (FOUND.GT.0) THEN + DIR_COUNT = FOUND + 1 + ELSE + DIR_COUNT = NBULL + 1 + END IF + END IF + + IF (DIR_COUNT.GT.NBULL.OR.(READ_TAG.AND.IER1.NE.0)) THEN + ! Outputted all entries? + DIR_COUNT = -1 ! Yes. Set counter to -1. + ELSE + WRITE(6,1010) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(' #',1X,'Description',43X,'From',9X,'Date',/) +1005 FORMAT(' #',1X,'Description',43X,'From',8X,'Expires',/) +1010 FORMAT(1X,/,' Press RETURN for more...',/) + +2010 FORMAT('+',I,1X,A<55-N>,1X,A12,1X,A9) + + END + + + SUBROUTINE CLOSE_FILES + + IMPLICIT INTEGER (A-Z) + + COMMON /CLOSE_FILES_INFO/ CLOSED_FILES + + INQUIRE(UNIT=1,OPENED=IER) + IF (IER) CALL CLOSE_BULLFIL + + INQUIRE(UNIT=2,OPENED=IER) + IF (IER) CALL CLOSE_BULLDIR + + CLOSED_FILES = .TRUE. + + RETURN + END + + + + SUBROUTINE GET_MSGKEY(BTIM,MSG_KEY) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*8 MSG_KEY,INPUT + + CALL LIB$MOVC3(8,BTIM(1),%REF(INPUT)) + + DO I=1,8 + MSG_KEY(I:I) = INPUT(9-I:9-I) + END DO + + RETURN + END + + + + SUBROUTINE FILE +C +C SUBROUTINE FILE +C +C FUNCTION: Copies a bulletin to a file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN ! If no file name was specified + WRITE(6,1020) ! Write error + RETURN ! And return + END IF + + CALL DISABLE_PRIVS + + IF (CLI$PRESENT('NEW')) THEN + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH, + & STATUS='OLD',CARRIAGECONTROL='LIST',ACCESS='APPEND') + IF (IER.NE.0) THEN + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE IF (CLI$PRESENT('FF')) THEN + WRITE (3,'(A)') CHAR(12) + END IF + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + DO FBULL = SBULL,EBULL + IF (FBULL.GT.SBULL.AND.CLI$PRESENT('FF')) THEN + WRITE (3,'(A)') CHAR(12) + END IF + CALL READDIR(FBULL,IER) ! Get info for specified bulletin + + IF (IER.NE.FBULL+1) THEN ! Was bulletin found? + WRITE(6,1030) FBULL + IF (FBULL.GT.SBULL) GO TO 100 + CLOSE (UNIT=3,STATUS='DELETE') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + RETURN + END IF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + END DO + +100 CLOSE (UNIT=3) ! Bulletin copy completed + + WRITE(6,1040) BULL_PARAMETER(1:LEN_P) + ! Show name of file created. + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + + RETURN + +900 WRITE(6,1000) + CALL ENABLE_PRIVS ! Reset BYPASS privileges + RETURN + +1000 FORMAT(' ERROR: Error in opening file.') +1010 FORMAT(' ERROR: You have not read any bulletin.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1020 FORMAT(' ERROR: No file name was specified.') +1030 FORMAT(' ERROR: Following bulletin was not found: ',I) +1040 FORMAT(' Message(s) written to ',A) +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,/,'Date: ',A) + + END + + + + + SUBROUTINE LOGIN +C +C SUBROUTINE LOGIN +C +C FUNCTION: Alerts user of new messages upon logging in. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /READIT/ READIT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /POINT/ BULL_POINT + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY*23,INREAD*1 + + LOGICAL*1 CTRL_G/7/ + + DATA GEN_DIR1/0/ ! General directory link list header + DATA SYS_DIR1/0/ ! System directory link list header + DATA SYS_NUM1/0/ ! System message number link list header + DATA SYS_BUL1/0/ ! System bulletin link list header + DATA ALL_DIR1/0/ ! Full directory link list header (for remote) + + DATA PAGE/0/ + + DATA FIRST_WRITE/.TRUE./ + LOGICAL FIRST_WRITE + + COMMON /LOGIN_BTIM/ LOGIN_BTIM_SAVE(2) + + DIMENSION NOLOGIN_BTIM(2),TODAY_BTIM(2) + DIMENSION NEW_BTIM(2),PASSCHANGE(2),BULLCP_BTIM(2) + DIMENSION LOGIN_BTIM_OLD(2),LOGIN_BTIM_NEW(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + CALL SYS_BINTIM('5-NOV-1956 11:05:56',NEW_BTIM) + +C +C Find user entry in BULLUSER.DAT to update information and +C to get the last date that messages were read. +C + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_HEADER(IER) ! Get the header + + IF (IER.EQ.0) THEN ! Header is present. + UNLOCK 4 + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + ! Find if there is an entry + IF (NEW_FLAG(1).LT.143.OR.NEW_FLAG(1).GT.143) THEN + NEW_FLAG(2)=0 ! If old version clear GENERIC value + NEW_FLAG(1)=143 ! Set new version number + END IF + IF (IER1.EQ.0) THEN ! There is a user entry + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + ! DISMAIL or SET LOGIN set + IF (CLI$PRESENT('ALL')) THEN + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + ELSE + RETURN ! Don't notify + END IF + END IF + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_ENTRY + IF (SYSTEM_FLAG(1).NE.0.AND.SYSTEM_FLAG(1).NE.1) READIT = 1 + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0.OR.BRIEF_FLAG(I).NE.0.OR. + & (I.GT.1.AND.SYSTEM_FLAG(I).NE.0)) READIT = 1 + END DO + ELSE + CALL CLEANUP_LOGIN ! Good time to delete dead users + READ_BTIM(1) = NEW_BTIM(1) ! Make new entry + READ_BTIM(2) = NEW_BTIM(2) + DO I = 1,FLONG + SET_FLAG(I) = SET_FLAG_DEF(I) + BRIEF_FLAG(I) = BRIEF_FLAG_DEF(I) + NOTIFY_FLAG(I) = NOTIFY_FLAG_DEF(I) + END DO + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) + IF (DISMAIL.EQ.1) THEN + LOGIN_BTIM(1) = NOLOGIN_BTIM(1) + LOGIN_BTIM(2) = NOLOGIN_BTIM(2) + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + ELSE + LOGIN_BTIM_SAVE(1) = NEW_BTIM(1) + LOGIN_BTIM_SAVE(2) = NEW_BTIM(2) + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0) READIT = 1 + END DO + IF (COMPARE_BTIM(PASSCHANGE,NEWEST_BTIM).LT.0) IER1 = 0 + ! Old password change indicates user is new to BULLETIN + ! but not to system, so don't limit message viewing. + END IF + CALL WRITE_USER_FILE(IER) + IF (IER.NE.0) THEN ! Error in writing to user file + WRITE (6,1070) ! Tell user of the error + CALL CLOSE_BULLUSER ! Close the user file + CALL EXIT ! Go away... + END IF + IF (DISMAIL.EQ.1) RETURN ! Go away if DISMAIL set + DIFF = -1 ! Force us to look at messages + CALL OPEN_BULLINF_SHARED + DO I=1,FOLDER_MAX + LAST_READ_BTIM(1,I) = READ_BTIM(1) + LAST_READ_BTIM(2,I) = READ_BTIM(2) + END DO + WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(I,J),I=1,2),J=1,FOLDER_MAX) + CALL CLOSE_BULLINF + END IF + LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) + LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) + CALL READ_USER_FILE_HEADER(IER2) ! Reset read back to header + END IF + + IF (IER.EQ.0.AND.MINUTE_DIFF(TODAY_BTIM,BBOARD_BTIM) + & .GT.BBOARD_UPDATE) THEN ! Update BBOARD mail? + BBOARD_BTIM(1) = TODAY_BTIM(1) + BBOARD_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_HEADER ! Rewrite header + IF (.NOT.TEST_BULLCP()) CALL CREATE_BBOARD_PROCESS + ELSE IF (IER.NE.0) THEN + CALL CLOSE_BULLUSER + CALL EXIT ! If no header, no messages + END IF + + IF (IER1.EQ.0) THEN ! Skip date comparison if new entry +C +C Compare and see if messages have been added since the last time +C that the user has logged in or used the BULLETIN facility. +C + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,READ_BTIM) + IF (DIFF1.LT.0) THEN ! If read messages since last login, + LOGIN_BTIM(1) = READ_BTIM(1) ! then use the read date to compare + LOGIN_BTIM(2) = READ_BTIM(2) ! with the latest bulletin date + END IF ! to see if should alert user. + + IF (SYSTEM_SWITCH) THEN + DIFF1 = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,NEWEST_BTIM) + ELSE + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,NEWEST_BTIM) + END IF + END IF + + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) ! These are destroyed in UPDATE_READ + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + + IF (NEW_FLAG(2).NE.0.AND.NEW_FLAG(2).NE.-1) THEN + CALL LIB$MOVC3(4,NEW_FLAG(2),%REF(BULL_PARAMETER)) + CALL SUBTIME(LOGIN_BTIM,BULL_PARAMETER(1:4),IER) + ELSE IF (DIFF1.GT.0) THEN + BULL_POINT = -1 + IF (READIT.EQ.1) THEN + CALL UPDATE_READ(1) + LOGIN_BTIM_NEW(1) = LOGIN_BTIM(1) + LOGIN_BTIM_NEW(2) = LOGIN_BTIM(2) + CALL READ_IN_FOLDERS + CALL MODIFY_SYSTEM_LIST(1) + END IF + CALL CLOSE_BULLUSER + RETURN + END IF + + CALL READ_IN_FOLDERS + CALL MODIFY_SYSTEM_LIST(1) + +C +C If there are new messages, look for them in BULLDIR.DAT +C Save all new entries in the GEN_DIR file BULLCHECK.SCR so +C that we can close BULLDIR.DAT as soon as possible. +C + + ENTRY LOGIN_FOLDER + + IF (NEW_FLAG(2).EQ.0.OR.NEW_FLAG(2).EQ.-1.OR.FOLDER_SET) THEN + LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) + LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) + END IF + + IF (REMOTE_SET) THEN ! If system remote folder, use remote + ! info, not local login time + IF (LAST_SYS_BTIM(1,FOLDER_NUMBER+1).NE.0) THEN + LOGIN_BTIM(1) = LAST_SYS_BTIM(1,FOLDER_NUMBER+1) + LOGIN_BTIM(2) = LAST_SYS_BTIM(2,FOLDER_NUMBER+1) + LAST_SYS_BTIM(1,FOLDER_NUMBER+1) = 0 + LAST_SYS_BTIM(2,FOLDER_NUMBER+1) = 0 + ELSE + DIFF1 = COMPARE_BTIM(LOGIN_BTIM, + & LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF1.LT.0) THEN + LOGIN_BTIM(1) = LAST_READ_BTIM(1,FOLDER_NUMBER+1) + LOGIN_BTIM(2) = LAST_READ_BTIM(2,FOLDER_NUMBER+1) + ELSE + DIFF = MINUTE_DIFF(LOGIN_BTIM,F_NEWEST_BTIM) + IF (DIFF.GE.0.AND.DIFF.LE.15) THEN ! BULLCP updates every 15 min + IER = SYS$BINTIM('0 00:15',BULLCP_BTIM) + BULLCP_BTIM(1) = -BULLCP_BTIM(1) ! Convert to -delta time + BULLCP_BTIM(2) = -BULLCP_BTIM(2)-1 + CALL LIB$SUBX(LOGIN_BTIM,BULLCP_BTIM,LOGIN_BTIM) + END IF + END IF + END IF + END IF + + ENTRY SHOW_SYSTEM + + JUST_SYSTEM = (.NOT.LOGIN_SWITCH.AND.SYSTEM_SWITCH).OR. + & (BTEST(FOLDER_FLAG,2) + & .AND..NOT.TEST2(SET_FLAG,FOLDER_NUMBER) + & .AND..NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) + + NGEN = 0 ! Number of general messages + NSYS = 0 ! Number of system messages + BULL_POINT = -1 + + IF (IER1.NE.0.AND.FOLDER_NUMBER.GT.0) THEN + IF (LOGIN_SWITCH) THEN + IF (READIT.EQ.1) THEN + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + CALL UPDATE_READ(1) + LOGIN_BTIM_NEW(1) = LOGIN_BTIM(1) + LOGIN_BTIM_NEW(2) = LOGIN_BTIM(2) + END IF + CALL CLOSE_BULLUSER + END IF + RETURN ! Don't overwhelm new user with lots of non-general msgs + END IF + + IF (BTEST(FOLDER_FLAG,2).AND.SYSTEM_SWITCH) THEN + ! Can folder have SYSTEM messages and /SYSTEM specified? + LOGIN_BTIM(1) = SYSTEM_LOGIN_BTIM(1) ! Use specified login time + LOGIN_BTIM(2) = SYSTEM_LOGIN_BTIM(2) ! for system messages. + END IF + + IF (LOGIN_SWITCH) THEN + IF (READIT.EQ.1) THEN + LOGIN_BTIM_OLD(1) = LOGIN_BTIM(1) + LOGIN_BTIM_OLD(2) = LOGIN_BTIM(2) + CALL UPDATE_READ(1) + LOGIN_BTIM_NEW(1) = LOGIN_BTIM(1) + LOGIN_BTIM_NEW(2) = LOGIN_BTIM(2) + LOGIN_BTIM(1) = LOGIN_BTIM_OLD(1) + LOGIN_BTIM(2) = LOGIN_BTIM_OLD(2) + END IF + CALL CLOSE_BULLUSER + END IF + + IF (READIT.EQ.1) THEN + IF (LAST_SYS_BTIM(1,FOLDER_NUMBER+1).NE.0) THEN + DIFF1 = COMPARE_BTIM(LOGIN_BTIM, + & LAST_SYS_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF1.LT.0) THEN + LOGIN_BTIM(1) = LAST_SYS_BTIM(1,FOLDER_NUMBER+1) + LOGIN_BTIM(2) = LAST_SYS_BTIM(2,FOLDER_NUMBER+1) + END IF + LAST_SYS_BTIM(1,FOLDER_NUMBER+1) = LOGIN_BTIM_NEW(1) + LAST_SYS_BTIM(2,FOLDER_NUMBER+1) = LOGIN_BTIM_NEW(2) + END IF + + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER) + & .AND.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + IF (.NOT.TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) GO TO 9999 + END IF + END IF + + CALL OPEN_BULLDIR_SHARED ! Get bulletin directory + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(0,IER) ! Get header info + ELSE + NBULL = F_NBULL + END IF + + CALL INIT_QUEUE(GEN_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_NUM1,%DESCR(ICOUNT)) + GEN_DIR = GEN_DIR1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + START = 1 + REVERSE = 0 + IF (.NOT.TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & .NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + IF (REVERSE_SWITCH) REVERSE = 1 + IF (IER1.EQ.0) THEN + CALL GET_NEWEST_MSG(LOGIN_BTIM,START) + IF (START.EQ.-1) START = NBULL + 1 + END IF + END IF + + IF (REMOTE_SET) THEN + CALL INIT_QUEUE(ALL_DIR1,BULLDIR_ENTRY) + IF (REVERSE) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,START,NBULL + ELSE + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,NBULL,START + END IF + IF (IER.EQ.0) THEN + ALL_DIR = ALL_DIR1 + I = START + DO WHILE (IER.EQ.0.AND.I.LE.NBULL) + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY + CALL WRITE_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + I = I + 1 + END DO + END IF + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + GO TO 9999 + END IF + ALL_DIR = ALL_DIR1 + END IF + + DO ICOUNT1 = NBULL,START,-1 + IF (REVERSE) THEN + ICOUNT = NBULL + START - ICOUNT1 + ELSE + ICOUNT = ICOUNT1 + END IF + IF (REMOTE_SET) THEN + CALL READ_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + IER = ICOUNT + 1 + ELSE + CALL READDIR(ICOUNT,IER) + END IF + IF (IER1.EQ.0.AND.IER.EQ.ICOUNT+1) THEN ! Is this a totally new user? + ! No. Is bulletin system or from same user? + IF (.NOT.REVERSE) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM,MSG_BTIM) ! No, so compare date + IF (DIFF.GT.0) GO TO 100 + END IF + IF (.NOT.BTEST(FOLDER_FLAG,2)) SYSTEM = SYSTEM.AND.(.NOT.1) + ! Show system msg in non-system folder as general msg + IF (USERNAME.NE.FROM.OR.SYSTEM) THEN + IF (SYSTEM) THEN ! Is it system bulletin? + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (.NOT.JUST_SYSTEM) THEN + IF (SYSTEM_SWITCH) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,MSG_BTIM) + ELSE + DIFF = -1 + END IF + IF (DIFF.LT.0) THEN + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (.NOT.BTEST(FOLDER_FLAG,2).AND. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + SYSTEM = ICOUNT + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END IF + ELSE IF (IER.EQ.ICOUNT+1) THEN + ! Totally new user, save only permanent system msgs + IF ((SYSTEM.AND.7).EQ.3) THEN + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (NGEN.EQ.0) THEN ! And save only the first non-system msg + SYSTEM = ICOUNT ! Save bulletin number for display + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (.NOT.BTEST(FOLDER_FLAG,2).AND. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END DO +100 CALL CLOSE_BULLDIR +C +C Review new directory entries. If there are system messages, +C copy the system bulletin into GEN_DIR file BULLSYS.SCR for outputting +C to the terminal. If there are simple messages, just output the +C header information. +C + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) NGEN = 0 + + IF (NGEN.EQ.0.AND.NSYS.EQ.0) GO TO 9999 + + IF (NSYS.GT.0) THEN ! Are there any system messages? + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + LENF = TRIM(FOLDER) + S1 = (PAGE_WIDTH-(LENF+16))/2 + S2 = PAGE_WIDTH - S1 - (LENF + 16) + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE (6,1026) FOLDER(:LENF) ! Yep... + PAGE = PAGE + 1 + CTRL_G = 0 ! Don't ring bell for non-system bulls + CALL OPEN_BULLFIL_SHARED + CALL INIT_QUEUE(SYS_BUL1,INPUT) + SYS_BUL = SYS_BUL1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + NSYS_LINE = 0 + DO J=1,NSYS + CALL READ_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + IF (REMOTE_SET) THEN + CALL READ_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,ICOUNT + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER) + END IF + IF (IER.GT.0) THEN + CALL CLOSE_BULLFIL + GO TO 9999 + END IF + END IF + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin to SYS_BUL link list + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + IF (ILEN.LT.0) THEN + CALL CLOSE_BULLFIL + GO TO 9999 + END IF + IF (J.LT.NSYS.AND.SEPARATE.NE.' ') THEN + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + DO I=1,PAGE_WIDTH + INPUT(I:I) = SEPARATE + END DO + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 2 + END IF + END DO + CALL CLOSE_BULLFIL + SYS_BUL = SYS_BUL1 + ILEN = 0 + I = 1 + DO WHILE (I.LE.NSYS_LINE.OR.ILEN.GT.0) ! Write out system messages + IF (ILEN.EQ.0) THEN + CALL READ_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + ILEN = TRIM(INPUT) + I = I + 1 + END IF + IF (SYS_BUL.NE.0) THEN + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN + ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD,! Get terminal input + & 'HIT any key for next page....') + WRITE (6,'(1X)') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) '+'//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) '+'//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + ELSE + PAGE = PAGE + 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) ' '//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) ' '//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + END IF + END IF + END DO + IF (NGEN.EQ.0) THEN + WRITE(6,'(A)') ! Write delimiting blank line + END IF + PAGE = PAGE + 1 + END IF + + ENTRY REDISPLAY_DIRECTORY + + GEN_DIR = GEN_DIR1 + IF (NGEN.GT.0) THEN ! Are there new non-system messages? + LENF = TRIM(FOLDER) + S1 = (PAGE_WIDTH-13-LENF)/2 + S2 = PAGE_WIDTH-S1-13-LENF + IF (PAGE+5+NGEN.GT.PAGE_LENGTH.AND.PAGE.GT.0) THEN + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, ! Get terminal input + & 'HIT any key for next page....') + WRITE (6,'(1X)') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1028) 'New '//FOLDER(1:LENF)//' messages' + PAGE = 1 + ELSE + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1027) 'New '//FOLDER(1:LENF)//' messages' + PAGE = PAGE + 1 + END IF + WRITE(6,1020) + WRITE(6,1025) + PAGE = PAGE + 2 + I = 0 + DO WHILE (I.LT.NGEN) + I = I + 1 + CALL READ_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + CALL CONVERT_ENTRY_FROMBIN + IF (SYSTEM.GT.9999) THEN ! # Digits in message number + N = 5 + ELSE IF (SYSTEM.GT.999) THEN + N = 4 + ELSE + N = 3 + END IF + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, + & 'HIT Q(Quit listing) or any other key for next page....') + CALL STR$UPCASE(INREAD,INREAD) + WRITE (6,'(1X)') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (INREAD.EQ.'Q') THEN + I = NGEN ! Quit directory listing + WRITE(6,'(''+Quitting directory listing.'')') + ELSE + WRITE(6,1040) '+'//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM + END IF + ! Bulletin number is stored in SYSTEM + ELSE + PAGE = PAGE + 1 + WRITE(6,1040) ' '//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM + END IF + END DO + IF ((.NOT.FOLDER_SET.AND.BTEST(SET_FLAG(1),0).AND.DIFF1.LE.0) + & .OR.(FOLDER_SET.AND.TEST2(SET_FLAG,FOLDER_NUMBER))) THEN + PAGE = 0 ! Don't reset page counter if READNEW not set, + END IF ! as no prompt to read is generated. + END IF +C +C Instruct users how to read displayed messages if READNEW not selected. +C + IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE(6,1030) + ELSE IF (NGEN.EQ.0) THEN + ILEN = 57 + INDEX(COMMAND_PROMPT,'>') - 1 + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-57)// + & '/SYSTEM command can be used to reread these messages.' + ELSE + FLEN = TRIM(FOLDER) + IF (FOLDER_NUMBER.EQ.0) FLEN = -1 + ILEN = 49 + INDEX(COMMAND_PROMPT,'>') - 1 + FLEN + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-48)// + & ' command can be used to read these messages.' + ELSE + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-49-FLEN) + & //' '//FOLDER(:FLEN)// + & ' command can be used to read these messages.' + END IF + END IF + +9999 IF (LOGIN_SWITCH) THEN + LOGIN_BTIM(1) = LOGIN_BTIM_NEW(1) + LOGIN_BTIM(2) = LOGIN_BTIM_NEW(2) + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM_OLD(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM_OLD(2) + END IF + RETURN + +1020 FORMAT(' Description',43X,'From',9X,'Date',3X,'Number') +1025 FORMAT(' -----------',43X,'----',9X,'----',3X,'------') +1026 FORMAT(' ',('*'),A,' System Messages',('*')) +1027 FORMAT(/,' ',('*'),A,('*')) +1028 FORMAT('+',('*'),A,('*')) +1030 FORMAT(' ',('*')) +1035 FORMAT(' ',('*'),A,('*')) +1040 FORMAT(A<57-N>,1X,A12,1X,A6,<6-N>X,I) +1060 FORMAT(A) +1070 FORMAT(' ERROR: Cannot add new entry to user file.') +1080 FORMAT(' ',/) + + END + + + + SUBROUTINE GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,NODE_NAME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + CHARACTER*(*) NODE_NAME + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) + CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) + CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist + + IER = SYS$GETSYIW(,,NODE_NAME(:TRIM(NODE_NAME)), + & %VAL(GETSYI_ITMLST),,,) ! Get Info command. + + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Specified node name not found.'')') + NODE_AREA = 0 + END IF + + RETURN + END + diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin1.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin1.for new file mode 100644 index 0000000..20d3af8 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin1.for @@ -0,0 +1,1603 @@ +C +C BULLETIN1.FOR, Version 11/27/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE MAIL(STATUS) +C +C SUBROUTINE MAIL +C +C FUNCTION: Sends message which you have read to user via DEC mail. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*64 MAIL_SUBJECT + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + MAIL_SUBJECT = DESCRIP + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',MAIL_SUBJECT,LEN_D) + IF (LEN_D.GT.LEN(MAIL_SUBJECT)-2) THEN + WRITE(6,'('' ERROR: Subject limit is 64 characters.'')') + RETURN + END IF + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Error in opening scratch file.'')') + RETURN + END IF + + IF (CLI$PRESENT('HEADER')) THEN ! Printout header? + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + WRITE (3,'(A)') INPUT(:TRIM(INPUT)) + END IF + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Message copy completed + + CALL CLOSE_BULLFIL + + LEN_D = TRIM(MAIL_SUBJECT) + IF (LEN_D.EQ.0) THEN + MAIL_SUBJECT = 'BULLETIN message.' + LEN_D = TRIM(MAIL_SUBJECT) + END IF + + I = 1 + DO WHILE (I.LE.LEN_D) + IF (MAIL_SUBJECT(I:I).EQ.'"') THEN + IF (LEN_D.EQ.64) THEN + MAIL_SUBJECT(I:I) = '`' + ELSE + MAIL_SUBJECT = MAIL_SUBJECT(:I)//'"'//MAIL_SUBJECT(I+1:) + I = I + 1 + LEN_D = LEN_D + 1 + END IF + END IF + I = I + 1 + END DO + + LEN_P = 0 + DO WHILE (CLI$GET_VALUE('RECIPIENTS',BULL_PARAMETER(LEN_P+1:),I) + & .NE.%LOC(CLI$_ABSENT)) ! Get all the usernames + LEN_P = LEN_P + I + 1 + BULL_PARAMETER(LEN_P:LEN_P) = ',' + END DO + LEN_P = LEN_P - 1 + + I = 1 ! Must change all " to """ in MAIL recipients + DO WHILE (I.LE.LEN_P) + IF (BULL_PARAMETER(I:I).EQ.'"') THEN + BULL_PARAMETER = BULL_PARAMETER(:I)//'""'// + & BULL_PARAMETER(I+1:) + I = I + 2 + LEN_P = LEN_P + 2 + END IF + I = I + 1 + END DO + + CALL DISABLE_PRIVS + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR '//BULL_PARAMETER(:LEN_P) + & //'/SUBJECT="'//MAIL_SUBJECT(:LEN_D)//'"',,,,,,STATUS) + CALL ENABLE_PRIVS + + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR') + + RETURN + +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A) + + END + + + + SUBROUTINE MODIFY_FOLDER +C +C SUBROUTINE MODIFY_FOLDER +C +C FUNCTION: Modifies a folder's information. +C + IMPLICIT INTEGER (A - Z) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER PASSWORD*31,DEFAULT_USER*12 + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + RETURN + ELSE IF (.NOT.FOLDER_ACCESS + & (USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE (6,'('' ERROR: No privileges to modify folder.'')') + RETURN + END IF + + IF (CLI$PRESENT('NAME')) THEN + IF (REMOTE_SET) THEN + WRITE (6,'('' ERROR: Cannot change name of'', + & '' remote folder.'')') + RETURN + ELSE + CALL CLI$GET_VALUE('NAME',FOLDER1,LEN_P) + IF (LEN_P.GT.25) THEN + WRITE (6,'('' ERROR: Folder name cannot be larger + & than 25 characters.'')') + RETURN + END IF + END IF + ELSE + FOLDER1 = FOLDER + END IF + + IF (CLI$PRESENT('DESCRIPTION')) THEN + WRITE (6,'('' Enter one line description of folder.'')') + LEN_P = 81 + DO WHILE (LEN_P.GT.80) + CALL GET_LINE(FOLDER1_DESCRIP,LEN_P) ! Get input line + IF (LEN_P.LE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + RETURN + ELSE IF (LEN_P.GT.80) THEN ! If too many characters + WRITE (6,'('' ERROR: Description must be < 80 characters.'')') + ELSE + FOLDER1_DESCRIP = FOLDER1_DESCRIP(:LEN_P) ! End fill with spaces + END IF + END DO + ELSE + FOLDER1_DESCRIP = FOLDER_DESCRIP + END IF + + IF (CLI$PRESENT('OWNER')) THEN + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + IF (LEN_P.GT.12) THEN + WRITE (6,'('' ERROR: Owner name must be < 13 characters.'')') + RETURN + ELSE IF (CLI$PRESENT('ID')) THEN + IER = CHKPRO(FOLDER1_OWNER) + ELSE + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + END IF + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner name is not valid username.'')') + RETURN + ELSE IF (LEN_P.GT.LEN(FOLDER1_OWNER)) THEN + WRITE (6,'('' ERROR: Folder owner name too long.'')') + RETURN + ELSE IF (.NOT.SETPRV_PRIV()) THEN + WRITE(6,'('' Enter password of new owner: '',A)') CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) THEN + WRITE (6,'('' ERROR: No password entered.'')') + RETURN + END IF + WRITE (6,'('' Attempting to verify password name...'')') + OPEN (UNIT=10,NAME='SYS$NODE"'// + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + & //' '//PASSWORD(:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + RETURN + ELSE + WRITE (6,'('' Password was verified.'')') + END IF + ELSE + FOLDER1_OWNER = FOLDER1_OWNER(:LEN_P) + END IF + ELSE + FOLDER1_OWNER = FOLDER_OWNER + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + + IF (CLI$PRESENT('NAME')) THEN + READ (7,IOSTAT=IER,KEY=FOLDER1,KEYID=0) + ! See if folder exists + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder name already exists.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + END IF + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (IER.EQ.0.AND.CLI$PRESENT('NAME')) THEN + LEN_F = TRIM(FOLDER_DIRECTORY) + IER = LIB$RENAME_FILE(FOLDER_DIRECTORY(:LEN_F)// + & FOLDER(:TRIM(FOLDER))//'.*',FOLDER_DIRECTORY(:LEN_F)// + & FOLDER1(:TRIM(FOLDER1))//'.*') + IF (IER) THEN + IER = 0 + FOLDER_FILE = FOLDER_DIRECTORY(:LEN_F)//FOLDER1 + END IF + END IF + + IF (IER.EQ.0) THEN + IF (CLI$PRESENT('OWNER')) THEN + CALL CHKACL + & (FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + CALL DEL_ACL(FOLDER_OWNER,'R+W+C',IER) + END IF + END IF + FOLDER = FOLDER1 + FOLDER_OWNER = FOLDER1_OWNER + FOLDER_DESCRIP = FOLDER1_DESCRIP + DELETE (7) + IF (CLI$PRESENT('ID')) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,6) + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,6) + END IF + CALL WRITE_FOLDER_FILE(IER) + IF (IER.EQ.0) WRITE (6,'('' Folder successfully modified.'')') + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + FUNCTION FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME,FOLDER_OWNER + + IF (SETPRV_PRIV()) THEN + FOLDER_ACCESS = .TRUE. + ELSE IF (BTEST(FOLDER_FLAG,6)) THEN ! If folder owner is ID + FOLDER_ACCESS = CHKPRO(FOLDER_OWNER) + ELSE + FOLDER_ACCESS = USERNAME.EQ.FOLDER_OWNER + END IF + + RETURN + END + + + + SUBROUTINE MOVE(DELETE_ORIGINAL) +C +C SUBROUTINE MOVE +C +C FUNCTION: Moves message from one folder to another. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + EXTERNAL CLI$_ABSENT + + EXTERNAL BULLETIN_SUBCOMMANDS + + LOGICAL DELETE_ORIGINAL + + CHARACTER SAVE_FOLDER*25 + + IF (CLI$PRESENT('ORIGINAL').AND..NOT.SETPRV_PRIV()) THEN + WRITE (6, + & '('' ERROR: You have no privileges to keep original owner.'')') + END IF + + ALL = CLI$PRESENT('ALL') + + MERGE = CLI$PRESENT('MERGE') + + SAVE_BULL_POINT = BULL_POINT + + IER1 = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER1.EQ.%LOC(CLI$_ABSENT).AND..NOT.ALL) THEN + IF (BULL_POINT.EQ.0) THEN ! If no message has been read + WRITE(6,'('' ERROR: You are not reading any message.'')') + RETURN ! and return + END IF + + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) ! Get message directory entry + IF (IER.NE.BULL_POINT+1) THEN ! Was message found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + NUM_COPY = 1 + ELSE + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) ! Get message directory entry + IF (NBULL.EQ.0) THEN ! Were messages found? + WRITE(6,'('' ERROR: No messages were found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (IER1.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER1) + IF (SBULL.LE.0.OR.IER1.NE.0) THEN + WRITE (6,'(A)') + & ' ERROR: Specified message number has incorrect format.' + CALL CLOSE_BULLDIR + RETURN + ELSE + NUM_COPY = EBULL - SBULL + 1 + BULL_POINT = SBULL + END IF + ALL = .TRUE. + ELSE IF (CLI$PRESENT('ALL')) THEN + NUM_COPY = NBULL + BULL_POINT = 1 + END IF + END IF + + FROM_REMOTE = REMOTE_SET + + IF (REMOTE_SET) THEN + OPEN (UNIT=12,FILE='REMOTE.BULLDIR', + & STATUS='SCRATCH',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.0) THEN + OPEN (UNIT=11,FILE='REMOTE.BULLFIL', + & STATUS='SCRATCH',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END IF + IF (IER.EQ.0) THEN + CALL OPEN_BULLFIL + I = BULL_POINT - 1 + CALL READDIR(I,IER) + IF (IER.EQ.I+1) THEN + IF (I.EQ.0) THEN + WRITE (12,IOSTAT=IER1) BULLDIR_HEADER + ELSE + WRITE (12,IOSTAT=IER1) BULLDIR_ENTRY + END IF + END IF + NBLOCK = 1 + DO WHILE (I.LT.BULL_POINT+NUM_COPY-1.AND.IER.EQ.I+1) + I = I + 1 + CALL READDIR(I,IER) + IF (IER.EQ.I+1) THEN + BLOCK = NBLOCK + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (12,IOSTAT=IER1) BULLDIR_ENTRY + IF (IER1.EQ.0) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER1) 5,I + IF (IER1.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER1) + END IF + END IF + IF (IER1.EQ.0) THEN + SCRATCH_R = SCRATCH_R1 + DO J=1,LENGTH + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT(:128)) + WRITE (11'NBLOCK,IOSTAT=IER1) INPUT(:128) + NBLOCK = NBLOCK + 1 + END DO + END IF + IF (IER1.NE.0) I = IER + END IF + END DO + NUM_COPY = I - BULL_POINT + 1 + END IF + CALL CLOSE_BULLFIL + IF (IER1.NE.0) THEN + WRITE(6,'('' ERROR: Copy aborted. Remote folder problem.'')') + CLOSE (UNIT=11) + CLOSE (UNIT=12) + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + + CALL CLOSE_BULLDIR + + SAVE_FOLDER = FOLDER + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + CALL CLI$GET_VALUE('FOLDER',FOLDER1) + + FOLDER_NUMBER = -1 ! Use FOLDER as key rather than FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Cannot access specified folder.'')') + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER = SAVE_FOLDER + BULL_POINT = SAVE_BULL_POINT + CLOSE (UNIT=11) + CLOSE (UNIT=12) + RETURN + END IF + + IF (READ_ONLY.OR.(MERGE.AND.REMOTE_SET)) THEN + IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No access to write into folder.'')') + ELSE + WRITE (6,'('' ERROR: /MERGE invalid into remote folder.'')') + END IF + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + BULL_POINT = SAVE_BULL_POINT + CLOSE (UNIT=11) + CLOSE (UNIT=12) + RETURN + END IF + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + CALL OPEN_BULLDIR ! Prepare to add dir entry + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //SAVE_FOLDER + + IF (.NOT.FROM_REMOTE) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=12,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER.EQ.0) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=11,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END DO + END IF + ELSE + IER= 0 + END IF + + IF (MERGE) CALL INITIALIZE_MERGE(IER) + + START_BULL_POINT = BULL_POINT + + IF (IER.EQ.0) READ (12,KEYID=0,KEY=BULL_POINT-1,IOSTAT=IER) + + DO WHILE (NUM_COPY.GT.0.AND.IER.EQ.0) + READ (12,IOSTAT=IER) BULLDIR_ENTRY + NUM_COPY = NUM_COPY - 1 + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + + IF (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV()) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,0) ! Remove system bit + END IF + + IF (BTEST(SYSTEM,2).AND. ! Shutdown message? + & (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV())) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,2) ! Remove shutdown bit + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + EXTIME = '00:00:00.00' + ELSE IF (BTEST(SYSTEM,1).AND.FOLDER_NUMBER.EQ.0.AND. + & .NOT.SETPRV_PRIV().AND..NOT.ALL) THEN ! Permanent? + WRITE (6,'('' ERROR: No privileges to add'', + & '' permanent message.'')') + WRITE (6,'('' Expiration will be '',I,'' days.'')') + & FOLDER_BBEXPIRE + SYSTEM = IBCLR(SYSTEM,1) + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + EXTIME = '00:00:00.00' + END IF + + IF (.NOT.CLI$PRESENT('ORIGINAL')) THEN ! If not /ORIGINAL + FROM = USERNAME ! Specify owner + END IF + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + IF (IER.NE.0) CALL ERROR_AND_EXIT + END IF + + IF (MERGE) CALL ADD_MERGE_TO(IER) + + IF (IER.EQ.0) THEN + NBLOCK = NBLOCK + 1 + + DO I=BLOCK,BLOCK+LENGTH-1 + READ (11'I,IOSTAT=IER) INPUT(:128) + IF (IER.EQ.0) THEN + CALL WRITE_BULL_FILE(NBLOCK,INPUT(:128)) + END IF + NBLOCK = NBLOCK + 1 + END DO + END IF + + IF (IER.EQ.0) THEN + IF (MERGE) THEN + CALL ADD_MERGE_FROM(IER) + ELSE + CALL ADD_ENTRY ! Add the new directory entry + END IF + BULL_POINT = BULL_POINT + 1 + END IF + END DO + + IF (MERGE) CALL ADD_MERGE_REST(IER) + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CLOSE (UNIT=11) + + CLOSE (UNIT=12) + + IF (FOLDER_NUMBER.GE.0.AND.IER.EQ.0) THEN + CALL UPDATE_FOLDER ! Update folder info +C +C If user is adding message, update that user's last read time for +C folder, so user is not alerted of new message which is owned by user. +C + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + + IF (IER.EQ.0) THEN + WRITE (6,'('' Successful copy to folder '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + IF (MERGE) THEN + CALL LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END IF + ELSE IF (MERGE) THEN + WRITE (6,'('' ERROR: Copy aborted. No files copied.'')') + ELSE + WRITE (6,'('' ERROR: Copy aborted. '',I,'' files copied.'')') + & BULL_POINT - START_BULL_POINT + END IF + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + + BULL_POINT = SAVE_BULL_POINT + + IF (DELETE_ORIGINAL.AND.IER.EQ.0) THEN + IF (FROM_REMOTE.AND.ALL) THEN + WRITE (6,'('' WARNING: Original messages not deleted.'')') + WRITE (6,'('' Multiple deletions not possible for '', + & ''remote folders.'')') + ELSE + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + CALL DELETE + END IF + END IF + + RETURN + + END + + + + + SUBROUTINE PRINT +C +C SUBROUTINE PRINT +C +C FUNCTION: Print header to queue. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SJCDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + CHARACTER*32 QUEUE + + INTEGER*2 FILE_ID(14) + INTEGER*2 IOSB(4) + EQUIVALENCE (IOSB(1),JBC_ERROR) + + CHARACTER*31 FORM_NAME + + PARAMETER FF = CHAR(12) + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + + CALL DISABLE_PRIVS + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.LIS',ERR=900,IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + CALL ENABLE_PRIVS + + CALL OPEN_BULLDIR_SHARED + + CALL OPEN_BULLFIL_SHARED + + HEAD = CLI$PRESENT('HEADER') + + DO I=SBULL,EBULL + CALL READDIR(I,IER) ! Get info for specified message + + IF (IER.NE.I+1) THEN ! Was message found? + IF (I.EQ.SBULL) THEN ! No, were any messages found? + WRITE(6,1030) ! If not, then error out + CLOSE (UNIT=3,STATUS='DELETE') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + RETURN + END IF + ELSE ! Yes, message found. + IF (I.GT.SBULL) WRITE(3,'(A)') FF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + END IF + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(18,SJC$_FILE_SPECIFICATION, + & %LOC('SYS$LOGIN:BULL.LIS')) + + IER = CLI$GET_VALUE('QUEUE',QUEUE,ILEN) ! Get queue name + IF (ILEN.EQ.0) THEN + QUEUE = 'SYS$PRINT' + ILEN = 9 + END IF + + CALL ADD_2_ITMLST(ILEN,SJC$_QUEUE,%LOC(QUEUE)) + CALL ADD_2_ITMLST(0,SJC$_DELETE_FILE,0) + + IF (CLI$PRESENT('NOTIFY')) THEN + CALL ADD_2_ITMLST(0,SJC$_NOTIFY,0) + END IF + + IF (CLI$PRESENT('FORM')) THEN + IER = CLI$GET_VALUE('FORM',FORM_NAME,FORM_NAME_LEN) + CALL ADD_2_ITMLST(FORM_NAME_LEN,SJC$_FORM_NAME,%LOC(FORM_NAME)) + END IF + + CALL DISABLE_PRIVS + + CALL END_ITMLST(SJC_ITMLST) + + IER=SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SJC_ITMLST),IOSB,,) + IF (IER.AND.(.NOT.JBC_ERROR)) THEN + CALL SYS_GETMSG(JBC_ERROR) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + ELSE IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + RETURN + +900 CALL ERRSNS(IDUMMY,IER) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + WRITE(6,1000) + CALL SYS_GETMSG(IER) + RETURN + +1000 FORMAT(' ERROR: Unable to open temporary file + & SYS$LOGIN:BULL.LIS for printing.') +1010 FORMAT(' ERROR: You have not read any message.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Specified message was not found.') +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A,/,'Date: ',A) + + END + + + + + SUBROUTINE READ(READ_COUNT,BULL_READ) +C +C SUBROUTINE READ +C +C FUNCTION: Reads a specified bulletin. +C +C PARAMETER: +C READ_COUNT - Variable to store the record in the message file +C that READ will read from. Must be set to 0 to indicate +C that it is the first read of the message. If -1, +C READ will search for the last message in the message file +C and read that one. If -2, just display header information. +C BULL_READ - Message number to be read. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /TAGS/ BULL_TAG,READ_TAG + + DATA SCRATCH_B1/0/ + + CHARACTER TODAY*11,DATETIME*23,BUFFER*(LINE_LENGTH) + CHARACTER SAVE_MSG_KEY*8,PREV_MSG_KEY*8 + + LOGICAL SINCE,PAGE + + CALL LIB$ERASE_PAGE(1,1) ! Clear screen + END = 0 ! Nothing outputted on screen + + IF (READ_COUNT.GT.0) GO TO 100 ! Skip init steps if this is + ! not first page of bulletin + + SINCE = .FALSE. + PAGE = .TRUE. + + IF (.NOT.PAGING) PAGE = .FALSE. + IF (INCMD(:4).EQ.'READ') THEN ! If READ command... + IF (CLI$PRESENT('MARKED')) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No marked messages found.'')') + RETURN + ELSE + READ_TAG = .TRUE. + END IF + END IF + + IF (.NOT.CLI$PRESENT('PAGE')) PAGE = .FALSE. + IF (CLI$PRESENT('SINCE')) THEN ! was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present.'')') + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + END IF + IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + CALL OPEN_BULLDIR_SHARED + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + RETURN + ELSE + BULL_READ = IER + IER = IER + 1 + END IF + SINCE = .TRUE. + END IF + END IF + + IF (READ_TAG) THEN + NEXT = .FALSE. + IF (INCMD(:4).EQ.'NEXT'.OR.INCMD.EQ.' ') THEN + NEXT = .TRUE. + ELSE IF (INCMD(:4).EQ.'READ') THEN + IF (.NOT.CLI$PRESENT('BULLETIN_NUMBER')) NEXT = .TRUE. + END IF + IF (INCMD(:4).EQ.'BACK') THEN + SAVE_MSG_KEY = MSG_KEY + MSG_KEY = BULLDIR_HEADER + I = 0 + IER = 0 + CALL OPEN_BULLDIR_SHARED + DO WHILE (IER.EQ.0.AND.MSG_KEY.NE.SAVE_MSG_KEY) + I = I + 1 + IF (MSG_KEY.NE.SAVE_MSG_KEY) PREV_MSG_KEY = MSG_KEY + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END DO + IF (IER.EQ.0) THEN + MSG_KEY = PREV_MSG_KEY + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + IER = BULL_READ + 1 + ELSE + IER = 0 + END IF + ELSE IF (INCMD(:4).EQ.'LAST') THEN + CALL OPEN_BULLDIR_SHARED + IER = 0 + IF (BULL_POINT.EQ.0) CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_READ) + DO WHILE (IER.EQ.0) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END DO + CALL CLOSE_BULLDIR + IER = BULL_READ + 1 + ELSE IF (NEXT) THEN + IF (SINCE) THEN + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + ELSE + IF (BULL_POINT.GT.0) THEN + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) + CALL CLOSE_BULLDIR + ELSE + MSG_KEY = BULLDIR_HEADER + END IF + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,BULL_READ) + END IF + IF (IER.EQ.0) THEN + IER = BULL_READ + 1 + ELSE + IER = 0 + END IF + END IF + END IF + + IF (.NOT.SINCE.AND.(.NOT.READ_TAG.OR.(.NOT.NEXT.AND. + & INCMD(:4).NE.'LAST'.AND.INCMD(:4).NE.'BACK'))) THEN + IF (BULL_READ.GT.0) THEN ! Valid bulletin number? + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_READ,IER) ! Get bulletin directory entry + IF (READ_COUNT.EQ.-1.AND.IER.NE.BULL_READ+1) THEN + READ_COUNT = 0 + CALL READDIR(0,IER) + IF (NBULL.GT.0) THEN + BULL_READ = NBULL + CALL READDIR(BULL_READ,IER) + ELSE + IER = 0 + END IF + ELSE IF (READ_TAG.AND.IER.EQ.BULL_READ+1) THEN + CALL GET_THIS_TAG(FOLDER_NUMBER,IER1,BULL_READ) + IF (IER1.NE.0) IER = 0 + END IF + CALL CLOSE_BULLDIR + ELSE + IER = 0 + END IF + END IF + + IF (IER.NE.BULL_READ+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + RETURN + END IF + + DIFF = COMPARE_BTIM(MSG_BTIM,LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF.GT.0) THEN + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = MSG_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = MSG_BTIM(2) + END IF + + BULL_POINT = BULL_READ ! Update bulletin counter + + IF (INCMD(:4).EQ.'READ'.OR.INCMD(:4).EQ.'CURR') THEN + IF (CLI$PRESENT('EDIT')) THEN + CALL READ_EDIT + RETURN + END IF + END IF + + FLEN = TRIM(FOLDER) + IF (BULL_POINT.GT.F_NBULL) F_NBULL = BULL_POINT + WRITE (INPUT,'(1X,I5,'' of '',I5)') BULL_POINT,F_NBULL + DO WHILE (INDEX(INPUT,' ').LT.TRIM(INPUT)) + I = INDEX(INPUT,' ') + INPUT(I:) = INPUT(I+1:) + END DO + I = TRIM(INPUT) + INPUT = ' #'//INPUT(2:TRIM(INPUT)) + INPUT(PAGE_WIDTH-LEN(FOLDER):) = FOLDER(:FLEN) + IF (READIT.GT.0) THEN + WRITE(6,'(A)') '+'//INPUT(:TRIM(INPUT)) + ELSE + WRITE(6,'(1X,A)') INPUT(:TRIM(INPUT)) + END IF + + END = 1 ! Outputted 1 line to screen + + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + WRITE (6,'(1X,A)') INPUT(:TRIM(INPUT)) + + END = END + 1 + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + LINE_OFFSET = 0 + CHAR_OFFSET = 0 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INPUT = 'From: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + WRITE(6,'(1X,A)') INPUT(:I) + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = 1 + ELSE + WRITE(6,'('' From: '',A)') FROM + END = END + 1 + END IF + IF (INPUT(:6).NE.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + INPUT = 'Subj: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + WRITE(6,'(1X,A)') INPUT(:I) + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = LINE_OFFSET + 1 + ELSE + IF (LINE_OFFSET.EQ.1) THEN + CHAR_OFFSET = 1 - PAGE_WIDTH + LINE_OFFSET = 2 + END IF + WRITE(6,'('' Subj: '',A)') DESCRIP + END = END + 1 + END IF + IF (LINE_OFFSET.EQ.0) ILEN = LINE_LENGTH + 1 + CALL CLOSE_BULLFIL ! End of bulletin file read + + WRITE(6,'(1X)') + IF (READIT.GT.0) WRITE(6,'(1X)') + END = END + 1 +C +C Each page of the bulletin is buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C bulletin file, and to avoid the possibility of the user holding the screen, +C and thus causing the bulletin file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_B1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + IF (SCRATCH_B1.NE.0) THEN ! Is queue empty? + SCRATCH_B = SCRATCH_B1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_B,INPUT) + SCRATCH_B1 = SCRATCH_B ! Init header pointer + END IF + + READ_ALREADY = 0 ! Number of lines already read + ! from record. + IF (READ_COUNT.EQ.-2) THEN ! Just output header first read + READ_COUNT = BLOCK + RETURN + ELSE + READ_COUNT = BLOCK ! Init bulletin record counter + END IF + + GO TO 200 + +100 IF (READIT.EQ.0) THEN ! If not 1st page of READ + WRITE (BUFFER,'(1X,I5,'' of '',I5)') BULL_POINT,F_NBULL + DO WHILE (INDEX(BUFFER,' ').LT.TRIM(BUFFER)) + I = INDEX(BUFFER,' ') + BUFFER(I:) = BUFFER(I+1:) + END DO + BUFFER = ' #'//BUFFER(2:TRIM(BUFFER)) + BUFFER(PAGE_WIDTH-LEN(FOLDER):) = FOLDER(:FLEN) + WRITE(6,'(1X,A,/)') BUFFER(:TRIM(BUFFER)) ! Output header info + END = END + 2 ! Increase display counter + END IF + +200 SCRATCH_B = SCRATCH_B1 ! Init queue pointer to header + IF (READIT.GT.0) END = END - 2 ! /READ can output 2 more lines + DISPLAY = 0 + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + MORE_LINES = .TRUE. + DO WHILE (ILEN.GT.0.AND.MORE_LINES) + IF (CHAR_OFFSET.EQ.0) THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + LINE_OFFSET = LINE_OFFSET + 1 + END IF + IF (ILEN.LT.0) THEN ! Error, couldn't read record + ILEN = 0 ! Fake end of reading file + MORE_LINES = .FALSE. + ELSE IF (ILEN.GT.0) THEN + IF (CHAR_OFFSET.EQ.0) THEN + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (LEN_TEMP.GT.PAGE_WIDTH) THEN + CHAR_OFFSET = 1 + BUFFER = INPUT(:PAGE_WIDTH) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + ELSE + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,INPUT) + END IF + ELSE + CHAR_OFFSET = CHAR_OFFSET + PAGE_WIDTH + IF (LEN_TEMP.LE.CHAR_OFFSET+PAGE_WIDTH-1) THEN + BUFFER = INPUT(CHAR_OFFSET:LEN_TEMP) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + CHAR_OFFSET = 0 + ELSE + BUFFER = INPUT(CHAR_OFFSET:CHAR_OFFSET+PAGE_WIDTH-1) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + END IF + END IF + DISPLAY = DISPLAY + 1 + IF ((DISPLAY.EQ.PAGE_LENGTH-END-4).AND.PAGE) THEN + MORE_LINES = .FALSE. + END IF + END IF + END DO + + CALL CLOSE_BULLFIL ! End of bulletin file read + +C +C Bulletin page is now in temporary memory, so output to terminal. +C Note that if this is a /READ, the first line will have problems with +C the usual FORMAT statement. It will cause a blank line to be outputted +C at the top of the screen. This is because of the input QIO at the +C end of the previous page. The output gets confused and thinks it must +C end the previous line. To prevent that, the first line of a new page +C in a /READ must use a different FORMAT statement to surpress the CR/LF. +C + + SCRATCH_B = SCRATCH_B1 ! Reinit queue pointer to head + DO I=1,DISPLAY ! Output page to terminal + CALL READ_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) ! Get queue record + IF (I.EQ.1.AND.READIT.GT.0) THEN + WRITE(6,'(A)') '+'//BUFFER(:TRIM(BUFFER)) ! (See above comments) + ELSE + WRITE(6,'(1X,A)') BUFFER(:TRIM(BUFFER)) + END IF + END DO + + IF (ILEN.EQ.0) THEN ! End of message? + READ_COUNT = 0 ! init bulletin record counter + ELSE ! Possibly end of message since end of page could be last line + CALL TEST_MORE_RECORDS(BLOCK,LENGTH,IREC) + IF (IREC.EQ.0) THEN ! Last record? + CALL TEST_MORE_LINES(ILEN) ! More lines to read? + IF (ILEN.GT.0) THEN ! Yes, there are still more + IF (READIT.EQ.0) WRITE(6,1070) ! say there is more of bulletin + ELSE ! Yes, last line anyway + READ_COUNT = 0 ! init bulletin record counter + END IF + ELSE IF (READIT.EQ.0) THEN ! Not last record so + WRITE(6,1070) ! say there is more of bulletin + END IF + END IF + + RETURN + +1030 FORMAT(' ERROR: Specified message was not found.') +1070 FORMAT(1X,/,' Press RETURN for more...',/) + +2000 FORMAT(A) + + END + + + + + + SUBROUTINE READ_EDIT + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + WRITE(3,1050) INPUT(7:ILEN) + ELSE + WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + CALL CLOSE_BULLFIL + + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A,' Date: ',A) + + RETURN + END + + + SUBROUTINE READNEW(REDO) +C +C SUBROUTINE READNEW +C +C FUNCTION: Displays new non-system bulletins with prompts between bulletins. +C + + IMPLICIT INTEGER (A-Z) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /POINT/ BULL_POINT + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + CHARACTER INREAD*1,FILE_DEF*80,NUMREAD*5 + + DATA LEN_FILE_DEF /0/, INREAD/0/ + + LOGICAL SLOW,SLOW_TERMINAL + + FIRST_MESSAGE = BULL_POINT + + IF (ICHAR(INREAD).EQ.0) THEN ! If calling READNEW for first time + SLOW = SLOW_TERMINAL() ! Check baud rate of terminal + END IF ! to avoid gobs of output + + LEN_P = 0 ! Tells read subroutine there is + ! no bulletin parameter + +1 WRITE(6,1000) ! Ask if want to read new bulletins + + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0) THEN + INREAD = NUMREAD(:1) + IF (INREAD.EQ.'N'.OR.INREAD.EQ.'Q'.OR.INREAD.EQ.'E') THEN + IF (INREAD.EQ.'Q') THEN + WRITE (6,'(''+uit'',$)') + ELSE IF (INREAD.EQ.'E') THEN + WRITE (6,'(''+xit'',$)') + DO I=1,FLONG ! Just show SYSTEM folders + NEW_MSG(I) = NEW_MSG(I).AND.SYSTEM_FLAG(I) + END DO + DO I=1,FLONG ! Test for new messages in SYSTEM folders + IF (NEW_MSG(I).NE.0) RETURN + END DO + CALL EXIT + ELSE + WRITE (6,'(''+o'',$)') + END IF + RETURN ! If NO, exit + ! Include QUIT to be consistent with next question + ELSE + CALL LIB$ERASE_PAGE(1,1) + END IF + END IF + +3 IF (TEMP_READ.GT.0) THEN + IF (TEMP_READ.LT.FIRST_MESSAGE+1.OR.TEMP_READ.GT.NBULL) THEN + WRITE (6,'('' ERROR: Specified new message not found.'')') + GO TO 1 + ELSE + BULL_POINT = TEMP_READ - 1 + END IF + END IF + + READ_COUNT = 0 ! Initialize display pointer + +5 CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + FILE_POINT = BULL_POINT + IF (READ_COUNT.EQ.0) THEN ! Is full bulletin displayed? + CALL OPEN_BULLDIR_SHARED ! If so, see if more new bulls +10 CALL READDIR(BULL_POINT+1,IER_POINT) + IF ((IER_POINT.EQ.BULL_POINT+2).AND. ! If system bulletin (and system + & (SYSTEM.AND.BTEST(FOLDER_FLAG,2))) THEN ! folder) then skip it. + BULL_POINT = BULL_POINT + 1 + GO TO 10 + END IF + CALL CLOSE_BULLDIR + END IF + +12 IF (READ_COUNT.EQ.0) THEN ! Prompt user in between + WRITE(6,1020) ! full screens or end of bull. + ELSE + WRITE(6,1030) + END IF + + CALL GET_INPUT_NOECHO(INREAD) + CALL STR$UPCASE(INREAD,INREAD) ! Convert input to upper case + + IF (INREAD.EQ.'Q') THEN ! If Q , then QUIT + WRITE (6,'(''+Quit'',$)') + RETURN + ELSE IF (INREAD.EQ.'D') THEN ! If D , then redisplay directory + WRITE (6,'(''+Dir'',$)') + REDO = .TRUE. + RETURN + ELSE IF (INREAD.EQ.'F') THEN ! If F then copy bulletin to file + WRITE (6,'(''+ '')') ! Move cursor from end of prompt line + ! to beginning of next line. + IF (LEN_FILE_DEF.EQ.0) THEN + CALL LIB$SYS_TRNLOG('SYS$LOGIN',ILEN,FILE_DEF) + IER = LIB$FIND_FILE(FILE_DEF//'BULL.DIR', + & BULL_PARAMETER,CONTEXT) + IF (IER) THEN + FILE_DEF = BULL_PARAMETER(:ILEN-1)//'.BULL]' + LEN_FILE_DEF = ILEN + 5 + ELSE + FILE_DEF = 'SYS$LOGIN:' + LEN_FILE_DEF = 10 + END IF + END IF + + LEN_FOLDER = TRIM(FOLDER) + CALL GET_INPUT_PROMPT(BULL_PARAMETER,LEN_P, + & 'Name of file? (Default='//FILE_DEF(:LEN_FILE_DEF)// + & FOLDER(:LEN_FOLDER)//'.LIS) ') + + IF (LEN_P.EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)//FOLDER(:LEN_FOLDER) + & //'.LIS' + LEN_P = LEN_FILE_DEF + LEN_FOLDER + 4 + ELSE + IER = LIB$SYS_TRNLOG(BULL_PARAMETER(:LEN_P),ILEN,INPUT) + IF (IER.NE.1.AND.INDEX(BULL_PARAMETER(:LEN_P),':').EQ.0 + & .AND.INDEX(BULL_PARAMETER(:LEN_P),'[').EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)// + & BULL_PARAMETER(:LEN_P) + LEN_P = LEN_P + LEN_FILE_DEF + END IF + END IF + + BLOCK_SAVE = BLOCK + LENGTH_SAVE = LENGTH + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + CALL READDIR(FILE_POINT,IER) + CALL DISABLE_PRIVS + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH,ERR=18,STATUS='UNKNOWN', + & CARRIAGECONTROL='LIST',ACCESS='APPEND') + WRITE(3,1050) DESCRIP ! Output bulletin header info + WRITE(3,1060) FROM,DATE//' '//TIME(:5) + ILEN = LINE_LENGTH + 1 + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE(3,'(A)') INPUT(:TRIM(INPUT)) + END DO + IF (ILEN.EQ.0) WRITE(6,1040) BULL_PARAMETER(:LEN_P) + ! Show name of file created. +18 IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + END IF + CLOSE (UNIT=3) ! Bulletin copy completed + IF (READ_COUNT.GT.0) THEN ! Reposition GET_BULL routine + ILEN = LINE_LENGTH + 1 ! in case read in progress + DO I=1,LINE_OFFSET ! and partial block was read. + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + END IF + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + LENGTH = LENGTH_SAVE + BLOCK = BLOCK_SAVE + CALL ENABLE_PRIVS ! Reset BYPASS privileges + GO TO 12 + ELSE IF (INREAD.EQ.'N'.AND.READ_COUNT.GT.0) THEN + ! If NEXT and last bulletins not finished + READ_COUNT = 0 ! Reset read bulletin counter + CALL OPEN_BULLDIR_SHARED ! Look for NEXT bulletin +20 CALL READDIR(BULL_POINT+1,IER) + IF (IER.NE.BULL_POINT+2) THEN ! If no NEXT bulletin + CALL CLOSE_BULLDIR ! Exit + WRITE(6,1010) + RETURN + ELSE IF (SYSTEM.AND.BTEST(FOLDER_FLAG,2)) THEN + BULL_POINT = BULL_POINT + 1 ! If SYSTEM bulletin, skip it + GO TO 20 ! Look for more bulletins + END IF + CALL CLOSE_BULLDIR + ELSE IF (INREAD.EQ.'R') THEN + WRITE (6,'(''+Read'')') + WRITE (6,'('' Enter message number: '',$)') + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0.OR.TEMP_READ.LE.0) THEN + WRITE (6,'('' ERROR: Invalid message number specified.'')') + GO TO 12 + ELSE + GO TO 3 + END IF + ELSE IF (IER_POINT.NE.BULL_POINT+2.AND.READ_COUNT.EQ.0) THEN + WRITE(6,1010) + RETURN + END IF + IF (READ_COUNT.EQ.0.AND.SLOW) READ_COUNT = -2 + GO TO 5 + +1000 FORMAT(' Read messages? Type N(No),E(Exit),message + & number, or any other key for yes: ',$) +1010 FORMAT(' No more messages.') +1020 FORMAT(1X,('-'),/,' Type Q(Quit), + & F(File it), D(Dir), R(Read msg #) or other for next message: ',$) +1030 FORMAT(1X,('-'),/,' Type Q(Quit), F(File), N(Next), + & D(Dir), R(Read msg #) or other for MORE: ',$) +1040 FORMAT(' Message written to ',A) +1050 FORMAT(/,'Description: ',A53) +1060 FORMAT('From: ',A12,' Date: ',A20,/) + + END + + + + + SUBROUTINE SET_DEFAULT_EXPIRE +C +C SUBROUTINE SET_DEFAULT_EXPIRE +C +C FUNCTION: Sets default expiration date. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER EXPIRE*3 + + IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + IER = CLI$GET_VALUE('DEFAULT_EXPIRE',EXPIRE,EX_LEN) + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + ELSE IF (TEMP.LT.-1) THEN + WRITE (6,'('' ERROR: Expiration must be > -1.'')') + ELSE + FOLDER_BBEXPIRE = TEMP + WRITE (6,'('' Default expiration modified.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to set expiration.'')') + END IF + + RETURN + END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin2.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin2.for new file mode 100644 index 0000000..189f9d6 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin2.for @@ -0,0 +1,1638 @@ +C +C BULLETIN2.FOR, Version 11/27/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE SET_BBOARD(BBOARD) +C +C SUBROUTINE SET_BBOARD +C +C FUNCTION: Set username for BBOARD for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($UAIDEF)' + + EXTERNAL CLI$_ABSENT + + CHARACTER EXPIRE*3,INPUT_BBOARD*12,TODAY*23,RESPONSE*1 + + IF (TRIM(BBOARD_DIRECTORY).EQ.0) THEN + WRITE(6,'('' ERROR: System programmer has disabled BBOARD.'')') + RETURN + END IF + + IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + WRITE (6,'( + & '' ERROR: Cannot set BBOARD for remote folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + + IF (BBOARD) THEN + IER = CLI$GET_VALUE('BB_USERNAME',INPUT_BBOARD,INPUT_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_UAF + & (INPUT_BBOARD,USERB,GROUPB,ACCOUNTB,FLAGS,IER1) + CALL CLOSE_BULLFOLDER + IF (IER1.AND..NOT.BTEST(FLAGS,UAI$V_DISACNT)) THEN ! DISUSER? + WRITE (6,'('' ERROR: '',A, + & '' account needs DISUSER flag set.'')') + & INPUT_BBOARD(:INPUT_LEN) + RETURN + ELSE IF (IER1.AND.BTEST(USERB,31)) THEN + WRITE (6,'('' ERROR: User number of UIC cannot '', + & ''be greater than 7777777777.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_TEMP(IER) + DO WHILE ((FOLDER1_BBOARD.NE.INPUT_BBOARD.OR. + & FOLDER1_NUMBER.EQ.FOLDER_NUMBER).AND.IER.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER) + END DO + IF (FOLDER1_BBOARD.EQ.INPUT_BBOARD.AND. + & FOLDER1_NUMBER.NE.FOLDER_NUMBER) THEN + WRITE (6,'( + & '' ERROR: Account used by other folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + IF (.NOT.IER1) THEN + CALL CLOSE_BULLFOLDER + WRITE (6,'('' WARNING: '',A,'' account not in SYSUAF'', + & '' file.'')') INPUT_BBOARD(:INPUT_LEN) + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Is the name a mail forwarding entry? '// + & '(Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + USERB = 1 ! Fake userb/groupb, as old method of + GROUPB = 1 ! indicating /SPECIAL used [0,0] + END IF + GROUPB1 = GROUPB + USERB1 = USERB + ACCOUNTB1 = ACCOUNTB + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + GROUPB = GROUPB1 + USERB = USERB1 + ACCOUNTB = ACCOUNTB1 + FOLDER_BBOARD = INPUT_BBOARD + CALL OPEN_BULLUSER + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM(TODAY,BBOARD_BTIM) + REWRITE (4) USER_HEADER + CALL CLOSE_BULLUSER + IF (CLI$PRESENT('SPECIAL')) THEN ! SPECIAL specified? + USERB = IBSET(USERB,31) ! Set bit to show /SPECIAL + IF (CLI$PRESENT('VMSMAIL')) THEN + GROUPB = IBSET(GROUPB,31) ! Set bit to show /VMSMAIL + END IF + END IF + ELSE IF (CLI$PRESENT('SPECIAL')) THEN + USERB = IBSET(0,31) ! Set top bit to show /SPECIAL + GROUPB = 0 + DO I=1,LEN(FOLDER_BBOARD) + FOLDER_BBOARD(I:I) = ' ' + END DO + ELSE IF (FOLDER_BBOARD.EQ.'NONE') THEN + WRITE (6,'('' ERROR: No BBOARD specified for folder.'')') + END IF + + IER = CLI$GET_VALUE('EXPIRATION',EXPIRE,EX_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (TEMP.LE.0) THEN + WRITE (6,'('' ERROR: Expiration must be > 0.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + FOLDER_BBEXPIRE = TEMP + END IF + ELSE IF (.NOT.CLI$PRESENT('EXPIRATION')) THEN + FOLDER_BBEXPIRE = -1 + END IF + ELSE + FOLDER_BBOARD = 'NONE' + END IF + + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + WRITE (6,'('' BBOARD has been modified for folder.'')') + ELSE + WRITE (6,'('' You are not authorized to modify BBOARD.'')') + END IF + + RETURN + END + + + + + + + SUBROUTINE SET_SYSTEM(SYSTEM_SET) +C +C SUBROUTINE SET_SYSTEM +C +C FUNCTION: Set SYSTEM specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + ELSE IF (SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (SYSTEM_SET) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been set.'')') + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been removed.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL MODIFY_SYSTEM_LIST(0) + CALL CLOSE_BULLFOLDER + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + ELSE + WRITE (6,'('' You are not authorized to modify SYSTEM.'')') + END IF + + RETURN + END + + + + SUBROUTINE MODIFY_SYSTEM_LIST(FILE_OPENED) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + INTEGER SHUTDOWN_BTIM(FLONG),VERSION(FLONG) + + CHARACTER UPDATE*11,UPTIME*8 + + INTEGER UP_BTIM(2) + + IF (.NOT.FILE_OPENED) CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0.OR.VERSION(1).NE.168) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + SHUTDOWN_BTIM(1) = 0 + SHUTDOWN_BTIM(2) = 0 + NODE_NUMBER = 0 + NODE_AREA = 0 + IF (IER.EQ.0) THEN + DO WHILE (TEMP_USER(:7).EQ.'*SYSTEM'.AND.IER.EQ.0) + DELETE (UNIT=4) + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) TEMP_USER + END DO + END DO + IER = 2 + ELSE + VERSION(1) = 168 + END IF + END IF + + IF (VERSION(1).NE.168) THEN + CALL CLOSE_BULLFOLDER + CALL OPEN_BULLFOLDER + NODE_AREA = 0 + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + END DO + IER1 = 0 + DO WHILE (IER1.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER1) + IF (BTEST(FOLDER1_FLAG,2).AND.IER1.EQ.0) THEN + CALL SET2(SYSTEM_FLAG,FOLDER1_NUMBER) + END IF + END DO + VERSION(1) = 168 + END IF + + IF (BTEST(FOLDER_FLAG,2)) THEN + CALL SET2(SYSTEM_FLAG,FOLDER_NUMBER) + ELSE + CALL CLR2(SYSTEM_FLAG,FOLDER_NUMBER) + END IF + + CALL SYS_BINTIM('-',UP_BTIM) ! Get today's date + DIFF = COMPARE_BTIM(SHUTDOWN_BTIM,UP_BTIM) + IF (DIFF.GE.0) THEN ! Must have been in a time wrap + SHUTDOWN_BTIM(1) = UP_BTIM(1) + SHUTDOWN_BTIM(2) = UP_BTIM(2) + END IF + + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14,BTEST(FOLDER_FLAG,2), + & NODENAME + IF (IER1.NE.0) THEN + CALL DISCONNECT_REMOTE + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + RETURN + END IF + END IF + + CALL GET_UPTIME(UPDATE,UPTIME) + + CALL SYS_BINTIM(UPDATE//' '//UPTIME,UP_BTIM) + + IF (NODE_AREA.EQ.0) THEN + IF (SHUTDOWN_BTIM(1).EQ.0) THEN + DIFF = -1 + ELSE + DIFF = COMPARE_BTIM(SHUTDOWN_BTIM,UP_BTIM) + END IF + IF (DIFF.EQ.-1) THEN + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + SHUTDOWN_BTIM(1) = UP_BTIM(1) + SHUTDOWN_BTIM(2) = UP_BTIM(2) + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + END IF + ELSE ! Test to make sure NODE_AREA is zero + SEEN_FLAG = 0 ! if all of SHUTDOWN_FLAG is zero + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 + END IF + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL READ_PERM + + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + + RETURN + END + + + + SUBROUTINE GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) + CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) + CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist + + IER = SYS$GETSYIW(,,,%VAL(GETSYI_ITMLST),,,) ! Get Info command. +C +C NODE_AREA is set to 0 after shutdown messages are deleted. +C If node is not part of cluster, NODE_AREA will be 0, +C so set it to 1 as a dummy value to cause messages to be deleted. +C + IF (NODE_AREA.EQ.0) NODE_AREA = 1 + + RETURN + END + + + + + SUBROUTINE SET_NODE(NODE_SET) +C +C SUBROUTINE SET_NODE +C +C FUNCTION: Set or reset remote node specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,FOLDER_SAVE*25 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) ! Get folder name + FOLDER_SAVE = FOLDER + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + IF (IER.EQ.0) THEN + IF (.NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE (6,'('' ERROR: No privs to modify folder.'')') + IER = 1 + END IF + ELSE + WRITE (6,'('' ERROR: Specified folder not found.'')') + END IF + IF (IER.NE.0) THEN + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + RETURN + END IF + CALL CLOSE_BULLFOLDER + END IF + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' Cannot set remote node for GENERAL folder.'')') + ELSE IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + IF (.NOT.NODE_SET) THEN + IF (INDEX(FOLDER_BBOARD,'*').GT.0) THEN + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + CALL OPEN_BULLDIR ! Remove directory file which + CALL CLOSE_BULLDIR_DELETE ! contains remote folder name + REMOTE_SET = REMOTE_SET_SAVE + END IF + FOLDER1_BBOARD = 'NONE' + WRITE (6,'('' Remote node setting has been removed.'')') + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .FALSE. + ELSE + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Are you sure you want to make folder '// + & FOLDER(:TRIM(FOLDER))// + & ' remote? (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + IER = CLI$GET_VALUE('NODENAME',FOLDER1_BBOARD,FLEN) + FOLDER1_BBOARD = '::'//FOLDER1_BBOARD(:FLEN) + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'( + & '' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE + WRITE (6,'('' Folder has been converted to remote.'')') + END IF + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + IF (FOLDER.NE.FOLDER1) THEN ! Different remote folder name? + CALL OPEN_BULLDIR ! If so, put name in header + BULLDIR_HEADER(13:) = FOLDER1 ! of directory file. + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:FLEN+2)//'*' + END IF + REMOTE_SET = REMOTE_SET_SAVE + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .TRUE. + END IF + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (.NOT.NODE_SET.AND.FOLDER_BBOARD(:2).EQ.'::' + & .AND.BTEST(FOLDER_FLAG,2)) THEN + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER_BBOARD(3:TRIM(FOLDER_BBOARD)) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Disregister remote SYSTEM folder + WRITE(17,'(2A)',IOSTAT=IER) 14,0 + CLOSE (UNIT=17) + END IF + END IF + FOLDER_BBOARD = FOLDER1_BBOARD + IF (NODE_SET) THEN + F_NBULL = F1_NBULL + F_NEWEST_BTIM(1) = F1_NEWEST_BTIM(1) + F_NEWEST_BTIM(2) = F1_NEWEST_BTIM(2) + F_NEWEST_NOSYS_BTIM(1) = F1_NEWEST_NOSYS_BTIM(1) + F_NEWEST_NOSYS_BTIM(2) = F1_NEWEST_NOSYS_BTIM(2) + FOLDER_FLAG = 0 + F_EXPIRE_LIMIT = F1_EXPIRE_LIMIT + ELSE + F_NBULL = 0 + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to modify NODE.'')') + END IF + + IF (CLI$PRESENT('FOLDER')) THEN + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + END IF + + RETURN + END + + + + + SUBROUTINE RESPOND(STATUS) +C +C SUBROUTINE RESPOND +C +C FUNCTION: Sends a mail message in reply to a posted message. +C +C NOTE: Modify the last SPAWN statement to specify the command +C you use to send mail to sites other than via MAIL. +C If you always use a different command, modify both +C spawn commands. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER FROM_TEST*5,INFROM*(LINE_LENGTH) + + EXTERNAL CLI$_NEGATED + + IF (INCMD(:4).NE.'POST') THEN + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + CALL STR$UPCASE(BULL_PARAMETER,DESCRIP) + IF (BULL_PARAMETER(:3).NE.'RE:') THEN + BULL_PARAMETER = 'RE: '//DESCRIP + ELSE + BULL_PARAMETER = 'RE:'//DESCRIP(4:) + END IF + END IF + + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',BULL_PARAMETER,LEN_P) + IF (LEN_P.GT.LEN(BULL_PARAMETER)-2) THEN + WRITE(6,'('' ERROR: Subject limit is 64 characters.'')') + RETURN + END IF + ELSE IF (INCMD(:4).EQ.'POST') THEN + WRITE(6,'('' Enter subject of message:'')') + CALL GET_LINE(BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.0) THEN + WRITE(6,'('' ERROR: No subject specified.'')') + RETURN + END IF + END IF + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + EDIT = .TRUE. + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + ELSE + EDIT = .FALSE. + END IF + + TEXT = CLI$PRESENT('EXTRACT') + + IF (EDIT.AND.TEXT) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + RETURN + END IF + ELSE IF (TEXT.AND..NOT.EDIT) THEN + WRITE (6,'('' ERROR: Cannot extract text without /EDIT.'')') + RETURN + END IF + + LENFRO = 0 + IF (CLI$GET_VALUE('CC',INPUT,ILEN)) THEN + INFROM = INPUT(:ILEN)//',' + LENFRO = ILEN + 1 + END IF + + IF ((EDIT.AND.TEXT).OR.INCMD(:4).NE.'POST') THEN + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INFROM = INFROM(:LENFRO)//INPUT(7:) + LENFRO = LENFRO + ILEN - 6 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + INFROM = INFROM(:LENFRO)//FROM + LENFRO = TRIM(FROM) + LENFRO + END IF + + IF (CLI$PRESENT('LIST')) THEN + INFROM = INFROM(:LENFRO)//',' + LENFRO = LENFRO + 1 + END IF + + IF (INCMD(:4).EQ.'POST') LENFRO = 0 + + IF (EDIT.AND.TEXT) THEN + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + + CALL CLOSE_BULLFIL + END IF + + IF (CLI$PRESENT('LIST')) THEN + LIST = INDEX(FOLDER_DESCRIP,'<') + IF (LIST.GT.0) THEN + INFROM = INFROM(:LENFRO)// + & FOLDER_DESCRIP(LIST+1:TRIM(FOLDER_DESCRIP)-1) + LENFRO = LENFRO + TRIM(FOLDER_DESCRIP) - 1 - LIST + ELSE + WRITE (6,'('' ERROR: No list address'', + & '' found in folder description.'')') + GO TO 900 + END IF + END IF + + I = 1 ! Must change all " to "" in FROM field + DO WHILE (I.LE.LENFRO) + IF (INFROM(I:I).EQ.'"') THEN + INFROM = INFROM(:I)//'"'//INFROM(I+1:) + I = I + 1 + LENFRO = LENFRO + 1 + END IF + I = I + 1 + END DO + + LEN_P = TRIM(BULL_PARAMETER) + I = 1 ! Must change all " to "" in SUBJECT field + DO WHILE (I.LE.LEN_P) + IF (BULL_PARAMETER(I:I).EQ.'"') THEN + IF (LEN_P.EQ.64) THEN + BULL_PARAMETER(I:I) = '`' + ELSE + BULL_PARAMETER = BULL_PARAMETER(:I)//'"' + & //BULL_PARAMETER(I+1:) + I = I + 1 + LEN_P = LEN_P + 1 + END IF + END IF + I = I + 1 + END DO + CALL DISABLE_PRIVS + IF (EDIT) THEN + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + IF (TEXT) THEN + CONTEXT = 0 + CALL LIB$FIND_FILE('SYS$LOGIN:BULL.SCR',INPUT,CONTEXT) + VERSION = INDEX(INPUT,';') + 1 + IF (INPUT(VERSION:VERSION).EQ.'1') THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + END IF + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR "'//INFROM(:LENFRO) + & //'"/SUBJECT="'//BULL_PARAMETER//'"',,,,,,STATUS) + ELSE + CALL LIB$SPAWN('$MAIL SYS$INPUT "'//INFROM(:LENFRO)// + & '"/SUBJECT="'//BULL_PARAMETER//'"',,,,,,STATUS) + END IF + CALL ENABLE_PRIVS + +900 IF (EDIT) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + + END + + + INTEGER FUNCTION CONFIRM_USER(USERNAME) +C +C FUNCTION CONFIRM_USER +C +C FUNCTION: Confirms that username is valid user. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + CALL OPEN_SYSUAF_SHARED + + READ (8,KEY=USERNAME,IOSTAT=CONFIRM_USER) + + CALL CLOSE_SYSUAF + + RETURN + END + + + + + + SUBROUTINE REPLACE +C +C SUBROUTINE REPLACE +C +C FUNCTION: Replaces existing bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER INEXDATE*11,INEXTIME*11 + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH) + CHARACTER*1 ANSWER + + CHARACTER DATE_SAVE*11,TIME_SAVE*11 + + INTEGER TIMADR(2) + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + LOGICAL*1 DOALL + +C +C Get the bulletin number to be replaced. +C + + ALL = CLI$PRESENT('ALL') + + IER1 = CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + IF (IER1.EQ.%LOC(CLI$_ABSENT).AND..NOT.ALL) THEN + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE (6,1005) ! Tell user of the error + RETURN ! and return + END IF + SBULL = BULL_POINT ! Replace the bulletin we are reading + EBULL = SBULL + + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) ! Get message directory entry + CALL CLOSE_BULLDIR + IF (IER.NE.BULL_POINT+1) THEN ! Was message found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + RETURN + END IF + ELSE + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) ! Get message directory entry + CALL CLOSE_BULLDIR + IF (NBULL.EQ.0) THEN ! Were messages found? + WRITE(6,'('' ERROR: No messages were found.'')') + RETURN + END IF + + IF (IER1.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER1) + IF (SBULL.LE.0.OR.IER1.NE.0) THEN + WRITE (6,'(A)') + & ' ERROR: Specified message number has incorrect format.' + RETURN + END IF + ALL = .TRUE. + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = NBULL + END IF + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to system.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SYSTEM cannot be set with selected folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to shutdown.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SHUTDOWN cannot be set with selected folder.'')') + RETURN + ELSE IF (CLI$GET_VALUE('SHUTDOWN',BULL_PARAMETER).NE. + & %LOC(CLI$_ABSENT).AND.REMOTE_SET) THEN + WRITE (6,'('' ERROR: Shutdown node name not'', + & '' permitted for remote folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('PERMANENT').AND. + & .NOT.FOLDER_SET.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to permanent.'')') + RETURN + END IF +C +C Check to see if specified bulletin is present, and if the user +C is permitted to replace the bulletin. +C + + CALL OPEN_BULLDIR_SHARED + + SAME_OWNER = .TRUE. + DO I=SBULL,EBULL + CALL READDIR(I,IER) ! Get info for specified messages + IF (USERNAME.NE.FROM) SAME_OWNER = .FALSE. + END DO + CALL READDIR(SBULL,IER) + + CALL CLOSE_BULLDIR + + IF (.NOT.SAME_OWNER) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER) + & .AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1090) ! If not, then error out. + RETURN + ELSE + WRITE (6,1100) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER ! Get his answer + CALL STR$UPCASE(ANSWER,ANSWER) ! Convert input to uppercase + IF (ANSWER.NE.'Y') RETURN ! If not Yes, then exit + END IF + END IF + +C +C If no switches were given, replace the full bulletin +C + + DOALL = .FALSE. + + TEXT = CLI$PRESENT('TEXT') + + IF ((.NOT.CLI$PRESENT('EXPIRATION')).AND. + & (.NOT.CLI$PRESENT('GENERAL')).AND. + & (.NOT.CLI$PRESENT('SYSTEM')).AND. + & (.NOT.CLI$PRESENT('HEADER')).AND. + & (.NOT.CLI$PRESENT('SUBJECT')).AND. + & (.NOT.TEXT).AND. + & (.NOT.CLI$PRESENT('SHUTDOWN')).AND. + & (.NOT.CLI$PRESENT('PERMANENT'))) THEN + DOALL = .TRUE. + END IF + + IF (SBULL.NE.EBULL.AND.(DOALL.OR.TEXT)) THEN + WRITE (6,'('' ERROR: Cannot change text when replacing'', + & '' more than one messsage.'')') + RETURN + END IF + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + +8 LENDES = 0 + IF (CLI$PRESENT('HEADER').OR.DOALL) THEN + WRITE(6,1050) ! Request header for bulletin + READ(5,'(Q,A)',END=910,ERR=910) LENDES,INDESCRIP + IF (LENDES.EQ.0) GO TO 910 ! If no header, don't add bull + ELSE IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + END IF + + IF (LENDES.GT.0) THEN + INDESCRIP = 'Subj: '//INDESCRIP + LENDES = MIN(LENDES+6,LEN(INDESCRIP)) + END IF + + IF (SBULL.NE.EBULL) CALL OPEN_BULLDIR + + DO NUMBER=SBULL,EBULL + NUMBER_PARAM = NUMBER + IF (SBULL.NE.EBULL) THEN + CALL READDIR(NUMBER_PARAM,IER) + IF (IER.NE.NUMBER_PARAM+1) THEN ! Couldn't find message + CALL CLOSE_BULLDIR + WRITE(6,'('' ERROR: Message '',I5,'' cannot be found.'')') + & NUMBER_PARAM + WRITE(6,'('' All messages up to that message were modified.'')') + RETURN + END IF + END IF + + REC1 = 0 + + LENFROM = 0 + + IF (LENDES.GT.0.OR.TEXT.OR.DOALL) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='SCRATCH',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + REC1 = 1 + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INFROM = INPUT(:ILEN) + LENFROM = ILEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (LENDES.EQ.0.AND..NOT.DOALL) THEN + INDESCRIP = INPUT(:ILEN) + LENDES = ILEN + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + CALL CLOSE_BULLFIL + + IF (TEXT.OR.DOALL) CLOSE(UNIT=3) + END IF + + IF (TEXT.OR.DOALL) THEN +C +C If file specified in REPLACE command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + ICOUNT = 0 ! Line count for bulletin + LAST_NOBLANK = 0 ! Last line with data + REC1 = 1 + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT).OR. ! If file param in ADD command + & ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! or /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)))) THEN + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + IF (LEN_P.EQ.0) THEN ! If no file param specified + IF (.NOT.CLI$PRESENT('NEW')) THEN + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='NEW', + & RECL=LINE_LENGTH, + & ERR=920,FORM='FORMATTED',CARRIAGECONTROL='LIST') + CALL OPEN_BULLFIL_SHARED ! Prepare to copy message + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy message into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + CALL CLOSE_BULLFIL + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + ELSE + CALL DISABLE_PRIVS + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + END IF + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;-1') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + ELSE IF (LEN_P.GT.0) THEN + CALL DISABLE_PRIVS + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD', + & READONLY,SHARED,ERR=920,FORM='FORMATTED') ! Try opening the file + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT ! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + CALL STR$TRIM(INPUT,INPUT,ILEN) + IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN + 1 ! Increment record count + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0) THEN + IF (ICOUNT.GT.0) THEN + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + ELSE ! 1 space for a blank line. + REC1 = REC1 + 1 + END IF + END IF + END DO + ELSE ! If no input file + OPEN (UNIT=3,STATUS='NEW',FILE='SYS$LOGIN:BULL.SCR',ERR=920, + & DISPOSE='DELETE',FORM='FORMATTED',RECL=LINE_LENGTH, + & CARRIAGECONTROL='LIST') ! Scratch file to save bulletin + WRITE (6,1000) ! Request bulletin input from terminal + ILEN = LINE_LENGTH ! Length of input line + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Line too long. + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput::'')') LINE_LENGTH + ELSE IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + 1 + ILEN ! Increment character count + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.0) THEN + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + END IF ! 1 space for a blank line. + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 ICOUNT = LAST_NOBLANK + IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + END IF + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + DATE_SAVE = DATE + TIME_SAVE = TIME + INPUT = DESCRIP + + IF (SBULL.EQ.EBULL) THEN + CALL OPEN_BULLDIR ! Prepare to add dir entry + CALL READDIR(NUMBER_PARAM,IER) ! Get info for message + + IF (IER.NE.NUMBER_PARAM+1.OR.DATE.NE.DATE_SAVE.OR. + & TIME.NE.TIME_SAVE.OR.INPUT.NE.DESCRIP) THEN + ! If message disappeared, try to find it. + IF (IER.NE.NUMBER_PARAM+1) DATE = ' ' + NUMBER_PARAM = 0 + IER = 1 + DO WHILE (IER.EQ.NUMBER_PARAM+1.AND. + & (DATE.NE.DATE_SAVE.OR.TIME.NE.TIME_SAVE.OR.DESCRIP.NE.INPUT)) + NUMBER_PARAM = NUMBER_PARAM + 1 + CALL READDIR(NUMBER_PARAM,IER) + END DO + + IF (IER.NE.NUMBER_PARAM+1) THEN ! Couldn't find message + CALL CLOSE_BULLDIR + CLOSE (UNIT=3,STATUS='SAVE') + WRITE(6,'('' ERROR: Message has been deleted'', + & '' by another user.'')') + IF (DOALL.OR.TEXT) THEN + WRITE (6,'('' New text has been saved in'', + & '' SYS$LOGIN:BULL.SCR.'')') + END IF + GO TO 100 + END IF + END IF + END IF + + CALL READDIR(0,IER) ! Get directory header + + IF (REC1.GT.0) THEN ! If text has been replaced + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + BLOCK = NBLOCK + 1 + BLOCK_SAVE = BLOCK + NEMPTY = NEMPTY + LENGTH + + OBLOCK = BLOCK + IF (LENFROM.GT.0) THEN + CALL STORE_BULL(LENFROM,INFROM(:LENFROM),OBLOCK) + END IF + IF (LENDES.GT.0) THEN + CALL STORE_BULL(LENDES,INDESCRIP(:LENDES),OBLOCK) + END IF + REWIND (UNIT=3) + CALL COPY_BULL(3,REC1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) THEN ! Error in creating bulletin + WRITE (6,'(A)') ' ERROR: Unable to replace message.' + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + END IF + + LENGTH_SAVE = OCOUNT - BLOCK + 1 + NBLOCK = NBLOCK + LENGTH_SAVE + + IF (.NOT.REMOTE_SET) CALL WRITEDIR(0,IER) + + CALL CLOSE_BULLFIL + + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(NUMBER_PARAM,IER) ! Get directory entry + LENGTH = LENGTH_SAVE ! Update size + BLOCK = BLOCK_SAVE + CALL WRITEDIR(NUMBER_PARAM,IER) ! Write new directory entry + END IF + ELSE + CALL READDIR(NUMBER_PARAM,IER) + END IF + + IF (.NOT.REMOTE_SET) THEN + + IF (LENDES.GT.0.OR.DOALL) THEN + DESCRIP=INDESCRIP(7:59) ! Update description header + END IF + CALL UPDATE_DIR_HEADER(CLI$PRESENT('EXPIRATION').OR.DOALL, + & CLI$PRESENT('PERMANENT'),CLI$PRESENT('SHUTDOWN'), + & INEXDATE,INEXTIME) + IF (CLI$PRESENT('SYSTEM')) THEN + SYSTEM = IBSET(SYSTEM,0) + ELSE IF (CLI$PRESENT('GENERAL')) THEN + SYSTEM = IBCLR(SYSTEM,0) + END IF + CALL WRITEDIR(NUMBER_PARAM,IER) + ELSE + MSGTYPE = 0 + IF (CLI$PRESENT('SYSTEM').OR. + & (BTEST(SYSTEM,0).AND..NOT.CLI$PRESENT('GENERAL'))) THEN + MSGTYPE = IBSET(MSGTYPE,0) + END IF + IF (CLI$PRESENT('PERMANENT')) THEN + MSGTYPE = IBSET(MSGTYPE,1) + ELSE IF (CLI$PRESENT('SHUTDOWN')) THEN + MSGTYPE = IBSET(MSGTYPE,2) + ELSE IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + MSGTYPE = IBSET(MSGTYPE,3) + END IF + IF (LENDES.EQ.0.AND..NOT.DOALL) INDESCRIP(7:) = DESCRIP + IF (CLI$PRESENT('EXPIRATION')) THEN + EXDATE = INEXDATE + EXTIME = INEXTIME + END IF + WRITE (REMOTE_UNIT,'(7A)',IOSTAT=IER) + & 10,DESCRIP,NUMBER_PARAM,INDESCRIP(7:59),MSGTYPE,EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + END DO + + CALL CLOSE_BULLDIR ! Totally finished with replace + + CLOSE (UNIT=3) + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + RETURN + +910 WRITE(6,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(6,1020) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + GOTO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1005 FORMAT (' ERROR: You are not reading any message.') +1010 FORMAT (' No message was replaced.') +1015 FORMAT (' ERROR: Specified message was not found.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1090 FORMAT(' ERROR: Specified message is not owned by you.') +1100 FORMAT(' Message(s) is not owned by you.', + & ' Are you sure you want to replace it? ',$) +2020 FORMAT(1X,A) + + END + + + + SUBROUTINE UPDATE_DIR_HEADER(EXPIRE,PERM,SHUT,INEXDATE,INEXTIME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER TODAY*23,INEXDATE*11,INEXTIME*11 + + IF (EXPIRE) THEN + SYSTEM = IBCLR(SYSTEM,1) + SYSTEM = IBCLR(SYSTEM,2) + EXDATE=INEXDATE ! Update expiration date + EXTIME=INEXTIME + DIFF = COMPARE_DATE(EXDATE,NEWEST_EXDATE) ! Compare expiration + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,NEWEST_EXTIME) + IF (DIFF.LT.0) THEN ! If it's oldest expiration bull + NEWEST_EXDATE = EXDATE ! Update the header in + NEWEST_EXTIME = EXTIME ! the directory file + CALL WRITEDIR(0,IER) + END IF + ELSE IF (PERM.AND.(.NOT.BTEST(SYSTEM,1))) THEN + IF (BTEST(SYSTEM,2)) THEN + SYSTEM = IBCLR(SYSTEM,2) + SHUTDOWN = SHUTDOWN - 1 + CALL WRITEDIR(0,IER) + END IF + SYSTEM = IBSET(SYSTEM,1) + EXDATE = '5-NOV-2000' + EXTIME = '00:00:00.00' + ELSE IF (SHUT.AND.(.NOT.BTEST(SYSTEM,2))) THEN + SYSTEM = IBSET(SYSTEM,2) + SYSTEM = IBCLR(SYSTEM,1) + EXDATE = '5-NOV-2000' + NODE_AREA = 0 + IF (INCMD(:4).EQ.'REPL') THEN + IF (CLI$GET_VALUE('SHUTDOWN',NODE_NAME) + & .NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,NODE_NAME) + IF (NODE_AREA.EQ.0) THEN + WRITE (6,'('' ERROR: Shutdown node name ignored.'', + & '' Invalid node name specified.'')') + END IF + END IF + END IF + IF (NODE_AREA.EQ.0) 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) + SHUTDOWN = SHUTDOWN + 1 + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + SHUTDOWN_DATE = TODAY(:11) + SHUTDOWN_TIME = TODAY(13:) + CALL WRITEDIR(0,IER) + END IF + + RETURN + END + + + + + SUBROUTINE SEARCH(READ_COUNT) +C +C SUBROUTINE SEARCH +C +C FUNCTION: Search for bulletin with specified string +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*132 SEARCH_STRING + + START_BULL = BULL_POINT + + IF (CLI$PRESENT('START')) THEN ! Starting message specified + CALL CLI$GET_VALUE('START',BULL_PARAMETER,LEN_P) + DECODE(LEN_P,'(I)',BULL_PARAMETER) START_BULL + IF (.NOT.CLI$PRESENT('REPLY')) START_BULL = START_BULL - 1 + END IF + + IER1 = CLI$GET_VALUE('SEARCH_STRING',SEARCH_STRING,SEARCH_LEN) + + CALL GET_SEARCH(FOUND,SEARCH_STRING,START_BULL, + & CLI$PRESENT('REVERSE'),CLI$PRESENT('SUBJECT'), + & CLI$PRESENT('REPLY'),.TRUE.,CLI$PRESENT('START')) + + IF (FOUND.GT.0) THEN + BULL_POINT = FOUND - 1 + CALL READ(READ_COUNT,BULL_POINT+1) ! Read next bulletin + ELSE IF (FOUND.EQ.0) THEN + WRITE (6,'('' No messages found with given search string.'')') + ELSE IF (FOUND.EQ.-2) THEN + WRITE (6,'('' ERROR: No more messages.'')') + END IF + + RETURN + END + + + + + SUBROUTINE GET_SEARCH(FOUND,SEARCH_STRING,START_BULL,REVERSE, + & SUBJECT,REPLY,FILES,START) +C +C SUBROUTINE GET_SEARCH +C +C FUNCTION: Search for bulletin with specified string +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) SEARCH_STRING + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*132 SAVE_STRING + DATA SAVE_STRING/' '/ + + CHARACTER*53 DESCRIP1 + + FOUND = -1 + + CALL DISABLE_CTRL + + CALL DECLARE_CTRLC_AST + + IF (TRIM(SEARCH_STRING).EQ.0) THEN + IER1 = .FALSE. + ELSE + IER1 = .TRUE. + END IF + + IF (.NOT.IER1.AND..NOT.REPLY.AND. + & (SUBJECT.OR.SEARCH_MODE.NE.1)) THEN + ! If no search string entered + SEARCH_STRING = SAVE_STRING ! use saved search string + IF (TRIM(SAVE_STRING).EQ.0) THEN + WRITE (6,'('' No search string present.'')') + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + RETURN + END IF + IF (STEP_BULL.EQ.-1) START_BULL = START_BULL - 2 + ELSE IF (.NOT.IER1.AND.SEARCH_MODE.EQ.1) THEN + SEARCH_STRING = SAVE_STRING ! use saved search string + END IF + + IF (FILES) CALL OPEN_BULLDIR_SHARED + + CALL READDIR(0,IER) + + OLD_SEARCH_MODE = SEARCH_MODE + IF (IER1) THEN ! If string entered + IF (SUBJECT) THEN + SEARCH_MODE = 3 + ELSE + SEARCH_MODE = 2 + END IF + ELSE IF (SUBJECT.AND.SEARCH_MODE.NE.3) THEN + SEARCH_MODE = 3 + ELSE IF (REPLY) THEN + CALL READDIR(START_BULL,IER) + IF (START_BULL+1.NE.IER) THEN + WRITE (6,'('' ERROR: No message being read.'')') + IF (FILES) CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + RETURN + ELSE + SEARCH_MODE = 1 + SEARCH_STRING = DESCRIP + IF (REVERSE) START_BULL = START_BULL - 2 + END IF + END IF + + SAVE_STRING = SEARCH_STRING + SEARCH_LEN = TRIM(SAVE_STRING) + + CALL STR$UPCASE(SEARCH_STRING,SEARCH_STRING) ! Make upper case + + IF (IER1.OR.SEARCH_MODE.NE.OLD_SEARCH_MODE.OR. + & REVERSE.OR.REPLY) THEN + IF (.NOT.START.AND.SEARCH_MODE.NE.1) THEN + START_BULL = 0 ! If starting message not specified, use first + IF (REVERSE) START_BULL = NBULL - 1 ! or last + END IF + IF (REVERSE) THEN + END_BULL = 1 + STEP_BULL = -1 + ELSE + END_BULL = NBULL + STEP_BULL = 1 + END IF + END IF + + IF ((START_BULL+1.GT.NBULL.AND.STEP_BULL.EQ.1).OR. + & (START_BULL+1.EQ.0)) THEN + FOUND = -2 + IF (FILES) CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + RETURN + END IF + + IF (FILES) CALL OPEN_BULLFIL_SHARED + + DO BULL_SEARCH = START_BULL+1, END_BULL, STEP_BULL + CALL READDIR(BULL_SEARCH,IER) ! Get bulletin directory entry + IF (IER.EQ.BULL_SEARCH+1.AND.SEARCH_MODE.NE.2) THEN + CALL STR$UPCASE(DESCRIP1,DESCRIP) ! Make upper case + IF ((SEARCH_MODE.EQ.3.AND. + & INDEX(DESCRIP1,SEARCH_STRING(:SEARCH_LEN)).GT.0).OR. + & (SEARCH_MODE.EQ.1.AND.(DESCRIP1.EQ.SEARCH_STRING.OR. + & INDEX(SEARCH_STRING,DESCRIP1(5:)).EQ.1))) THEN + FOUND = BULL_SEARCH + GO TO 900 + ELSE IF (FLAG.EQ.1) THEN + WRITE (6,'('' Search aborted.'')') + GO TO 900 + END IF + END IF + IF (IER.EQ.BULL_SEARCH+1.AND.SEARCH_MODE.EQ.2) THEN + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,BULL_SEARCH + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + GO TO 900 + ELSE + CALL GET_REMOTE_MESSAGE(IER) + IF (IER.GT.0) GO TO 900 + END IF + END IF + ILEN = LINE_LENGTH + 1 + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + CALL STR$UPCASE(INPUT,INPUT) ! Make upper case + IF (INDEX(INPUT,SEARCH_STRING(:SEARCH_LEN)).GT.0) THEN + FOUND = BULL_SEARCH + GO TO 900 + ELSE IF (FLAG.EQ.1) THEN + WRITE (6,'('' Search aborted.'')') + GO TO 900 + END IF + END DO + END IF + END DO + + FOUND = 0 + +900 IF (FILES) CALL CLOSE_BULLFIL ! End of bulletin file read + IF (FILES) CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + + RETURN + END + + + + + SUBROUTINE UNDELETE +C +C SUBROUTINE UNDELETE +C +C FUNCTION: Undeletes deleted message. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + +C +C Get the bulletin number to be undeleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + DECODE(LEN_P,5,BULL_PARAMETER,ERR=920) BULL_DELETE ! Yes +5 FORMAT(I) + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + GO TO 910 ! No, then error. + ELSE + BULL_DELETE = BULL_POINT ! Delete the file we are reading + END IF + + IF (BULL_DELETE.LE.0) GO TO 920 + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + CALL OPEN_BULLDIR + + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER) + & .AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1040) ! Then error out. + GO TO 100 + ELSE + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + END IF + END IF + + IF ((SYSTEM.AND.7).LE.1) THEN ! General or System message + EXDATE = EXDATE(:7)//'19'//EXDATE(10:) + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(:6)//'20'//EXDATE(9:) + ELSE + EXDATE = EXDATE(:7)//'20'//EXDATE(10:) + END IF + END IF + + IF (.NOT.REMOTE_SET) THEN + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + WRITE (6,'('' Message was undeleted.'')') + ELSE + WRITE (REMOTE_UNIT,'(5A)',IOSTAT=IER) + & 11,BULL_DELETE,DESCRIP,EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + ELSE + WRITE (6,'('' Message was undeleted.'')') + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + +100 CALL CLOSE_BULLDIR + +900 RETURN + +910 WRITE(6,1010) + GO TO 900 + +920 WRITE(6,1020) + GO TO 900 + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not undeleted. Not owned by you.') + + END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin3.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin3.for new file mode 100644 index 0000000..b67007b --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin3.for @@ -0,0 +1,1738 @@ +C +C BULLETIN3.FOR, Version 11/27/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE UPDATE +C +C SUBROUTINE UPDATE +C +C FUNCTION: Searches for bulletins that have expired and deletes them. +C +C NOTE: Assumes directory file is already opened. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER*107 DIRLINE + + CHARACTER*11 TEMP_DATE,TEMP_EXDATE,TEMP_NOSYSDATE + CHARACTER*11 TEMP_TIME,TEMP_EXTIME,TEMP_NOSYSTIME + + IF (REMOTE_SET.AND. + & NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + + IF (TEST_BULLCP().OR.REMOTE_SET) RETURN + ! BULLCP cleans up expired bulletins + + ENTRY UPDATE_ALWAYS ! Entry to skip BULLCP test + + TEMP_EXDATE = '5-NOV-2000' ! If a bulletin gets deleted, and there are + TEMP_EXTIME = '00:00:00.00' ! are no more bulletins, this is the value + ! assigned to the latest expiration date + + TEMP_DATE = '5-NOV-1956' ! Storage for computing newest + TEMP_TIME = '00:00:00.00' ! bulletin date if deletion occurs + + TEMP_NOSYSDATE = '5-NOV-1956' ! Storage for computing newest + TEMP_NOSYSTIME = '00:00:00.00' ! non-system bulletin date + + BULL_ENTRY = 1 ! Init bulletin pointer + UPDATE_DONE = 0 ! Flag showing bull has been deleted + + NEW_SHUTDOWN = 0 + OLD_SHUTDOWN = SHUTDOWN + + DO WHILE (1) + CALL READDIR(BULL_ENTRY,IER) ! Get next directory entry + IF (IER.EQ.BULL_ENTRY) GO TO 100 ! ERROR: Not found + IF ((SYSTEM.AND.7).LE.3.OR.(OLD_SHUTDOWN.EQ.0 + ! If not shutdown, or time + & .AND.(SYSTEM.AND.4).EQ.4)) THEN ! to delete shutdowns? + IF ((SYSTEM.AND.4).EQ.4) THEN ! Shutdown bulletin? + IF (NODE_AREA.GT.0) THEN + EXTIME(3:4) = EXTIME(4:5) + READ (EXTIME(1:4),'(I4)') NODE_NUMBER_MSG + EXTIME(9:10) = EXTIME(10:11) + READ (EXTIME(7:10),'(I4)') NODE_AREA_MSG + IF (NODE_NUMBER_MSG.EQ.NODE_NUMBER.AND. + & NODE_AREA_MSG.EQ.NODE_AREA) THEN + DIFF = 0 + ELSE + DIFF = 1 + END IF + ELSE + DIFF = COMPARE_DATE(EXDATE,' ') + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,' ') + END IF + IF (DIFF.GT.0) NEW_SHUTDOWN = NEW_SHUTDOWN + 1 + ELSE + DIFF = COMPARE_DATE(EXDATE,' ') ! Has expiration date passed? + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,' ') + END IF + IF (DIFF.LE.0) THEN ! If so then delete bulletin + CALL DELETE_ENTRY(BULL_ENTRY) ! Delete bulletin entry + IF (UPDATE_DONE.EQ.0) THEN ! If this is first deleted file + UPDATE_DONE = BULL_ENTRY ! store it to use for reordering + END IF ! directory file. + ELSE IF ((SYSTEM.AND.7).LE.3) THEN ! Expiration date hasn't passed + ! If a bulletin is deleted, we'll have to update the latest + ! expiration date. The following does that. + DIFF = COMPARE_DATE(EXDATE,TEMP_EXDATE) + IF (DIFF.LT.0.OR.(DIFF.EQ.0.AND. + & COMPARE_TIME(EXTIME,TEMP_EXTIME).LT.0)) THEN + TEMP_EXDATE = EXDATE ! If this is the latest exp + TEMP_EXTIME = EXTIME ! date seen so far, save it. + END IF + TEMP_DATE = DATE ! Keep date after search + TEMP_TIME = TIME ! we have the last message date + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + ELSE + TEMP_DATE = DATE + TEMP_TIME = TIME + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + BULL_ENTRY = BULL_ENTRY + 1 + END DO + +100 IF (UPDATE_DONE.GT.0) THEN ! Reorder directory file + CALL CLEANUP_DIRFILE(UPDATE_DONE) ! due to deleted entries + END IF + + DATE = NEWEST_DATE + TIME = NEWEST_TIME + CALL READDIR(0,IER) + SHUTDOWN = NEW_SHUTDOWN + NEWEST_EXDATE = TEMP_EXDATE + DIFF = COMPARE_DATE(NEWEST_EXDATE,' ') + IF (DIFF.GT.20*356) NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = TEMP_EXTIME + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL WRITEDIR(0,IER) + SYSTEM = 0 ! Updating last non-system date/time + NEWEST_DATE = TEMP_NOSYSDATE + NEWEST_TIME = TEMP_NOSYSTIME + CALL UPDATE_FOLDER + SYSTEM = 1 ! Now update latest date/time + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL UPDATE_FOLDER + + IF (NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN ! Shutdowns deleted? + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) ! Save that info + END IF + +C +C If newest message date has been changed, must change it in BULLUSER.DAT +C and also see if it affects notification of new messages to users +C + IF (TEMP_DATE.NE.DATE.OR.TEMP_TIME.NE.TIME) THEN + CALL UPDATE_LOGIN(.FALSE.) + END IF + + RETURN + + END + + + + SUBROUTINE UPDATE_READ(USERFILE_OPEN) +C +C SUBROUTINE UPDATE_READ +C +C FUNCTION: +C Store the latest date that user has used the BULLETIN facility. +C If new bulletins have been added, alert user of the fact. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($PRVDEF)' + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2),READ_BTIM_SAVE(2) + + LOGICAL MODIFY_SYSTEM /.TRUE./ + +C +C Update user's latest read time in his entry in BULLUSER.DAT. +C + IF (.NOT.USERFILE_OPEN) THEN + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + END IF + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.NE.0) THEN ! If header not present, exit + IF (.NOT.USERFILE_OPEN) CALL CLOSE_BULLUSER + RETURN + ELSE IF (USERPRIV(1).EQ.-1.AND.USERPRIV(2).EQ.-1) THEN + ! If header present, but no + DO I=1,FLONG ! SET_FLAG and NOTIFY_FLAG + SET_FLAG_DEF(I) = 0 ! information, write default + NOTIFY_FLAG_DEF(I) = 0 ! flags. + BRIEF_FLAG_DEF(I) = 0 + END DO + SET_FLAG_DEF(1) = 1 + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + + CALL SYS$ASCTIM(,TODAY,,) ! Get today's time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + UNLOCK 4 + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + + IF (IER1.EQ.0) THEN ! If entry found, update it + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + ELSE ! If no entry create a new entry + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + CALL WRITE_USER_FILE_NEW(IER) + END IF + + IF (MODIFY_SYSTEM) THEN + CALL MODIFY_SYSTEM_LIST(1) + MODIFY_SYSTEM = .FALSE. + END IF + + IF (.NOT.USERFILE_OPEN) THEN + CALL CLOSE_BULLUSER ! All finished with BULLUSER + END IF + + RETURN ! to go home... + + END + + + + + SUBROUTINE FIND_NEWEST_BULL +C +C SUBROUTINE FIND_NEWEST_BULL +C +C If new bulletins have been added, alert user of the fact and +C set the next bulletin to be read to the first new bulletin. +C +C OUTPUTS: +C BULL_POINT - If -1, no new bulletins to read, else there are. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INTEGER DIR_BTIM(2) + +C +C Now see if bulletins have been added since the user's previous +C read time. If they have, then search for the first new bulletin. +C Ignore new bulletins that are owned by the user or system notices +C that have not been added since the user has logged in. +C + BULL_POINT = -1 ! Init bulletin pointer + + CALL OPEN_BULLDIR_SHARED ! Yep, so get directory file + CALL READDIR(0,IER) ! Get # bulletins from header + IF (IER.EQ.1) THEN + CALL GET_NEWEST_MSG(LAST_READ_BTIM(1,FOLDER_NUMBER+1),START) + IF (START.LE.0) THEN + BULL_POINT = START + CALL CLOSE_BULLDIR + RETURN + END IF + DO WHILE (START.LE.NBULL.AND.(FROM.EQ.USERNAME.OR.SYSTEM)) + IF (FROM.NE.USERNAME) THEN ! Ignore bull if owner is user + IF (SYSTEM) THEN ! If system bulletin + CALL SYS_BINTIM(DATE//' '//TIME,DIR_BTIM) + DIFF = COMPARE_BTIM(LOGIN_BTIM,DIR_BTIM) + IF (DIFF.GT.0) THEN + START = START + 1 + CALL READDIR(START,IER) + ELSE ! SYSTEM bulletin was not seen + SYSTEM = 0 ! so force exit to read it. + END IF + END IF + ELSE + START = START + 1 + CALL READDIR(START,IER) + IF (IER.NE.START+1) START = NBULL + 1 + END IF + END DO + IF (START.LE.NBULL) BULL_POINT = START - 1 + END IF + + CALL CLOSE_BULLDIR + + RETURN + END + + + + SUBROUTINE GET_EXPIRED(EXPDAT,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 EXPDAT + CHARACTER*23 TODAY + + DIMENSION EXTIME(2),NOW(2) + + EXTERNAL CLI$_ABSENT + + IER = SYS$ASCTIM(,TODAY,,) ! Get today's date + + IERC = CLI$GET_VALUE('EXPIRATION',EXPDAT,ILEN) + + PROMPT = .TRUE. + +5 IF (PROMPT) THEN + IF (IERC.NE.%LOC(CLI$_ABSENT)) THEN ! Was value specified? + PROMPT = .FALSE. + ELSE + DEFAULT_EXPIRE = FOLDER_BBEXPIRE + IF ((DEFAULT_EXPIRE.GT.F_EXPIRE_LIMIT.OR.DEFAULT_EXPIRE + & .EQ.0).AND.F_EXPIRE_LIMIT.GT.0.AND..NOT. + & FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + DEFAULT_EXPIRE = F_EXPIRE_LIMIT + END IF + IF (BTEST(FOLDER_FLAG,3)) THEN ! NOPROMPT was set + IF (DEFAULT_EXPIRE.LE.0) THEN ! If no expiration date + SYSTEM = SYSTEM.OR.2 ! make permanent + EXPDAT = '5-NOV-2000 00:00:00.00' + ELSE ! Else set expiration + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + ELSE + IF (DEFAULT_EXPIRE.EQ.0) THEN ! Get expiration date + WRITE(6,1030) TODAY(:INDEX(TODAY,'.')-4) + ELSE IF (DEFAULT_EXPIRE.EQ.-1) THEN + WRITE(6,1031) TODAY(:INDEX(TODAY,'.')-4) + ELSE + WRITE(6,1032) TODAY(:INDEX(TODAY,'.')-4), + & DEFAULT_EXPIRE + END IF + WRITE (6,1035) + CALL GET_LINE(EXPDAT,ILEN) ! Get EXPDAT line + IF (ILEN.EQ.0.AND.DEFAULT_EXPIRE.NE.0) THEN + IF (DEFAULT_EXPIRE.EQ.-1) THEN + EXPDAT = '5-NOV-2000 00:00:00.00' + SYSTEM = IBSET(SYSTEM,1) ! Indicate permanent message + ELSE + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + END IF + END IF + END IF + ELSE + RETURN + END IF + + IF (ILEN.LE.0) THEN + IER = 0 + RETURN + END IF + + EXPDAT = EXPDAT(:ILEN) ! Change trailing zeros 2 spaces + + IF (INDEX(EXPDAT,'-').EQ.0.AND.INDEX(EXPDAT,':').GT.0.AND. + & INDEX(EXPDAT(:ILEN),' ').EQ.0) THEN ! Only time specified? + EXPDAT = TODAY(:INDEX(TODAY(2:),' ')+1)//EXPDAT ! Add date + ELSE IF (INDEX(EXPDAT(6:),'-').EQ.0.AND. ! Date specified + & INDEX(EXPDAT,'-').GT.0) THEN ! but no year? + SPACE = INDEX(EXPDAT,' ') - 1 ! Add year + IF (SPACE.EQ.-1) SPACE = TRIM(EXPDAT) + YEAR = INDEX(TODAY(6:),'-') + EXPDAT = EXPDAT(:SPACE)//TODAY(5+YEAR:9+YEAR)//EXPDAT(SPACE+1:) + END IF + + CALL STR$UPCASE(EXPDAT,EXPDAT) ! Convert to upper case + IER = SYS_BINTIM(EXPDAT,EXTIME) + IF (IER.NE.1) THEN ! If not able to do so + WRITE(6,1040) ! tell user is wrong + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + IF (TIMLEN.EQ.16) THEN + CALL SYS$GETTIM(NOW) + CALL LIB$SUBX(NOW,EXTIME,EXTIME) + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + END IF + + IF (EXPDAT(2:2).EQ.'-') EXPDAT = '0'//EXPDAT + IER = COMPARE_DATE(EXPDAT(:11),TODAY(:11)) ! Compare date with today's + IF (IER.GT.F_EXPIRE_LIMIT.AND.F_EXPIRE_LIMIT.GT.0.AND. + & .NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE(6,1050) F_EXPIRE_LIMIT ! Expiration date > limit + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IF (IER.EQ.0) IER = COMPARE_TIME(EXPDAT(13:),TODAY(13:)) + IF (IER.LE.0) THEN ! If expiration date not future + WRITE(6,1045) ! tell user + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + + IF (PROMPT) THEN + IF (BTEST(SYSTEM,1)) THEN ! Permanent message + WRITE (6,'('' Message will be permanent.'')') + ELSE + WRITE (6,'('' Expiration date will be '',A,''.'')') + & EXPDAT(:TRIM(EXPDAT)) + END IF + END IF + + IER = 1 + + RETURN + +1030 FORMAT(' It is ',A,'. Specify when message expires.') +1031 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is permanent.') +1032 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is ',I3,' days.') +1035 Format(' Enter absolute time: [dd-mmm-yyyy] hh:mm:ss ', + & 'or delta time: dddd hh:mm:ss') +1040 FORMAT(' ERROR: Invalid date format specified.') +1045 FORMAT(' ERROR: Specified time has already passed.') +1050 FORMAT(' ERROR: Specified expiration period too large.' + & ' Limit is ',I3,' days.') + + END + + + SUBROUTINE MAILEDIT(INFILE,OUTFILE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SSDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL BULLETIN_SUBCOMMANDS + + CHARACTER*(*) INFILE,OUTFILE + + CHARACTER*80 MAIL_EDIT,OUT + DATA MAIL_EDIT /' '/ + + CHARACTER*132 INPUT + + IF (MAIL_EDIT.EQ.' ') THEN + OPEN (UNIT=10,FILE='VMSMAIL_PROFILE', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL_PROFILE.DATA', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + IF (IER.EQ.0) THEN + DO WHILE (REC_LOCK(IER)) + READ(10,'(A)',KEY=USERNAME,IOSTAT=IER) INPUT + END DO + CLOSE (UNIT=10) + IF (IER.EQ.0) THEN + INPUT = INPUT(32:) + DO WHILE (TRIM(INPUT).GT.0) + IF (ICHAR(INPUT(1:1)).EQ.8) THEN + MAIL_EDIT = 'CALLABLE_'//INPUT(5:4+ICHAR(INPUT(3:3))) + INPUT = ' ' + ELSE + INPUT = INPUT(ICHAR(INPUT(3:3))+5:) + END IF + END DO + END IF + END IF + IF (MAIL_EDIT.EQ.' ') THEN + IER = SYS_TRNLNM('MAIL$EDIT',MAIL_EDIT) + ELSE + IER = SS$_NORMAL + END IF + CALL STR$UPCASE(MAIL_EDIT,MAIL_EDIT) ! Convert to upper case + END IF + + OUT = OUTFILE + IF (TRIM(OUT).EQ.0) THEN + OUT = INFILE + END IF + + CALL DISABLE_PRIVS + IF (INDEX(MAIL_EDIT,'CALLABLE_').EQ.0.AND. + & IER.EQ.SS$_NORMAL) THEN + IF (OUT.EQ.INFILE) THEN + CALL LIB$SPAWN('$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' "" '//OUT(:TRIM(OUT))) + ELSE + CALL LIB$SPAWN('$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' '//INFILE//' '//OUT(:TRIM(OUT))) + END IF + ELSE IF (INDEX(MAIL_EDIT,'EDT').GT.0.OR. + & IER.NE.SS$_NORMAL) THEN + CALL EDT$EDIT(INFILE,OUT) + ELSE IF (INDEX(MAIL_EDIT,'TPU').GT.0) THEN + CONTEXT = 0 + IER1 = LIB$FIND_FILE(INFILE,INPUT,CONTEXT) + IF (.NOT.IER1) THEN + CALL TPU$EDIT(' ',OUT) + ELSE + CALL TPU$EDIT(INFILE,OUT) + END IF + IER1 = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + ! TPU does CLI$ stuff which wipes our parsed command line + END IF + CALL ENABLE_PRIVS + + RETURN + END + + + + + + SUBROUTINE CREATE_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE '($JPIDEF)' + + INCLUDE '($SSDEF)' + + INCLUDE '($PQLDEF)' + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /REALPROC/ REALPROCPRIV(2) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + DIMENSION IMAGEPRIV(2) + + CHARACTER IMAGENAME*132,ANSWER*1,PRCNAM*15 + + STRUCTURE /QUOTA_ITMLST/ + BYTE ITEM + INTEGER VALUE + END STRUCTURE + + RECORD /QUOTA_ITMLST/ QUOTA(3) + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: You do not have the privileges '', + & ''to execute the command.'')') + CALL EXIT + END IF + + JUST_STOP = CLI$PRESENT('STOP') + + IF (JUST_STOP.AND..NOT.BTEST(REALPROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: You need SETPRV to execute /STOP.'')') + CALL EXIT + ELSE IF (.NOT.JUST_STOP.AND. + & .NOT.BTEST(REALPROCPRIV(1),PRV$V_SYSNAM)) THEN + CALL SYS$SETPRV(,,,IMAGEPRIV) + IF (.NOT.BTEST(IMAGEPRIV(1),PRV$V_SYSNAM)) THEN + WRITE (6,'('' ERROR: This new version of BULLETIN'', + & '' needs to be installed with SYSNAM.'')') + CALL EXIT + END IF + END IF + + IF (TEST_BULLCP()) THEN + IF (.NOT.JUST_STOP) THEN + WRITE (6,'('' BULLCP process running. + & Do you wish to kill it and restart a new one? '',$)') + READ (5,'(A)') ANSWER + IF (ANSWER.NE.'Y'.AND.ANSWER.NE.'y') CALL EXIT + END IF + + WILDCARD = -1 + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(PRCNAM),JPI$_PRCNAM,%LOC(PRCNAM)) + CALL ADD_2_ITMLST(4,JPI$_PID,%LOC(PID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + IER = 1 + DO WHILE (IER.AND.PRCNAM(:6).NE.'BULLCP') + ! Get next interactive process + IER = SYS$GETJPIW(,WILDCARD,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + IF (IER.AND.PID.NE.0) IER = SYS$DELPRC(PID,) + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + CALL EXIT + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP process has been terminated.'')') + CALL EXIT + END IF + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP is not presently running.'')') + CALL EXIT + END IF + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(FOLDER_DIRECTORY) + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) +C +C Generate a new BULLCP.COM each time. This is done in case the BULLETIN +C executeable is moved, or a new version of BULLETIN is being installed that +C has changes to BULLCP.COM. (It's also a security risk to execute the old +C copy, as someone might have been able to write into that directory and +C replace BULLCP.COM, and the command procedure is executed under the +C SYSTEM account, so it has all privileges.) +C + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$SET NOON' + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$LOOP:' + WRITE(11,'(A)') '$PURGE '//FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$OUTPUT ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$ERROR ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.ERR' + WRITE(11,'(A)') '$B/BULLCP' + WRITE(11,'(A)') '$WAIT 00:01:00' + WRITE(11,'(A)') '$GOTO LOOP' ! File open timed out + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + I = 1 + IER = CLI$GET_VALUE('PGFLQUOTA',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + DECODE(LEN_P,'(I)',BULL_PARAMETER) PGFLQUOTA + QUOTA(I).ITEM = PQL$_PGFLQUOTA + QUOTA(I).VALUE = PGFLQUOTA + I = I + 1 + END IF + IER = CLI$GET_VALUE('WSEXTENT',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + DECODE(LEN_P,'(I)',BULL_PARAMETER) WSEXTENT + QUOTA(I).ITEM = PQL$_WSEXTENT + QUOTA(I).VALUE = WSEXTENT + I = I + 1 + END IF + QUOTA(I).ITEM = PQL$_LISTEND + QUOTA(I).VALUE = 0 + + IER = 0 + DO WHILE (IER.EQ.0.OR.(IER.EQ.SS$_DUPLNAM.AND.PID.GT.0)) + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT',FOLDER_DIRECTORY(:LEN_B) + & //'BULLCP.COM','NL:',,,QUOTA,'BULLCP',%VAL(4), + & ,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + END DO + + IF (IER) THEN + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM;-1', + & STATUS='OLD',IOSTAT=IER1) + IF (IER1.EQ.0) CLOSE(UNIT=11,STATUS='DELETE',IOSTAT=IER1) + END IF + + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + ELSE + IF (CONFIRM_USER('DECNET').NE.0) THEN + WRITE (6,'('' WARNING: Account with username DECNET'', + & '' does not exist.'')') + WRITE (6,'('' BULLCP will be owned by present account.'')') + END IF + WRITE (6,'('' Successfully created BULLCP detached process.'')') + END IF + CALL EXIT + + END + + + + + + + SUBROUTINE FIND_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + DATA BULLCP /0/ + + CHARACTER*1 DUMMY + + IER = SYS_TRNLNM('BULL_BULLCP',DUMMY) + IF (IER) BULLCP = 1 + + RETURN + END + + + + + LOGICAL FUNCTION TEST_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + TEST_BULLCP = BULLCP + + RETURN + END + + + + + SUBROUTINE RUN_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + + CHARACTER*23 OLD_TIME,NEW_TIME + + IF (TEST_BULLCP()) CALL EXIT ! BULLCP already running, so exit. + + CALL LIB$DATE_TIME(OLD_TIME) + + BULLCP = 2 ! Enable process to do BULLCP functions + + IER = SYS$CREMBX(%VAL(1),CHAN,,,,,'BULL_BULLCP') + IF (.NOT.IER) THEN ! Can't create mailbox, so exit. + CALL SYS_GETMSG(IER) + CALL EXIT + END IF + + IER = SYS$DELMBX(%VAL(CHAN)) ! If process dies, mailbox is deleted. + + CALL REGISTER_BULLCP + + CALL SET_REMOTE_SYSTEM + + CALL START_DECNET + + DO WHILE (1) ! Loop once every 15 minutes + CALL SYS$SETAST(%VAL(0)) + CALL LIB$DATE_TIME(NEW_TIME) + CALL GET_PROXY_ACCOUNTS ! Proxy info for incoming connections + CALL SYS$SETAST(%VAL(1)) + CALL BBOARD ! Look for BBOARD messages. + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).NE.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + IF (IER) THEN + CALL DELETE_EXPIRED ! Delete expired messages + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Do empty block + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! cleanup at 3 a.m. + IF (NEMPTY.GT.200) THEN + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + END IF + END IF + END IF + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Cleanup deleted users from + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! data files at 3 a.m. + CALL SYS$SETAST(%VAL(0)) + CALL TOTAL_CLEANUP_LOGIN + CALL SYS$SETAST(%VAL(1)) + END IF + + OLD_TIME = NEW_TIME + CALL WAIT('15') ! Wait for 15 minutes +C +C Look at remote folders and update local info to reflect new messages. +C Do here after waiting in case problem with connecting to remote folder +C which requires killing process. +C + + FOLDER_Q = FOLDER_Q1 + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + CALL SYS$SETAST(%VAL(0)) + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + CALL REGISTER_BULLCP + CALL SYS$SETAST(%VAL(1)) + END DO + + RETURN + END + + + + + + SUBROUTINE SET_REMOTE_SYSTEM + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER NODENAME*8 + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + CALL OPEN_BULLFOLDER_SHARED + + IER = 0 + DO WHILE (IER.EQ.0) + CALL READ_FOLDER_FILE(IER) + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER_FLAG,2) + & .AND.IER.EQ.0) THEN + CALL SELECT_FOLDER(.FALSE.,IER1) + IF (IER1) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14, + & BTEST(FOLDER_FLAG,2),NODENAME + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER + + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + + RETURN + END + + + + + SUBROUTINE REGISTER_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + NODE_AREA = 0 + END IF + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE UPDATE_SHUTDOWN(FOLDER_NUMBER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + CALL CLR2(SHUTDOWN_FLAG,FOLDER_NUMBER) + + SEEN_FLAG = 0 + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 ! All done with that node + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE WAIT(PARAM) +C +C SUBROUTINE WAIT +C +C FUNCTION: Waits for specified time period in minutes. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,PARAM*2 + DATA TIMBUF/'0 00:00:00.00'/ + + DATA WAIT_EF /0/ + + IF (WAIT_EF.EQ.0) CALL LIB$GET_EF(WAIT_EF) + + TIMBUF(6:7) = PARAM + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SETIMR(%VAL(WAIT_EF),TIMADR,,%VAL(2)) ! Set timer. + IER=SYS$WAITFR(%VAL(WAIT_EF)) ! Wait for EFN to be set. + + RETURN + END + + + + SUBROUTINE WAIT_SEC(PARAM) +C +C SUBROUTINE WAIT_SEC +C +C FUNCTION: Waits for specified time period in seconds. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,PARAM*2 + DATA TIMBUF/'0 00:00:00.00'/ + DATA WAIT_EF /0/ + + IF (WAIT_EF.EQ.0) CALL LIB$GET_EF(WAIT_EF) + + TIMBUF(9:10) = PARAM + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SETIMR(%VAL(WAIT_EF),TIMADR,,%VAL(3)) ! Set timer. + IER=SYS$WAITFR(%VAL(WAIT_EF)) ! Wait for EFN to be set. + + RETURN + END + + + + + SUBROUTINE DELETE_EXPIRED + +C +C SUBROUTINE DELETE_EXPIRED +C +C FUNCTION: +C +C Delete any expired bulletins (normal or shutdown ones). +C (NOTE: If bulletin files don't exist, they get created now by +C OPEN_FILE_SHARED. Also, if new format has been defined for files, +C they get converted now. The directory file has had it's record size +C lengthened in the past to include more info, and the bulletin file +C was lengthened from 80 to 81 characters to include byte which indicated +C start of bulletin message. However, that scheme was removed and +C was replaced with a 128 byte record compressed format). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER UPTIME_DATE*11,UPTIME_TIME*11 + + CALL OPEN_BULLDIR_SHARED ! Open directory file + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + CALL CLOSE_BULLFIL + CALL READDIR(0,IER) ! Get directory header + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired bulls? + IF (IER.GT.20*356) IER = -1 ! Check if latest expiration date valid. + IF (IER.EQ.0) IER = COMPARE_TIME(NEWEST_EXTIME,' ') + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)).AND. + & TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown messages exist and need to be checked? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER1.LE.0) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Reopen without sharing + CALL UPDATE ! Need to update + END IF + ELSE ! If header not there, then first time running BULLETIN + CALL OPEN_BULLUSER ! Create user file to be able to set + CALL CLOSE_BULLUSER ! defaults, privileges, etc. + END IF + CALL CLOSE_BULLDIR + + RETURN + END + + + + + SUBROUTINE BBOARD +C +C SUBROUTINE BBOARD +C +C FUNCTION: Converts mail to BBOARD into non-system bulletins. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + CHARACTER*11 INEXDATE + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH),INTO*76 + CHARACTER ACCOUNT_SAVE*8,USERNAME_SAVE*12 + + DIMENSION NEW_MAIL(FOLDER_MAX) + + DATA SPAWN_EF/0/ + + CALL SYS$SETAST(%VAL(0)) + + IF (SPAWN_EF.EQ.0) CALL LIB$GET_EF(SPAWN_EF) + + CALL DISABLE_CTRL + + CALL INIT_QUEUE(FOLDER_Q1,FOLDER_COM) + + FOLDER_Q = FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE(IER) + IF (IER.EQ.0) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + CALL SYS$SETAST(%VAL(1)) + + CALL SYS$SETAST(%VAL(0)) + CALL CHECK_MAIL(NEW_MAIL) + CALL SYS$SETAST(%VAL(1)) + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + + NBBOARD_FOLDERS = 0 + + POINT_FOLDER = 0 + +1 POINT_FOLDER = POINT_FOLDER + 1 + IF (POINT_FOLDER.GT.NUM_FOLDERS) GO TO 900 + + CALL SYS$SETAST(%VAL(0)) + + FOLDER_Q_SAVE = FOLDER_Q + + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (FOLDER_BBOARD.EQ.'NONE'.OR. + & FOLDER_BBOARD(:2).EQ.'::') GO TO 1 + + NBBOARD_FOLDERS = NBBOARD_FOLDERS + 1 + + IF (.NOT.NEW_MAIL(POINT_FOLDER)) GO TO 1 +C +C The process is set to the BBOARD uic and username in order to create +C a spawned process that is able to read the BBOARD mail (a real kludge). +C + + CALL GETUSER(USERNAME_SAVE) ! Get present username + CALL GETACC(ACCOUNT_SAVE) ! Get present account + CALL GETUIC(GROUP_SAVE,USER_SAVE) ! Get present uic + + IF (TRIM(FOLDER_BBOARD).GT.0) THEN ! BBOARD name present? + IER = SETUSER(FOLDER_BBOARD,USERNAME_SAVE)! Set to BBOARD username + IF (IER.EQ.2) GO TO 910 ! Can't set username. New VMS version? + CALL SETACC(ACCOUNTB) ! Set to BBOARD account + CALL SETUIC(IBCLR(GROUPB,31),IBCLR(USERB,31)) ! Set to BBOARD uic + END IF + + LEN_B = TRIM(BBOARD_DIRECTORY) + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.TXT;*') + ! Delete old TXT files left due to errors + + IF (.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)) THEN + ! If normal BBOARD user + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + IF (((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'READ_BOARD.COM', + & STATUS='NEW',ERR=910,CARRIAGECONTROL='LIST') + WRITE(11,'(A)') '$ SET PROTECT=(W:RWED)/DEFAULT' + WRITE(11,'(A)') '$ SET PROC/PRIV=SYSPRV' + WRITE(11,'(A)') + & '$ DEFINE/USER EXTRACT_FILE '//BBOARD_DIRECTORY(:LEN_B)// + & '''F$GETJPI("","USERNAME")''' + WRITE(11,'(A)') '$ MAIL' + WRITE(11,'(A)') 'READ' + WRITE(11,'(A)') 'EXTRACT/ALL/APPEND EXTRACT_FILE' + WRITE(11,'(A)') 'DELETE/ALL' + WRITE(11,'(A)') 'SELECT/NEW' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + ELSE + CONTEXT = 0 + IER = LIB$FIND_FILE(BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.COM',INPUT,CONTEXT) + IF (IER) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.COM','NL:', + & 'NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + IF (.NOT.IER.OR.((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & 'BOARD_SPECIAL.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + END IF + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),FOLDER_Q,FOLDER_COM) + + NBULL = F_NBULL + + CALL SETACC(ACCOUNT_SAVE) ! Reset to original account + CALL SETUSER(USERNAME_SAVE) ! Reset to original username + CALL SETUIC(GROUP_SAVE,USER_SAVE) ! Reset to original uic + + OPEN (UNIT=14,FILE=BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.TXT',STATUS='OLD',ERR=100) + READ (14,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read first line + CALL SYS$SETAST(%VAL(1)) + +5 CALL SYS$SETAST(%VAL(0)) + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),IDUMMY,FOLDER_COM) + + DO WHILE (LEN_INPUT.GT.0) + IF (INPUT(:5).EQ.'From:') THEN + INFROM = INPUT(7:) ! Store username + ELSE IF (INPUT(:5).EQ.'Subj:') THEN + INDESCRIP = INPUT(7:) ! Store subject + ELSE IF (INPUT(:3).EQ.'To:') THEN + INTO = INPUT(5:) ! Store address + END IF + READ (14,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read next line from mail + END DO + + INTO = INTO(:TRIM(INTO)) + CALL STR$TRIM(INTO,INTO) + CALL STR$UPCASE(INTO,INTO) + FLEN = TRIM(FOLDER_BBOARD) + IF (INDEX(INTO,FOLDER_BBOARD(:FLEN)).EQ.0.AND. + & INTO.NE.FOLDER_BBOARD.AND.INDEX(INTO,'@').EQ.0) THEN + POINT_FOLDER1 = 0 + FOLDER_Q2 = FOLDER_Q1 + FOLDER1_BBOARD = FOLDER_BBOARD + FOUND = .FALSE. + DO WHILE (.NOT.FOUND.AND.POINT_FOLDER1.LT.NUM_FOLDERS) + FOLDER_Q2_SAVE = FOLDER_Q2 + CALL READ_QUEUE(%VAL(FOLDER_Q2),FOLDER_Q2,FOLDER1_COM) + FLEN = TRIM(FOLDER1_BBOARD) + POINT_FOLDER1 = POINT_FOLDER1 + 1 + IF (POINT_FOLDER1.LE.NUM_FOLDERS.AND. + & FOLDER1_BBOARD(:2).NE.'::'.AND. + & FOLDER1_BBOARD.NE.'NONE') THEN + IF (INTO.EQ.FOLDER1_BBOARD) THEN + FOUND = .TRUE. + ELSE + FIND_TO = INDEX(INTO,FOLDER1_BBOARD(:FLEN)) + IF (FIND_TO.GT.0) THEN + END_TO = FLEN+FIND_TO + IF (TRIM(INTO).LT.END_TO.OR. + & INTO(END_TO:END_TO).LT.'A'.OR. + & INTO(END_TO:END_TO).GT.'Z') THEN + IF (FIND_TO.EQ.1) THEN + FOUND = .TRUE. + ELSE IF (INTO(FIND_TO-1:FIND_TO-1).LT.'A'.OR. + & INTO(FIND_TO-1:FIND_TO-1).GT.'Z') THEN + FOUND = .TRUE. + END IF + END IF + END IF + END IF + END IF + END DO + IF (FOUND) THEN + FOLDER_COM = FOLDER1_COM + FOLDER_Q_SAVE = FOLDER_Q2_SAVE + END IF + END IF + + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT ! Read first line + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12).AND.IER.EQ.0) + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (INPUT(:5).EQ.'From:') GO TO 5 + END DO ! If line is just form feed, the message is empty + IF (IER.NE.0) GO TO 100 ! If end of file, exit + + EFROM = 2 + I = TRIM(INFROM) + DO WHILE (EFROM.GT.0.AND.I.GT.0) ! Strip off the date + IF (INFROM(I:I).EQ.' ') EFROM = EFROM - 1 ! From the "From:" line + I = I - 1 + END DO + IF (I.GT.0) INFROM = INFROM(:I) + + CALL INIT_MESSAGE_ADD_BBOARD(INFROM,INDESCRIP,IER) + + ISTART = 0 + NBLANK = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Move text to bulletin file + IF (LEN_INPUT.EQ.0) THEN + IF (ISTART.EQ.1) THEN + NBLANK = NBLANK + 1 + END IF + ELSE + ISTART = 1 + DO I=1,NBLANK + CALL WRITE_MESSAGE_LINE(' ') + END DO + NBLANK = 0 + CALL WRITE_MESSAGE_LINE(INPUT) + END IF + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12)) THEN + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12) + & .AND.IER.EQ.0) + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + END DO + IF (IER.EQ.0.AND.INPUT(:5).EQ.'From:') THEN + IER = 1 + ELSE + NBLANK = NBLANK + 1 + END IF + END IF + END DO + + CALL FINISH_MESSAGE_ADD ! Totally finished with add + + CALL SYS$SETAST(%VAL(1)) + + GO TO 5 ! See if there is more mail + +100 CLOSE (UNIT=14,STATUS='DELETE') ! Close the input file + CALL SYS$SETAST(%VAL(1)) + GO TO 1 + +900 CALL SYS$SETAST(%VAL(0)) + + FOLDER_NUMBER = 0 + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNUM(0,IER) + CALL CLOSE_BULLFOLDER + CALL ENABLE_CTRL + FOLDER_SET = .FALSE. + + IF (NBBOARD_FOLDERS.EQ.0) THEN + CALL OPEN_BULLUSER + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',BBOARD_BTIM) + REWRITE (4) USER_HEADER ! Rewrite header + CALL CLOSE_BULLUSER + END IF + + CALL SYS$SETAST(%VAL(1)) + + RETURN + +910 WRITE (6,1010) + GO TO 100 + +930 CLOSE (UNIT=14) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + WRITE (6,1030) + GO TO 100 + +1010 FORMAT(' ERROR:Install program with CMKRNL privileges or relink.') +1030 FORMAT(' ERROR:Alert system programmer. Data file problems.') + + END + + + + + SUBROUTINE CREATE_BBOARD_PROCESS + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + CHARACTER*132 IMAGENAME + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(BBOARD_DIRECTORY) + + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='OLD',IOSTAT=IER) + IF (IER.EQ.0) CLOSE(UNIT=11,STATUS='DELETE') + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$ON ERROR THEN GOTO EXIT' + WRITE(11,'(A)') '$ON SEVERE THEN GOTO EXIT' + WRITE(11,'(A)') '$ON WARNING THEN GOTO EXIT' + WRITE(11,'(A)') '$B/'//'''F$PROCESS()''' + WRITE(11,'(A)') '$EXIT:' + WRITE(11,'(A)') '$LOGOUT' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT', + & BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM','NL:',, + & PROCPRIV,,'BBOARD',%VAL(4),,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + + RETURN + END + + + + SUBROUTINE GETUIC(GRP,MEM) +C +C SUBROUTINE GETUIC(UIC) +C +C FUNCTION: +C To get UIC of process submitting the job. +C OUTPUT: +C GRP - Group number of UIC +C MEM - Member number of UIC +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,JPI$_GRP,%LOC(GRP)) + CALL ADD_2_ITMLST(4,JPI$_MEM,%LOC(MEM)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + SUBROUTINE GET_UPTIME(UPTIME_DATE,UPTIME_TIME) +C +C SUBROUTINE GET_UPTIME +C +C FUNCTION: Gets time of last reboot. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + INTEGER UPTIME(2) + CHARACTER*(*) UPTIME_TIME,UPTIME_DATE + CHARACTER ASCSINCE*23 + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(8,SYI$_BOOTTIME,%LOC(UPTIME)) + CALL END_ITMLST(GETSYI_ITMLST) + + IER = SYS$GETSYI(,,,%VAL(GETSYI_ITMLST),,,) + + CALL SYS$ASCTIM(,ASCSINCE,UPTIME,) + + UPTIME_DATE = ASCSINCE(:11) + UPTIME_TIME = ASCSINCE(13:) + + RETURN + END + + + + INTEGER FUNCTION GET_L_VAL(I) + INTEGER I + GET_L_VAL = I + RETURN + END + + + + SUBROUTINE CHECK_MAIL(NEW_MAIL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + DIMENSION NEW_MAIL(1) + + CHARACTER INPUT*132 + + INTEGER*2 COUNT + + FOLDER_Q = FOLDER_Q1 ! so reinit queue pointer + + OPEN (UNIT=10,FILE='VMSMAIL_PROFILE', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL_PROFILE.DATA', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + + DO I=1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (((.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)).OR. + & BTEST(GROUPB,31)).AND.FOLDER_BBOARD(:2).NE.'::'.AND. + & FOLDER_BBOARD.NE.'NONE') THEN ! If normal BBOARD or /VMSMAIL + DO WHILE (REC_LOCK(IER1)) + READ(10,'(A)',KEY=FOLDER_BBOARD,IOSTAT=IER1) INPUT + END DO + COUNT = 0 + IF (IER1.EQ.0) THEN + INPUT = INPUT(32:) + DO WHILE (TRIM(INPUT).GT.0) + IF (ICHAR(INPUT(1:1)).EQ.1) THEN + CALL LIB$MOVC3(2,%REF(INPUT(5:)),COUNT) + INPUT = ' ' + ELSE + INPUT = INPUT(ICHAR(INPUT(3:3))+5:) + END IF + END DO + END IF + IF (IER1.EQ.0.AND.(COUNT.GT.0.OR.IER.NE.0)) THEN + NEW_MAIL(I) = .TRUE. + ELSE + NEW_MAIL(I) = .FALSE. + END IF + ELSE + NEW_MAIL(I) = .TRUE. + END IF + END DO + + CLOSE (10) + + RETURN + END + + + + SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C FUNCTION: +C To get image name of process. +C OUTPUT: +C IMAGNAME - Image name of process +C ILEN - Length of imagename +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CHARACTER*(*) IMAGNAME + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST_WITH_RET(LEN(IMAGNAME),JPI$_IMAGNAME, + & %LOC(IMAGNAME),%LOC(ILEN)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + + SUBROUTINE GET_NEWEST_MSG(IN_BTIM,START) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + DIMENSION IN_BTIM(2) + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 12,IN_BTIM(1),IN_BTIM(2) + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(A)',IOSTAT=IER) START + END IF + ELSE + CALL GET_MSGKEY(IN_BTIM,MSG_KEY) + CALL READDIR_KEYGE(START) + IF (START.EQ.0) THEN + START = -1 + END IF + END IF + + RETURN + END + + + + SUBROUTINE NOTIFY_REMOTE_USERS(IN_BTIM) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + DIMENSION IN_BTIM(2) + + CALL GET_MSGKEY(IN_BTIM,MSG_KEY) + CALL READDIR_KEYGE(START) + + IF (START.EQ.0) RETURN + + CALL OPEN_BULLUSER_SHARED + + IER = START + 1 + DO WHILE (START+1.EQ.IER) + IF (.NOT.BTEST(SYSTEM,3)) CALL NOTIFY_USERS(0) + START = START + 1 + CALL READDIR(START,IER) + END DO + + CALL CLOSE_BULLDIR + + RETURN + END + + + + + + SUBROUTINE READ_NOTIFY + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG) + + CALL OPEN_BULLUSER_SHARED + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*NOTIFY',IOSTAT=IER) TEMP_USER,NOTIFY_REMOTE + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + NOTIFY_REMOTE(I) = 0 + END DO + WRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + END IF + + CALL CLOSE_BULLDIR + + RETURN + END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin4.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin4.for new file mode 100644 index 0000000..07d40c5 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin4.for @@ -0,0 +1,1776 @@ +C +C BULLETIN4.FOR, Version 6/6/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C +C +C SUBROUTINE ITMLST_SUBS +C +C FUNCTION: +C A set of routines to easily create item lists. It allows one +C to easily create item lists without the need for declaring arrays +C or itemlist size. Thus, the code can be easily changed to add or +C delete item list codes. +C +C Here is an example of how to use the routines (prints file to a queue): +C +C CALL INIT_ITMLST ! Initialize item list +C ! Now add items to list +C CALL ADD_2_ITMLST(LEN,SJC$_FILE_SPECIFICATION,%LOC(FILENAME)) +C CALL ADD_2_ITMLST(9,SJC$_QUEUE,%LOC(QUEUE)) +C CALL END_ITMLST(SNDJBC_ITMLST) ! Get address of itemlist +C IER = SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SNDJBC_ITMLST),IOSB,,) +C + SUBROUTINE ITMLST_SUBS + + IMPLICIT INTEGER (A-Z) + + DATA SAVE_ITMLST_ADDRESS/0/,NUM_ITEMS/0/,QUEUE_HEADER/0/ + + ENTRY INIT_ITMLST + + IF (QUEUE_HEADER.EQ.0) THEN ! First time INIT_ITMLST ever called? + CALL LIB$GET_VM(8,QUEUE_HEADER) ! Yes, create queue header pointer + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER)) ! Zero out header + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER+4)) ! Zero out header + ELSE IF (SAVE_ITMLST_ADDRESS.GT.0) THEN ! Clean out old item list + CALL LIB$FREE_VM((NUM_ITEMS+1)*12,SAVE_ITMLST_ADDRESS) + NUM_ITEMS = 0 ! Release old itemlist memory + SAVE_ITMLST_ADDRESS = 0 + ELSE ! ITMLST calls cannot be nested. + WRITE (6,'('' ERROR: INIT_ITMLST called before previous'',$)') + WRITE (6,'(''+ ITMLST terminated with END_ITMLST.'')') + CALL EXIT + END IF + + RETURN + + + ENTRY ADD_2_ITMLST(BUFLEN,CODE,BUFADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR,0) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY ADD_2_ITMLST_WITH_RET(BUFLEN,CODE,BUFADR,RETADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR, + & RETADR) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY END_ITMLST(ITMLST_ADDRESS) + + CALL LIB$GET_VM((NUM_ITEMS+1)*12,ITMLST_ADDRESS) + ! Get memory for itemlist + SAVE_ITMLST_ADDRESS = ITMLST_ADDRESS ! Save address to remove memory + + DO I=1,NUM_ITEMS ! Place entries into itemlist + CALL LIB$REMQHI(%VAL(QUEUE_HEADER),INPUT_ITMLST) + CALL LIB$MOVC3(12,%VAL(INPUT_ITMLST+8), + & %VAL(ITMLST_ADDRESS+(I-1)*12)) + CALL LIB$FREE_VM(20,INPUT_ITMLST) + END DO + + CALL LIB$MOVC3(4,0,%VAL(ITMLST_ADDRESS+NUM_ITEMS*12)) + ! Place terminating 0 at end of itemlist + + RETURN + END + + + + SUBROUTINE STORE_ITMLST_ENTRY(INPUT_ITMLST,BUFLEN,CODE,BUFADR, + & RETADR) + + IMPLICIT INTEGER (A-Z) + + STRUCTURE /ITMLST/ + UNION + MAP + INTEGER*2 BUFLEN,CODE + INTEGER BUFADR,RETADR + END MAP + END UNION + END STRUCTURE + + RECORD /ITMLST/ INPUT_ITMLST(1) + + INPUT_ITMLST(1).BUFLEN = BUFLEN + INPUT_ITMLST(1).CODE = CODE + INPUT_ITMLST(1).BUFADR = BUFADR + INPUT_ITMLST(1).RETADR = RETADR + + RETURN + END + + + SUBROUTINE CLEANUP_LOGIN +C +C SUBROUTINE CLEANUP_LOGIN +C +C FUNCTION: Removes entry in user file of user that no longer exist. +C It creates empty space for new user. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 LOGIN_USER + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL OPEN_SYSUAF_SHARED + + LOGIN_USER = USERNAME + READ (4,IOSTAT=IER1,KEYGT=USERNAME) USER_ENTRY ! Look forward one + TEMP_USER = USERNAME + USERNAME = LOGIN_USER + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=TEMP_USER,IOSTAT=IER) TEMP_USER ! See if user exists + END DO + + IF (IER.NE.0.AND.IER1.EQ.0.AND.TEMP_USER.NE.USER_HEADER_KEY) THEN + ! If no UAF entry and last login was + ! more than 6 months old, delete entry + IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN + DELETE(UNIT=4) ! Delete non-existant user + CALL OPEN_BULLINF + READ (9,KEY=TEMP_USER,IOSTAT=IER) + IF (IER.EQ.0) DELETE(UNIT=9) + LU = TRIM(TEMP_USER) + TEMP_USER(LU:LU) = CHAR(ICHAR(TEMP_USER(LU:LU)).OR.128) + READ (9,KEY=TEMP_USER,IOSTAT=IER) + IF (IER.EQ.0) DELETE(UNIT=9) + CALL CLOSE_BULLINF + END IF + END IF + + CALL CLOSE_SYSUAF ! All done... + + RETURN + END + + + SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C FUNCTION: Removes all entries in user file of usesr that no longer exist +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG) + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL OPEN_SYSUAF_SHARED + CALL OPEN_BULLUSER + CALL OPEN_BULLINF + + TEMP_USER = USERNAME + + READ (4,IOSTAT=IER) USER_ENTRY ! Skip header + + DO WHILE (IER.EQ.0) ! Clean out BULLUSER.DAT + READ (4,IOSTAT=IER) USER_ENTRY + IF (IER.EQ.0.AND.USERNAME(:1).NE.'*'.AND. + & USERNAME(:1).NE.':') THEN ! See if user exists + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=USERNAME,IOSTAT=IER) + END DO + IF (IER.NE.0) THEN ! If no UAF entry and last login was + ! more than 6 months old, delete entry + IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN + DELETE (UNIT=4) + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=9) + LU = TRIM(USERNAME) + USERNAME(LU:LU) = CHAR(ICHAR(USERNAME(LU:LU)).OR.128) + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=9) + END IF + IER = 0 + ELSE + DO I=0,FOLDER_MAX-1 + IF (TEST2(NOTIFY_FLAG,I)) THEN + CALL SET2(NOTIFY_REMOTE,I) + END IF + END DO + END IF + END IF + END DO + + CALL CLOSE_SYSUAF ! All done... + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*NOTIFY',IOSTAT=IER) TEMP_USER + END DO + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + ELSE + REWRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + END IF + + READ (9,KEYGT=' ',IOSTAT=IER) USERNAME + + DO WHILE (IER.EQ.0) ! Clean out BULLINF.DAT + LU = TRIM(USERNAME) + USERNAME(LU:LU) = CHAR(ICHAR(USERNAME(LU:LU)).AND.127) + READ (4,KEYEQ=USERNAME,IOSTAT=IER) + IF (IER.NE.0) DELETE (UNIT=9) + READ (9,IOSTAT=IER) USERNAME + END DO + + CALL CLOSE_BULLINF + CALL CLOSE_BULLUSER + + USERNAME = TEMP_USER + + RETURN + END + + + SUBROUTINE COPY_BULL(INLUN,IBLOCK,OBLOCK,IER) +C +C SUBROUTINE COPY_BULL +C +C FUNCTION: To copy data to the bulletin file. +C +C INPUT: +C INLUN - Input logical unit number +C IBLOCK - Input block number in input file to start at +C OBLOCK - Output block number in output file to start at +C +C OUTPUT: +C IER - If error in writing to bulletin, IER will be <> 0. +C +C NOTES: Input file is accessed using sequential access. This is +C to allow files which have variable records to be read. The +C bulletin file is assumed to be opened on logical unit 1. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + IF (IER.NE.0) CALL ERROR_AND_EXIT + END IF + + DO I=1,IBLOCK-1 + READ(INLUN,'(A)') + END DO + + OCOUNT = OBLOCK + ICOUNT = IBLOCK + + NBLANK = 0 + LENGTH = 0 + DO WHILE (1) + ILEN = 0 + DO WHILE (ILEN.EQ.0) + READ(INLUN,'(Q,A)',END=100) ILEN,INPUT + ILEN = MIN(ILEN,TRIM(INPUT),LINE_LENGTH) + IF (ILEN.GT.1.AND.ICHAR(INPUT(ILEN:ILEN)).EQ.10) THEN + INPUT(ILEN-1:ILEN-1) = CHAR(32) ! Remove imbedded + INPUT(ILEN:ILEN) = CHAR(32) ! CR/LFs at end of file. + ILEN = ILEN - 2 + END IF + IF (ILEN.GT.0) THEN + IF (ICOUNT.EQ.IBLOCK) THEN + IF (INPUT(:6).EQ.'From: ') THEN + INPUT(:4) = 'FROM' + END IF + END IF + ICOUNT = ICOUNT + 1 + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.IBLOCK) THEN + NBLANK = NBLANK + 1 + END IF + END DO + IF (NBLANK.GT.0) THEN + DO I=1,NBLANK + CALL STORE_BULL(1,' ',OCOUNT) + END DO + LENGTH = LENGTH + NBLANK*2 + NBLANK = 0 + END IF + CALL STORE_BULL(ILEN,INPUT,OCOUNT) + LENGTH = LENGTH + ILEN + 1 + END DO + +100 LENGTH = (LENGTH+127)/128 + IF (LENGTH.EQ.0) THEN + IER = 1 + ELSE + IER = 0 + END IF + + CALL FLUSH_BULL(OCOUNT) + + RETURN + END + + + + SUBROUTINE STORE_BULL(ILEN,INPUT,OCOUNT) + + IMPLICIT INTEGER (A-Z) + + PARAMETER BRECLEN=128 + + CHARACTER INPUT*(*),OUTPUT*256 + + DATA POINT/0/ + + IF (ILEN+POINT+1.GT.BRECLEN) THEN + IF (POINT.EQ.BRECLEN) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)) + OUTPUT = CHAR(ILEN)//INPUT + POINT = ILEN + 1 + ELSE IF (POINT.EQ.BRECLEN-1) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN)) + OUTPUT = INPUT + POINT = ILEN + ELSE + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN) + & //INPUT(:BRECLEN-1-POINT)) + OUTPUT = INPUT(BRECLEN-POINT:) + POINT = ILEN - (BRECLEN-1-POINT) + END IF + OCOUNT = OCOUNT + 1 + DO WHILE (POINT.GE.BRECLEN) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + OCOUNT = OCOUNT + 1 + OUTPUT = OUTPUT(BRECLEN+1:) + POINT = POINT - BRECLEN + END DO + ELSE + OUTPUT(POINT+1:) = CHAR(ILEN)//INPUT(:ILEN) + POINT = POINT + ILEN + 1 + END IF + + RETURN + + ENTRY FLUSH_BULL(OCOUNT) + + IF (POINT.LT.BRECLEN) OUTPUT(POINT+1:POINT+1) = CHAR(0) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + POINT = 0 + + RETURN + + END + + + SUBROUTINE WRITE_BULL_FILE(OCOUNT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*(*) OUTPUT + + IF (REMOTE_SET) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 6,OUTPUT + ELSE + WRITE (1'OCOUNT) OUTPUT + END IF + + RETURN + END + + + SUBROUTINE GET_BULL_LINE(SBLOCK,BLENGTH,BUFFER,ILEN) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + IBLOCK = SBLOCK ! Initialize pointers. + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 + ELSE ! Else set ILEN to zero + ILEN = 0 ! to request next line + END IF + + DO WHILE (ILEN.EQ.0) ! Read until line created + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 ! Need to read new record. + IF (IBLOCK.GE.SBLOCK+BLENGTH) RETURN ! No more records. + END DO + + RETURN + + ENTRY TEST_MORE_RECORDS(SBLOCK,BLENGTH,IREC) + + IREC = (SBLOCK+BLENGTH-1) - IBLOCK + + RETURN + END + + + SUBROUTINE GET_BULL(IBLOCK,BUFFER,ILEN) +C +C SUBROUTINE GET_BULL +C +C FUNCTION: Outputs line from folder file. +C +C INPUT: +C IBLOCK - Input block number in input file to read from. +C +C OUTPUT: +C BUFFER - Character string containing output line. +C ILEN - Length of character string. If 0, signifies that +C new record needs to be read, -1 signifies error. +C +C NOTE: Since message file is stored as a fixed length (128) record file, +C but message lines are variable, message lines may span one or +C more record. This routine takes a record and outputs as many +C lines as it can from the record. When no more lines can be +C outputted, it returns ILEN=0 requesting the calling program to +C increment the record counter. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + PARAMETER BRECLEN=128 + + CHARACTER BUFFER*(*),TEMP*(BRECLEN), LEFT*(LINE_LENGTH) + + DATA POINT /1/, LEFT_LEN /0/ + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + POINT = 1 ! Initialize pointers. + LEFT_LEN = 0 + END IF + + IF (POINT.EQ.1) THEN ! Need to read new line? + IF (REMOTE_SET) THEN ! Remote folder? + IF (IBLOCK.EQ.BLOCK) SCRATCH_R = SCRATCH_R1 ! Read lines + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,TEMP) ! from queue + ELSE ! Local folder + DO WHILE (REC_LOCK(IER)) ! Read from file + READ (1'IBLOCK,IOSTAT=IER) TEMP + END DO + END IF + ELSE IF (POINT.EQ.BRECLEN+1) THEN ! Read all of line + ILEN = 0 ! so indicate need to read + POINT = 1 ! new line to calling routine. + RETURN + END IF + + IF (IER.GT.0) THEN ! Error in reading file. + ILEN = -1 ! ILEN = -1 signifies error + POINT = 1 + LEFT_LEN = 0 + RETURN + END IF + + IF (LEFT_LEN.GT.0) THEN ! Part of line is left from + ILEN = ICHAR(LEFT(:1)) ! previous record read. + IF (LEFT_LEN.LE.BRECLEN) THEN ! Rest of it is in next record. + BUFFER = LEFT(2:ILEN-LEFT_LEN+1)//TEMP(:LEFT_LEN) ! Output line. + POINT = LEFT_LEN + 1 ! Update pointers. + LEFT_LEN = 0 + ELSE ! Rest of line is longer than + LEFT(ILEN-LEFT_LEN+2:) = TEMP ! a record, so store record + LEFT_LEN = LEFT_LEN - BRECLEN ! and request another read. + ILEN = 0 ! Request new record read. + END IF + ELSE ! Else nothing left over. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Get line length + IF (ILEN.GT.BRECLEN-POINT) THEN ! If it extends to next record + LEFT = TEMP(POINT:) ! Store it in leftover buffer + LEFT_LEN = ILEN - (BRECLEN-POINT) ! Store leftover length + ILEN = 0 ! Request new record read + POINT = 1 ! Update record pointer. + ELSE IF (ILEN.EQ.0) THEN ! Empty line signifies + POINT = 1 ! end of message. + ELSE ! Else message line fully read + BUFFER = TEMP(POINT+1:POINT+ILEN) ! So output it + POINT = POINT+ILEN+1 ! and update pointer. + END IF + END IF + + RETURN + + ENTRY TEST_MORE_LINES(ILEN) ! Test for more lines in record. + ! Returns length of next line. + IF (POINT.EQ.BRECLEN+1) THEN ! If pointer greater than + ILEN = 0 ! record, no more lines. + ELSE ! Else there is another line. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Output it's length. + END IF + + RETURN + + END + + + + SUBROUTINE GET_REMOTE_MESSAGE(IER) +C +C SUBROUTINE GET_REMOTE_MESSAGE +C +C FUNCTION: +C Gets remote message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($RMSDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + IF (SCRATCH_R1.NE.0) THEN ! Is queue empty? + SCRATCH_R = SCRATCH_R1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_R,INPUT) + SCRATCH_R1 = SCRATCH_R ! Init header pointer + END IF + + ILEN = 128 + IER = 0 + LENGTH = 0 + DO WHILE (ILEN.GT.0.AND.IER.EQ.0) + READ (REMOTE_UNIT,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0.AND.ILEN.GT.0) THEN + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.RMS$_RER) THEN ! Ignore this error + IER = 0 + ILEN = 0 + ELSE + CALL SYS_GETMSG(IER1) + LENGTH = 0 + IER1 = IER + CALL DISCONNECT_REMOTE + IER = IER1 ! IER is set to 0 by DISCONNECT_REMOTE + END IF + ELSE IF (ILEN.GT.0) THEN + CALL WRITE_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT) + LENGTH = LENGTH + 1 + END IF + END DO + + RETURN + END + + + + + SUBROUTINE DELETE_ENTRY(BULL_ENTRY) +C +C SUBROUTINE DELETE_ENTRY +C +C FUNCTION: +C To delete a directory entry. +C +C INPUTS: +C BULL_ENTRY - Bulletin entry number to delete +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (NBULL.GT.0) THEN + CALL READDIR(0,IER) + NBULL = -NBULL + CALL WRITEDIR(0,IER) + END IF + + IF (BTEST(FOLDER_FLAG,1)) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',IOSTAT=IER,STATUS='OLD', + & RECL=LINE_LENGTH,CARRIAGECONTROL='LIST',ACCESS='APPEND') + IF (IER.NE.0) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + WRITE (3,'(A)') CHAR(12) + END IF + + CALL OPEN_BULLFIL + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + WRITE(3,1050) INPUT(7:ILEN) + ELSE + WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + + CALL CLOSE_BULLFIL + END IF + +900 CALL READDIR(BULL_ENTRY,IER) + DELETE(UNIT=2) + + NEMPTY = NEMPTY + LENGTH + CALL WRITEDIR(0,IER) + +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,' Date: ',A11) + + RETURN + END + + + + + SUBROUTINE GET_EXDATE(EXDATE,NDAYS) +C +C SUBROUTINE GET_EXDATE +C +C FUNCTION: Computes expiration date giving number of days to expire. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*11 EXDATE + + CHARACTER*3 MONTHS(12) + DIMENSION LENGTH(12) + DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP', + & 'OCT','NOV','DEC'/ + DATA LENGTH/31,27,31,30,31,30,31,31,30,31,30,31/ + + CALL SYS$ASCTIM(,EXDATE,,) ! Get the present date + + DECODE(2,'(I2)',EXDATE(:2)) DAY ! Get day + DECODE(4,'(I4)',EXDATE(8:11)) YEAR ! Get year + + MONTH = 1 + DO WHILE (MONTHS(MONTH).NE.EXDATE(4:6)) ! Get month + MONTH = MONTH + 1 + END DO + + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + + NUM_DAYS = NDAYS ! Put number of days into buffer variable + + DO WHILE (NUM_DAYS.GT.0) + IF (NUM_DAYS+DAY.GT.LENGTH(MONTH)) THEN + ! If expiration date exceeds end of month + NUM_DAYS = NUM_DAYS - (LENGTH(MONTH) - DAY + 1) + ! Decrement # of days by days left in month + DAY = 1 ! Reset day to first of month + MONTH = MONTH + 1 ! Increment month pointer + IF (MONTH.EQ.13) THEN ! Moved into next year? + MONTH = 1 ! Reset month pointer + YEAR = YEAR + 1 ! Increment year pointer + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + END IF + ELSE ! If expiration date is within the month + DAY = DAY + NUM_DAYS ! Find expiration day + NUM_DAYS = 0 ! Force loop exit + END IF + END DO + + ENCODE(2,'(I2)',EXDATE(:2)) DAY ! Put day into new date + ENCODE(4,'(I4)',EXDATE(8:11)) YEAR ! Put year into new date + EXDATE(4:6) = MONTHS(MONTH) ! Put month into new date + + RETURN + END + + + + SUBROUTINE GET_LINE(INPUT,LEN_INPUT) +C +C SUBROUTINE GET_LINE +C +C FUNCTION: +C Gets line of input from terminal. +C +C OUTPUTS: +C LEN_INPUT - Length of input line. If = -1, CTRLC entered. +C if = -2, CTRLZ entered. +C +C NOTES: +C Also, on first call, set LEN_INPUT to 1+LENGTH OF INPUT CHARCTER +C for initializing the CTRLC AST. +C + + IMPLICIT INTEGER (A-Z) + + LOGICAL*1 DESCRIP(8),DTYPE,CLASS + INTEGER*2 LENGTH + CHARACTER*(*) INPUT + EQUIVALENCE (DESCRIP(1),LENGTH),(DESCRIP(3),DTYPE) + EQUIVALENCE (DESCRIP(4),CLASS),(DESCRIP(5),POINTER) + + DATA LENGTH/0/,DTYPE/0/,CLASS/2/,POINTER/0/ + + EXTERNAL SMG$_EOF + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + CHARACTER PROMPT*(*),NULLPROMPT*1 + LOGICAL*1 USE_PROMPT + + USE_PROMPT = .FALSE. + + GO TO 5 + + ENTRY GET_INPUT_PROMPT(INPUT,LEN_INPUT,PROMPT) + + USE_PROMPT = .TRUE. + +5 LIMIT = LEN(INPUT) ! Get input line size limit + INPUT = ' ' ! Clean out input buffer + +C +C Initialize CTRL-C AST with AST routine CTRLC_ROUTINE and +C AST parameter FLAG. When CTRLC occurs, FLAG is set to 1 +C + + CALL DECLARE_CTRLC_AST + + LEN_INPUT = 0 ! Nothing inputted yet + +C +C LIB$GET_INPUT is nice way of getting input from terminal, +C as it handles such thing as accidental wrap around to next line. +C + + IF (DECNET_PROC) THEN + READ (5,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (IER.NE.0) LEN_INPUT = -2 + RETURN + ELSE IF (USE_PROMPT) THEN + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,PROMPT) ! Get line from terminal with prompt + ELSE + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,NULLPROMPT) ! Get line from terminal with no prompt + END IF + + IF (.NOT.IER.AND.IER.NE.%LOC(SMG$_EOF)) CALL EXIT(IER) + + CALL STR$TRIM(DESCRIP,DESCRIP,LEN_INPUT) + + IF (FLAG.EQ.0) THEN ! If no CTRL-C has occurred + CALL CANCEL_CTRLC_AST ! Cancel CTRL-C AST + IF (IER.NE.%LOC(SMG$_EOF)) THEN ! End of input? + LEN_INPUT = MIN(LIMIT,LENGTH) ! No. Get length of line + DO I=0,LEN_INPUT-1 ! Extract from descriptor + CALL GET_VAL(INPUT(I+1:I+1),%VAL(POINTER+I)) + END DO + CALL CONVERT_TABS(INPUT,LEN_INPUT) + LEN_INPUT = MAX(LEN_INPUT,LENGTH) + ELSE + LEN_INPUT = -2 ! If CTRL-Z, say so + END IF + ELSE + LEN_INPUT = -1 ! If CTRL-C, say so + END IF + RETURN + END + + + + SUBROUTINE CONVERT_TABS(INPUT,LEN_INPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT + + PARAMETER TAB = CHAR(9) + + LIMIT = LEN(INPUT) + + DO WHILE (INDEX(INPUT,TAB).GT.0.AND.LEN_INPUT.LT.LIMIT) + TAB_POINT = INDEX(INPUT,TAB) ! Remove tabs + MOVE = ((TAB_POINT-1)/8)*8 + 9 + ADD = MOVE - TAB_POINT + IF (MOVE-1.LE.LIMIT) THEN + INPUT(MOVE:) = INPUT(TAB_POINT+1:) + DO I = TAB_POINT,MOVE-1 + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LEN_INPUT + ADD - 1 + ELSE + DO I = TAB_POINT,LIMIT + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LIMIT+1 + END IF + END DO + + CALL FILTER (INPUT, LEN_INPUT) + + RETURN + END + + + SUBROUTINE FILTER (INCHAR, LENGTH) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INCHAR + + DO I = 1,LENGTH + IF ((INCHAR(I:I).LT.' '.AND. + & INCHAR(I:I).NE.CHAR(13).AND.INCHAR(I:I).NE.CHAR(10))) + & INCHAR(I:I) = '.' + END DO + + RETURN + END + + + SUBROUTINE GET_VAL(OUTPUT,INPUT) ! Used to convert logical + CHARACTER*(*) OUTPUT ! byte to character value + LOGICAL*1 INPUT + OUTPUT = CHAR(INPUT) + RETURN + END + + SUBROUTINE CTRLC_ROUTINE ! CTRL-C AST routine + IMPLICIT INTEGER (A-Z) ! If CTRL-C, come here + + COMMON /CTRLY/ CTRLY + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + IF (FLAG.EQ.2) THEN + CALL LIB$PUT_OUTPUT('Bulletin aborting...') + CALL SYS$CANEXH() + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + CALL EXIT + END IF + FLAG = 1 ! to set flag + RETURN + END + + + + SUBROUTINE DECLARE_CTRLC_AST +C +C SUBROUTINE DECLARE_CTRLC_AST +C +C FUNCTION: +C Declares a CTRLC ast. +C NOTES: +C Assumes terminal assigned to TERM_CHAN in common /TERM_CHAN/. +C + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SETMODE,IO$M_CTRLCAST,CTRLC_ROUTINE + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /CTRLC_FLAG/ FLAG + + FLAG = 0 ! Init CTRL-C flag + IO_CTRLC = %LOC(IO$_SETMODE)+%LOC(IO$M_CTRLCAST) ! Set AST code + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + + ENTRY CANCEL_CTRLC_AST + + IER = SYS$CANCEL(%VAL(TERM_CHAN)) + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + END + + + + + SUBROUTINE GET_INPUT_NOECHO(DATA) +C +C SUBROUTINE GET_INPUT_NOECHO +C +C FUNCTION: Reads data in from terminal without echoing characters. +C Also contains entry to assign terminal. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) DATA,PROMPT + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /READIT/ READIT + + INCLUDE '($TRMDEF)' + + INTEGER TERMSET(2) + + INTEGER MASK(4) + DATA MASK/4*'FFFFFFFF'X/ + + DATA PURGE/.TRUE./ + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NOECHO_PROMPT(DATA,PROMPT) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NUM(DATA,NLEN) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_PURGE,,TERMSET,NLEN,TERM) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA),,, + & TERMSET,NLEN,TERM) + END IF + + IF (TERM.NE.13.AND.TERM.NE.510.AND.NLEN.EQ.0) THEN + ! Input did not end with CR or buffer full + NLEN = 1 + DATA(:1) = CHAR(TERM) + END IF + + RETURN + + ENTRY ASSIGN_TERMINAL + + IER = SYS$ASSIGN('TT',TERM_CHAN,,) ! Assign terminal + + CALL DECLARE_CTRLC_AST + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IF (CLI$PRESENT('KEYPAD')) THEN + CALL SET_KEYPAD + ELSE IF (READIT.EQ.0) THEN + CALL SET_NOKEYPAD + END IF + + TERMSET(1) = 16 + TERMSET(2) = %LOC(MASK) + + DO I=ICHAR('0'),ICHAR('9') + MASK(2) = IBCLR(MASK(2),I-32) + END DO + + RETURN + END + + + + + + SUBROUTINE GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) +C +C SUBROUTINE GETPAGSIZ +C +C FUNCTION: +C Gets page size of the terminal. +C +C OUTPUTS: +C PAGE_LENGTH - Page length of the terminal. +C PAGE_WIDTH - Page size of the terminal. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($DVIDEF)' + + LOGICAL*1 DEVDEPEND(4) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,DVI$_DEVDEPEND,%LOC(DEVDEPEND(1))) + CALL ADD_2_ITMLST(4,DVI$_DEVBUFSIZ,%LOC(PAGE_WIDTH)) + CALL END_ITMLST(GETDVI_ITMLST) ! Get address of itemlist + + CALL SYS$GETDVIW(,,'TT',%VAL(GETDVI_ITMLST),,,,) + + PAGE_LENGTH = ZEXT(DEVDEPEND(4)) + + PAGE_WIDTH = MIN(PAGE_WIDTH,132) + + RETURN + END + + + + + + LOGICAL FUNCTION SLOW_TERMINAL +C +C FUNCTION SLOW_TERMINAL +C +C FUNCTION: +C Indicates that terminal has a slow speed (2400 baud or less). +C +C OUTPUTS: +C SLOW_TERMINAL = .true. if slow, .false. if not. +C + + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SENSEMODE + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON CHAR_BUF(2) + + LOGICAL*1 IOSB(8) + + INCLUDE '($TTDEF)' + + IER = SYS$QIOW(,%VAL(TERM_CHAN),IO$_SENSEMODE,IOSB,,, + & CHAR_BUF,%VAL(8),,,,) + + IF (IOSB(3).LE.TT$C_BAUD_2400) THEN + SLOW_TERMINAL = .TRUE. + ELSE + SLOW_TERMINAL = .FALSE. + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_PRIV +C +C SUBROUTINE SHOW_PRIV +C +C FUNCTION: +C To show privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($PRVDEF)' + + INCLUDE '($SSDEF)' + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + IF (NEW_FLAG(1).EQ.-1.AND.NEW_FLAG(2).EQ.-1) THEN ! Info not present + CALL CLOSE_BULLUSER + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + WRITE (6,'('' Following privileges are needed for privileged + & commands:'')') + DO I=0,38 + IF ((I.LT.32.AND.BTEST(USERPRIV(1),I)).OR. + & (I.GT.31.AND.BTEST(USERPRIV(2),I-32))) THEN + WRITE (6,'(1X,A)') PRIVS(I) + END IF + END DO + ELSE + WRITE (6,'('' ERROR: Cannot show privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + CALL CHKACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE)),IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN + CALL SHOWACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE))) + END IF + + RETURN + + END + + + + + SUBROUTINE SET_PRIV +C +C SUBROUTINE SET_PRIV +C +C FUNCTION: +C To set privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + DATA PRIVS + & /'CMKRNL','CMEXEC','SYSNAM','GRPNAM','ALLSPOOL','DETACH', + & 'DIAGNOSE','LOG_IO','GROUP','ACNT','PRMCEB','PRMMBX','PSWAPM', + & 'ALTPRI','SETPRV','TMPMBX','WORLD','MOUNT','OPER','EXQUOTA', + & 'NETMBX','VOLPRO','PHY_IO','BUGCHK','PRMGBL','SYSGBL','PFNMAP', + & 'SHMEM','SYSPRV','BYPASS','SYSLCK','SHARE','UPGRADE','DOWNGRADE', + & 'GRPPRV','READALL',' ',' ','SECURITY'/ + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + DIMENSION ONPRIV(2),OFFPRIV(2) + + CHARACTER*32 INPUT_PRIV + + IF (.NOT.SETPRV_PRIV().OR..NOT.BTEST(PROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: This command requires SETPRV privileges.'')') + RETURN + END IF + + IF (CLI$PRESENT('ID').OR. + & CLI$PRESENT('ID').EQ.%LOC(CLI$_NEGATED)) THEN + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the IDs + IF (CLI$PRESENT('ID')) THEN + CALL ADD_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + ELSE + CALL DEL_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + END IF + IF (.NOT.IER) CALL SYS_GETMSG(IER) + END DO + RETURN + END IF + + OFFPRIV(1) = 0 + OFFPRIV(2) = 0 + ONPRIV(1) = 0 + ONPRIV(2) = 0 + + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the privileges + PRIV_FOUND = -1 + I = 0 + DO WHILE (I.LT.39.AND.PRIV_FOUND.EQ.-1) + IF (INPUT_PRIV(:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + IF (INPUT_PRIV(3:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + I = I + 1 + END DO + IF (PRIV_FOUND.EQ.-1) THEN + WRITE(6,'('' ERROR: Incorrectly specified privilege = '', + & A)') INPUT_PRIV(:PLEN) + RETURN + ELSE IF (INPUT_PRIV(:2).EQ.'NO') THEN + IF (INPUT_PRIV.EQ.'NOSETPRV') THEN + WRITE(6,'('' ERROR: Cannot remove SETPRV privileges.'')') + RETURN + ELSE IF (PRIV_FOUND.LT.32) THEN + OFFPRIV(1) = IBSET(OFFPRIV(1),PRIV_FOUND) + ELSE + OFFPRIV(2) = IBSET(OFFPRIV(2),PRIV_FOUND-32) + END IF + ELSE + IF (PRIV_FOUND.LT.32) THEN + ONPRIV(1) = IBSET(ONPRIV(1),PRIV_FOUND) + ELSE + ONPRIV(2) = IBSET(ONPRIV(2),PRIV_FOUND-32) + END IF + END IF + END DO + + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + USERPRIV(1) = USERPRIV(1).OR.ONPRIV(1) + USERPRIV(2) = USERPRIV(2).OR.ONPRIV(2) + USERPRIV(1) = USERPRIV(1).AND.(.NOT.OFFPRIV(1)) + USERPRIV(2) = USERPRIV(2).AND.(.NOT.OFFPRIV(2)) + REWRITE (4) USER_HEADER + WRITE (6,'('' Privileges successfully modified.'')') + ELSE + WRITE (6,'('' ERROR: Cannot modify privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + RETURN + + END + + + + + + + SUBROUTINE ADD_ACL(ID,ACCESS,IER) +C +C SUBROUTINE ADD_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + INCLUDE '($SSDEF)' + + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) THEN + IF (IER.EQ.SS$_NOSUCHID.AND.ADDID.AND. + & INDEX(ACCESS,'C').EQ.0) THEN + CALL GET_UAF(ID,USER,GROUP,ACCOUNT,FLAGS,IER) + IF (.NOT.IER) THEN + CALL ERRSNS(IDUMMY,IER) + WRITE (6,'( + & '' ERROR: Specified username cannot be verified.'')') + CALL SYS_GETMSG(IER) + RETURN + END IF + IDENT = USER + ISHFT(GROUP,16) + IER = SYS$ADD_IDENT(ID,%VAL(IDENT),,) + IF (IER) THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + END IF + END IF + END IF + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_ADDACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IF (INDEX(ACCESS,'C').GT.0.AND.INDEX(ACCESS,'W').EQ.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + SUBROUTINE DEL_ACL(ID,ACCESS,IER) +C +C SUBROUTINE DEL_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + IF (ID.NE.' ') THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_DELACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_DELETEACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + END IF + + IF (INDEX(ACCESS,'C').GT.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + + SUBROUTINE CREATE_FOLDER +C +C SUBROUTINE CREATE_FOLDER +C +C FUNCTION: Creates a new bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + IF (.NOT.SETPRV_PRIV().AND.CLI$PRESENT('NEEDPRIV')) THEN + WRITE(6,'('' ERROR: CREATE is a privileged command.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('CREATE_FOLDER',FOLDER,LEN_T) ! Get folder name + + IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + IF (.NOT.SETPRV_PRIV().AND. ! /NOTIFY /READNEW /BRIEF privileged + & (CLI$PRESENT('NOTIFY').OR.CLI$PRESENT('READNEW').OR. + & CLI$PRESENT('BRIEF').OR.CLI$PRESENT('SYSTEM'))) THEN + WRITE (6,'( + & '' ERROR: No privs for SYSTEM, NOTIFY, BRIEF or READNEW.'')') + RETURN + END IF + + IF (CLI$PRESENT('NODE')) THEN ! Remote node specified? + IER = CLI$GET_VALUE('NODE',FOLDER_BBOARD,LEN_B) ! Get node name + FOLDER_BBOARD = '::'//FOLDER_BBOARD(:LEN_B) + FOLDER1_BBOARD = FOLDER_BBOARD + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE IF (CLI$PRESENT('SYSTEM').AND. + & .NOT.BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' ERROR: /SYSTEM not allowed as remote node'', + & '' is not SYSTEM folder.'')') + RETURN + END IF + END IF + + LENDES = 0 + DO WHILE (LENDES.EQ.0) + IF (CLI$PRESENT('DESCRIPTION')) THEN ! DESCRIPTION specified? + IER = CLI$GET_VALUE('DESCRIPTION',FOLDER_DESCRIP,LENDES) + ELSE + WRITE (6,'('' Enter one line description of folder.'')') + CALL GET_LINE(FOLDER_DESCRIP,LENDES) ! Get input line + FOLDER_DESCRIP = FOLDER_DESCRIP(:LENDES) ! End fill with spaces + END IF + IF (LENDES.LE.0) THEN + WRITE (6,'('' Aborting folder creation.'')') + RETURN + ELSE IF (LENDES.GT.80) THEN ! If too many characters + WRITE(6,'('' ERROR: folder must be < 80 characters.'')') + LENDES = 0 + END IF + END DO + + CALL OPEN_BULLFOLDER ! Open folder file + READ (7,IOSTAT=IER,KEY=FOLDER,KEYID=0) + ! See if folder exists + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Specified folder already exists.'')') + GO TO 1000 + END IF + + IF (CLI$PRESENT('OWNER')) THEN + IF (.NOT.SETPRV_PRIV().AND..NOT.CLI$PRESENT('ID')) THEN + WRITE (6,'('' ERROR: /OWNER requires privileges.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + IF (LEN_P.GT.12) THEN + WRITE (6,'('' ERROR: Folder owner name must be'', + & '' no more than 12 characters long.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (CLI$PRESENT('ID')) THEN + IER = CHKPRO(FOLDER1_OWNER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: ID not valid.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + ELSE + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner not valid username.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + END IF + FOLDER_OWNER = FOLDER1_OWNER + END IF + ELSE + FOLDER_OWNER = USERNAME ! Get present username + FOLDER1_OWNER = FOLDER_OWNER ! Save for later + END IF + + FOLDER_SET = .TRUE. + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + +C +C Folder file is placed in the directory FOLDER_DIRECTORY. +C The file prefix is the name of the folder. +C + + FD_LEN = TRIM(FOLDER_DIRECTORY) + IF (FD_LEN.EQ.0) THEN + WRITE (6,'('' ERROR: System programmer has disabled folders.'')') + GO TO 910 + ELSE + FOLDER_FILE = FOLDER_DIRECTORY(:FD_LEN)//FOLDER + END IF + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder directory file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='NEW', + 1 ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',IOSTAT=IER) + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder message file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + FOLDER_FLAG = 0 + + IF (CLI$PRESENT('PRIVATE').OR.CLI$PRESENT('SEMIPRIVATE')) THEN + ! Will folder have access limitations? + FOLDER1_FILE = FOLDER_FILE + CLOSE (UNIT=1) + CLOSE (UNIT=2) + IF (CLI$PRESENT('SEMIPRIVATE')) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER_OWNER,'R+W+C',IER) + OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLDIR',STATUS='OLD',IOSTAT=IER1) + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='OLD',IOSTAT=IER1) + IF (.NOT.IER) THEN + WRITE(6, + & '('' ERROR: Cannot create private folder using ACLs.'')') + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + + IER = 0 + LAST_NUMBER = 1 + DO WHILE (IER.EQ.0.AND.LAST_NUMBER.LT.FOLDER_MAX-1) + READ (7,IOSTAT=IER,KEY=LAST_NUMBER,KEYID=1) + LAST_NUMBER = LAST_NUMBER + 1 + END DO + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder limit of '',I,'' has been reached.'')') + & FOLDER_MAX + WRITE (6,'('' Unable to add specified folder.'')') + GO TO 910 + ELSE + FOLDER1_NUMBER = LAST_NUMBER - 1 + END IF + + IF (.NOT.CLI$PRESENT('NODE')) THEN + FOLDER_BBOARD = 'NONE' + IF (REMOTE_SET) CLOSE (UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + FOLDER_BBEXPIRE = 14 + F_NBULL = 0 + NBULL = 0 + F_NEWEST_BTIM(1) = 0 + F_NEWEST_BTIM(2) = 0 + F_NEWEST_NOSYS_BTIM(1) = 0 + F_NEWEST_NOSYS_BTIM(2) = 0 + F_EXPIRE_LIMIT = 0 + FOLDER_NUMBER = FOLDER1_NUMBER + ELSE + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + IF (FOLDER1.NE.FOLDER) THEN ! Different remote folder name? + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! If so, store name in directory file + BULLDIR_HEADER(13:) = FOLDER1 + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:LEN_B+2)//'*' + FOLDER1 = FOLDER + END IF + REMOTE_SET = .TRUE. + IF (BTEST(FOLDER1_FLAG,0)) FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + FOLDER1_FLAG = FOLDER_FLAG + FOLDER1_DESCRIP = FOLDER_DESCRIP + FOLDER_COM = FOLDER1_COM + NBULL = F_NBULL + END IF + + FOLDER_OWNER = FOLDER1_OWNER + + IF (CLI$PRESENT('SYSTEM')) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + END IF + + IF (CLI$PRESENT('ID')) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,6) + END IF + + CALL WRITE_FOLDER_FILE(IER) + CALL MODIFY_SYSTEM_LIST(0) + + CLOSE (UNIT=1) + CLOSE (UNIT=2) + + NOTIFY = 0 + READNEW = 0 + BRIEF = 0 + IF (CLI$PRESENT('NOTIFY')) NOTIFY = 1 + IF (CLI$PRESENT('READNEW')) READNEW = 1 + IF (CLI$PRESENT('SHOWNEW')) BRIEF = 1 + IF (CLI$PRESENT('BRIEF')) THEN + BRIEF = 1 + READNEW = 1 + END IF + CALL SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) + + WRITE (6,'('' Folder is now set to '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + + GO TO 1000 + +910 WRITE (6,'('' Aborting folder creation.'')') + IF (FOLDER_NUMBER.EQ.0) FOLDER_SET = .FALSE. + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + +1000 CALL CLOSE_BULLFOLDER + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + INTEGER FUNCTION CHKPRO(INPUT) +C +C Description: +C Parse given identify into binary ACL format. +C Call SYS$CHKPRO to check if present process has read +C access to an object if the object's protection is the ACL. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER ACL*255 + CHARACTER*(*) INPUT + + INCLUDE '($CHPDEF)' + + CHKPRO = SYS$PARSE_ACL('(IDENTIFIER='//INPUT(:TRIM(INPUT))// + & ',ACCESS=R)',ACL,,) ! Convert to ACL into binary format + IF (.NOT.CHKPRO) RETURN ! Exit if can't + + FLAGS = CHP$M_READ ! Specify read access checking + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACL(:1)),CHP$_ACL,%LOC(ACL(1:1))) + CALL ADD_2_ITMLST(4,CHP$_FLAGS,%LOC(FLAGS)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + CHKPRO = SYS$CHKPRO(%VAL(ACL_ITMLST)) ! Check if process has the + ! rights-id assigned to it + RETURN + END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin5.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin5.for new file mode 100644 index 0000000..145e949 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin5.for @@ -0,0 +1,1859 @@ +C +C BULLETIN5.FOR, Version 10/15/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) +C +C SUBROUTINE SET_FOLDER_DEFAULT +C +C FUNCTION: Sets flag defaults for specified folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL CLI$_NEGATED + + ALL = .FALSE. + DEFAULT = 0 + + IF (INCMD(:3).EQ.'SET') THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Privileges needed for changing defaults.'')') + RETURN + END IF + ALL = CLI$PRESENT('ALL') + DEFAULT = CLI$PRESENT('DEFAULT') + CALL OPEN_BULLUSER_SHARED + IF (CLI$PRESENT('PERMANENT')) THEN + CALL SET_PERM(NOTIFY,READNEW,BRIEF) + ELSE IF (CLI$PRESENT('NOPERMANENT')) THEN + IF (NOTIFY.GE.0) CALL SET_PERM(0,-1,-1) + IF (READNEW.GE.0.OR.BRIEF.GE.0) CALL SET_PERM(-1,0,0) + END IF + ELSE + CALL OPEN_BULLUSER_SHARED + END IF + + CALL READ_USER_FILE_HEADER(IER) + IF (DEFAULT.EQ.0.OR.DEFAULT) THEN + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + REWRITE(4) USER_HEADER + END IF + + IF (ALL.OR.(BRIEF.NE.-1.AND.NOTIFY.NE.-1.AND.READNEW.NE.-1)) THEN + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + IF (TEMP_USER(:1).NE.'*'.AND.TEMP_USER(:1).NE.':') THEN + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG,FOLDER_NUMBER) + REWRITE(4) TEMP_USER//USER_ENTRY(13:) + END IF + CALL READ_USER_FILE(IER) + END DO + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + SUBROUTINE READ_PERM + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BULL_PERM/ SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + DIMENSION SET_PERM_FLAG(FLONG) + DIMENSION BRIEF_PERM_FLAG(FLONG) + DIMENSION NOTIFY_PERM_FLAG(FLONG) + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*PERM',IOSTAT=IER) TEMP_USER, + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + SET_PERM_FLAG(I) = 0 + BRIEF_PERM_FLAG(I) = 0 + NOTIFY_PERM_FLAG(I) = 0 + END DO + BRIEF_PERM_FLAG(1) = 1 ! SHOWNEW permanent for GENERAL folder + WRITE (4,IOSTAT=IER) + & '*PERM ', + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + CALL READ_USER_FILE_HEADER(IER) + IF (.NOT.TEST2(SET_FLAG_DEF,0)) THEN + CALL SET2(BRIEF_FLAG_DEF,0) + REWRITE(4) USER_HEADER + END IF + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + IF (TEMP_USER(:1).NE.'*'.AND.TEMP_USER(:1).NE.':') THEN + IF (.NOT.TEST2(SET_FLAG,0)) THEN + CALL SET2(BRIEF_FLAG,0) + REWRITE(4) TEMP_USER//USER_ENTRY(13:) + END IF + END IF + CALL READ_USER_FILE(IER) + END DO + ELSE + UNLOCK 4 + END IF + + RETURN + + ENTRY SET_PERM(NOTIFY,READNEW,BRIEF) + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*PERM',IOSTAT=IER) TEMP_USER, + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + END DO + + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_PERM_FLAG,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_PERM_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_PERM_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_PERM_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_PERM_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_PERM_FLAG,FOLDER_NUMBER) + + REWRITE (4,IOSTAT=IER) TEMP_USER, + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + + + RETURN + + + ENTRY SET_USER_FLAG(NOTIFY,READNEW,BRIEF) + + CALL OPEN_BULLUSER_SHARED + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*PERM',IOSTAT=IER) TEMP_USER, + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + END DO + + CALL CLOSE_BULLUSER + + IER = .TRUE. + IF (NOTIFY.EQ.0) THEN + IF (TEST2(NOTIFY_PERM_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' ERROR: NOTIFY is permanent for this folder.'')') + RETURN + ELSE + CALL CHANGE_FLAG(0,4) + END IF + ELSE IF (NOTIFY.EQ.1) THEN + CALL CHANGE_FLAG(1,4) + RETURN + ELSE IF (BRIEF.EQ.0.AND.READNEW.EQ.0.AND. + & (TEST2(SET_PERM_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_PERM_FLAG,FOLDER_NUMBER))) THEN + IER = .FALSE. + ELSE IF (BRIEF.EQ.1.AND.READNEW.EQ.0.AND. + & TEST2(SET_PERM_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(BRIEF_PERM_FLAG,FOLDER_NUMBER)) THEN + IER = .FALSE. + ELSE IF (BRIEF.EQ.1.AND.READNEW.EQ.1.AND. + & (TEST2(SET_PERM_FLAG,FOLDER_NUMBER).XOR. + & TEST2(BRIEF_PERM_FLAG,FOLDER_NUMBER))) THEN + IER = .FALSE. + END IF + + IF (IER) THEN + IF (READNEW.GE.0) CALL CHANGE_FLAG(READNEW,2) + IF (BRIEF.GE.0) CALL CHANGE_FLAG(BRIEF,3) + ELSE + WRITE (6,'('' ERROR: PERMANENT flags exist for this folder.'')') + WRITE (6,'('' Flags will be set to those permanent settings.'')') + + IF (TEST2(SET_PERM_FLAG,FOLDER_NUMBER)) THEN + CALL CHANGE_FLAG(1,2) + ELSE + CALL CHANGE_FLAG(0,2) + END IF + + IF (TEST2(BRIEF_PERM_FLAG,FOLDER_NUMBER)) THEN + CALL CHANGE_FLAG(1,3) + ELSE + CALL CHANGE_FLAG(0,3) + END IF + END IF + + RETURN + END + + + + + + SUBROUTINE REMOVE_FOLDER +C +C SUBROUTINE REMOVE_FOLDER +C +C FUNCTION: Removes a bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,TEMP*80 + + IER = CLI$GET_VALUE('REMOVE_FOLDER',FOLDER1,LEN_T) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + IF (.NOT.FOLDER_SET) THEN + WRITE (6,'('' ERROR: No folder specified.'')') + RETURN + ELSE + FOLDER1 = FOLDER + END IF + ELSE IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Are you sure you want to remove folder ' + & //FOLDER1(:TRIM(FOLDER1))//' (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not removed.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if folder exists + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + GO TO 1000 + END IF + + IF (.NOT.FOLDER_ACCESS(USERNAME,FOLDER1_FLAG,FOLDER1_OWNER).OR. + & FOLDER1.EQ.'GENERAL') THEN + WRITE (6,'('' ERROR: You are not able to remove the folder.'')') + GO TO 1000 + END IF + + TEMP = FOLDER_FILE + FOLDER_FILE = FOLDER1_FILE + + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER1_FLAG,2)) THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) FLEN = FLEN - 1 + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER1_BBOARD(3:FLEN) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Deregister remote SYSTEM folder + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + IF (IER.EQ.1) FOLDER1 = BULLDIR_HEADER(13:) + CALL CLOSE_BULLDIR + END IF + WRITE (17,'(2A)',IOSTAT=IER) 1,FOLDER1 ! Select folder + IF (IER.EQ.0) READ(17,'(5A)',IOSTAT=IER) ! Throw away response + IF (IER.EQ.0) WRITE(17,'(2A)',IOSTAT=IER) 14,0 ! Deregister + CLOSE (UNIT=17) + END IF + END IF + + TEMPSET = FOLDER_SET + FOLDER_SET = .TRUE. + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + ! in case files don't exist and are created. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + FOLDER_FILE = TEMP + FOLDER_SET = TEMPSET + + DELETE (7) + + TEMP_NUMBER = FOLDER_NUMBER + FOLDER_NUMBER = FOLDER1_NUMBER + CALL SET_FOLDER_DEFAULT(0,0,0) + FOLDER_NUMBER = TEMP_NUMBER + + WRITE (6,'('' Folder removed.'')') + + IF (FOLDER.EQ.FOLDER1) THEN + FOLDER_SET = .FALSE. + ELSE + REMOTE_SET = REMOTE_SET_SAVE + END IF + +1000 CALL CLOSE_BULLFOLDER + + RETURN + + END + + + SUBROUTINE SELECT_FOLDER(OUTPUT,IER) +C +C SUBROUTINE SELECT_FOLDER +C +C FUNCTION: Selects the specified folder. +C +C INPUTS: +C OUTPUT - Specifies whether status messages are outputted. +C +C NOTES: +C FOLDER_NUMBER is used for selecting the folder. +C If FOLDER_NUMBER = -1, the name stored in FOLDER1 is used. +C If FOLDER_NUMBER = -2, the name stored in FOLDER1 is used, +C but the folder is not selected if it is remote. +C If the specified folder is on a remote node and does not have +C a local entry (i.e. specified via NODENAME::FOLDERNAME), then +C FOLDER_NUMBER is set to -1. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + INCLUDE '($SSDEF)' + + COMMON /POINT/ BULL_POINT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /DCL/ DCL_CMD,DCL_COMMAND + CHARACTER*132 DCL_CMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM + + COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG) + + EXTERNAL CLI$_ABSENT + + CHARACTER*80 LOCAL_FOLDER1_DESCRIP + + DIMENSION FIRST_TIME(FLONG) ! Bit set for folder if folder has + DATA FIRST_TIME /FLONG*0/ ! been selected before this. + + DIMENSION OLD_NEWEST_BTIM(2) + + COMMAND = (INCMD(:3).EQ.'ADD').OR.(INCMD(:3).EQ.'DEL').OR. + & (INCMD(:3).EQ.'DIR').OR.(INCMD(:3).EQ.'IND').OR. + & (INCMD(:3).EQ.'REP').OR.(INCMD(:3).EQ.'SEL').OR. + & (INCMD(:3).EQ.'SET') + + IF (.NOT.OUTPUT.OR.FOLDER_NUMBER.NE.-1.OR.COMMAND) THEN + IF (OUTPUT) THEN ! Get folder name + IER = CLI$GET_VALUE('SELECT_FOLDER',FOLDER1) + IF (FOLDER1(1:1).EQ.'"'.AND.INCMD.EQ.'SELECT') THEN + DCL_COMMAND = 1 + DCL_CMD = FOLDER1(2:) + IF (DCL_CMD(TRIM(DCL_CMD):).EQ.'"') THEN + DCL_CMD = DCL_CMD(:TRIM(DCL_CMD)-1) + END IF + IER = %LOC(CLI$_ABSENT) + FOLDER1 = ' ' + END IF + END IF + + FLEN = TRIM(FOLDER1) ! Add GENERAL after :: if no + IF (FLEN.GT.1) THEN ! name specified after the :: + IF (FOLDER1(FLEN-1:FLEN).EQ.'::') THEN + FOLDER1 = FOLDER1(:FLEN)//'GENERAL' + END IF + END IF + + IF (((IER.EQ.%LOC(CLI$_ABSENT).OR.FOLDER1.EQ.'GENERAL').AND. + & OUTPUT).OR.((FOLDER_NUMBER.EQ.0.OR.(FOLDER1.EQ.'GENERAL'.AND. + & FOLDER_NUMBER.LE.-1)).AND..NOT.OUTPUT)) THEN ! Select GENERAL + FOLDER_NUMBER = 0 + FOLDER1 = 'GENERAL' + END IF + END IF + + REMOTE_TEST = 0 + + IF (SAVE_FOLDER_Q1.NE.0) THEN ! Have folder info + FOLDER1_COM = FOLDER_COM + IER = 0 + ELSE + CALL OPEN_BULLFOLDER_SHARED ! Go find folder + + IF (OUTPUT.OR.FOLDER_NUMBER.LE.-1) THEN + REMOTE_TEST = INDEX(FOLDER1,'::') + IF (REMOTE_TEST.GT.0) THEN + FOLDER1_BBOARD = '::'//FOLDER1(:REMOTE_TEST-1) + FOLDER1 = FOLDER1(REMOTE_TEST+2:TRIM(FOLDER1)) + FOLDER1_NUMBER = -1 + IER = 0 + ELSE IF (INCMD(:2).EQ.'SE') THEN + CALL READ_FOLDER_FILE_KEYNAME_TEMP + & (FOLDER1(:TRIM(FOLDER1)),IER) + ELSE + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + END IF + ELSE + FOLDER1_NUMBER = FOLDER_NUMBER + CALL READ_FOLDER_FILE_KEYNUM_TEMP(FOLDER_NUMBER,IER) + END IF + + IF (REMOTE_TEST.EQ.0) THEN + IF (BTEST(FOLDER1_FLAG,29)) THEN ! Error in folder flag!! + FOLDER1_FLAG = FOLDER1_FLAG.AND.3 + F1_EXPIRE_LIMIT = 0 + CALL REWRITE_FOLDER_FILE_TEMP + END IF + END IF + + CALL CLOSE_BULLFOLDER + END IF + + IF (IER.EQ.0.AND.FOLDER1_BBOARD(:2).EQ.'::') THEN + IF (FOLDER_NUMBER.EQ.-2) RETURN ! Don't allow + LOCAL_FOLDER1_FLAG = FOLDER1_FLAG + LOCAL_FOLDER1_DESCRIP = FOLDER1_DESCRIP + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + IF (OUTPUT) THEN + WRITE (6,'('' ERROR: Unable to select the folder.'')') + WRITE (6,'('' Cannot connect to node '',A,''.'')') + & FOLDER1_BBOARD(3:TRIM(FOLDER1_BBOARD)) + END IF + RETURN + END IF + IF (REMOTE_TEST.GT.0) THEN ! Folder specified with "::" + FOLDER1 = FOLDER1_BBOARD(3:TRIM(FOLDER1_BBOARD))//'::'// + & FOLDER1 + FOLDER1_NUMBER = -1 + REMOTE_SET = .TRUE. + ELSE ! True remote folder + FOLDER1_DESCRIP = LOCAL_FOLDER1_DESCRIP ! Use local description + IF (BTEST(FOLDER1_FLAG,0)) THEN ! Copy remote folder protection + LOCAL_FOLDER1_FLAG = IBSET(LOCAL_FOLDER1_FLAG,0) + ELSE + LOCAL_FOLDER1_FLAG = IBCLR(LOCAL_FOLDER1_FLAG,0) + END IF + FOLDER1_FLAG = LOCAL_FOLDER1_FLAG ! Use local flag info + CALL OPEN_BULLFOLDER ! Update local folder information + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + OLD_NEWEST_BTIM(1) = F_NEWEST_BTIM(1) + OLD_NEWEST_BTIM(2) = F_NEWEST_BTIM(2) + FOLDER_COM = FOLDER1_COM + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + REMOTE_SET = .TRUE. + DIFF = COMPARE_BTIM(OLD_NEWEST_BTIM,F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN + CALL READ_NOTIFY + IF (TEST2(NOTIFY_REMOTE,FOLDER_NUMBER)) THEN + CALL NOTIFY_REMOTE_USERS(OLD_NEWEST_BTIM) + END IF + END IF + END IF + END IF + + IF (IER.EQ.0) THEN ! Folder found + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + IF (BTEST(FOLDER1_FLAG,0).AND.FOLDER1_BBOARD(:2).NE.'::' + & .AND..NOT.SETPRV_PRIV()) THEN + ! Is folder protected and not remote? + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER1_OWNER) THEN + IF (SETPRV_PRIV()) THEN + READ_ACCESS = 1 + WRITE_ACCESS = 1 + ELSE + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + END IF + IF (.NOT.READ_ACCESS.AND..NOT.WRITE_ACCESS) THEN + IF (OUTPUT) THEN + WRITE(6,'('' You are not allowed to access folder.'')') + WRITE(6,'('' See '',A,'' if you wish to access folder.'')') + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + ELSE IF (TEST2(BRIEF_FLAG,FOLDER1_NUMBER).OR. + & TEST2(SET_FLAG,FOLDER1_NUMBER)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER1_NUMBER) + CALL CLR2(SET_FLAG,FOLDER1_NUMBER) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + IER = 0 + RETURN + END IF + ELSE IF (BTEST(FOLDER1_FLAG,0).AND. + & IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER1) + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + ELSE ! Folder not protected + IER = SS$_ACLEMPTY.OR.SS$_NORMAL ! Indicate folder selected + END IF + + IF (FOLDER1_BBOARD(:2).NE.'::') THEN + IF (REMOTE_SET) CLOSE(UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + END IF + + IF (IER) THEN + FOLDER_COM = FOLDER1_COM ! Folder successfully set so + FOLDER_FILE = FOLDER1_FILE ! update folder parameters + + IF (FOLDER_NUMBER.NE.0) THEN + FOLDER_SET = .TRUE. + ELSE + FOLDER_SET = .FALSE. + END IF + + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + WRITE (6,'('' Folder has been set to '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + BULL_POINT = 0 ! Reset pointer to first bulletin + END IF + + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER_OWNER) THEN + IF (.NOT.WRITE_ACCESS) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') + & WRITE (6,'('' Folder only accessible for reading.'')') + READ_ONLY = .TRUE. + ELSE + READ_ONLY = .FALSE. + END IF + ELSE + READ_ONLY = .FALSE. + END IF + + IF (FOLDER_NUMBER.GT.0) THEN + IF (TEST_BULLCP().GT.0) THEN + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + ELSE IF (.NOT.TEST2(FIRST_TIME,FOLDER_NUMBER)) THEN + ! If first select, look for expired messages. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) ! Get header info from BULLDIR.DAT + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired? + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)) + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown bulletins exist? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER.GT.20*356.OR.IER1.LE.0) THEN + CALL UPDATE ! Need to update + END IF + ELSE + NBULL = 0 + END IF + CALL CLOSE_BULLDIR + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + END IF + END IF + + IF (OUTPUT) THEN + IF (FOLDER_NUMBER.GE.0.AND.CLI$PRESENT('MARKED')) THEN + READ_TAG = .TRUE. + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + IF (INCMD(:3).NE.'DIR') THEN + IF (IER.EQ.0) THEN + WRITE(6,'('' NOTE: Only marked messages'', + & '' will be shown.'')') + ELSE + WRITE(6,'('' ERROR: No marked messages found.'')') + END IF + END IF + ELSE + READ_TAG = .FALSE. + END IF + END IF + + IF (FOLDER_NUMBER.NE.0.AND..NOT.READ_TAG) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN ! If new unread messages + CALL FIND_NEWEST_BULL ! See if we can find it + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + END IF + END IF + END IF + END IF + IER = 1 + ELSE IF (OUTPUT) THEN + WRITE (6,'('' Cannot access specified folder.'')') + CALL SYS_GETMSG(IER) + END IF + ELSE ! Folder not found + IF (OUTPUT) WRITE (6,'('' ERROR: Folder does not exist.'')') + IER = 0 + END IF + + RETURN + + END + + + + SUBROUTINE CONNECT_REMOTE_FOLDER(READ_ONLY,IER) +C +C SUBROUTINE CONNECT_REMOTE_FOLDER +C +C FUNCTION: Connects to folder that is located on other DECNET node. +C + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_UNIT /15/ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /READIT/ READIT + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*12 FOLDER_BBOARD_SAVE,FOLDER_OWNER_SAVE + CHARACTER*25 FOLDER_SAVE + + DIMENSION DUMMY(4) + + REMOTE_UNIT = 31 - REMOTE_UNIT + + SAME = .TRUE. + LEN_BBOARD = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN ! Remote folder name different + SAME = .FALSE. ! from local? Yes. + LEN_BBOARD = LEN_BBOARD - 1 + END IF + + OPEN (UNIT=REMOTE_UNIT,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=FOLDER1_BBOARD(3:LEN_BBOARD)//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IF (.NOT.SAME) THEN + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + FOLDER_FILE = FOLDER1_FILE + FOLDER_SAVE = FOLDER1 + FOLDER1 = BULLDIR_HEADER(13:) + END IF + SYSLOG = .FALSE. + IF (READIT.EQ.1) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 1,'SYSTEM?' + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) IER1 + IF (IER1) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 1,FOLDER1//'+' + SYSLOG = .TRUE. + END IF + END IF + IF (.NOT.SYSLOG) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 1,FOLDER1 + END IF + FOLDER_OWNER_SAVE = FOLDER1_OWNER + FOLDER_BBOARD_SAVE = FOLDER1_BBOARD + FOLDER_NUMBER_SAVE = FOLDER1_NUMBER + IF (IER.EQ.0) THEN + IF (SYSLOG) THEN + READ(REMOTE_UNIT,'(7A)',IOSTAT=IER)IER1,READ_ONLY, + & DUMMY(1),DUMMY(2),DUMMY(3),DUMMY(4),FOLDER1_COM + ELSE + READ(REMOTE_UNIT,'(5A)',IOSTAT=IER)IER1,READ_ONLY, + & DUMMY(1),DUMMY(2),FOLDER1_COM + END IF + END IF + IF (.NOT.SAME) FOLDER1 = FOLDER_SAVE + FOLDER1_BBOARD = FOLDER_BBOARD_SAVE + FOLDER1_NUMBER = FOLDER_NUMBER_SAVE + FOLDER1_OWNER = FOLDER_OWNER_SAVE + END IF + + IF (IER.NE.0.OR..NOT.IER1) THEN + CLOSE (UNIT=REMOTE_UNIT) + REMOTE_UNIT = 31 - REMOTE_UNIT + IF (IER.EQ.0.AND.FOLDER_NUMBER_SAVE.GE.0.AND. + & TEST_BULLCP().NE.2) THEN ! Not BULLCP process + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + & .OR.TEST2(SET_FLAG,FOLDER_NUMBER_SAVE)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + CALL CLR2(SET_FLAG,FOLDER_NUMBER_SAVE) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + END IF + IER = 2 + ELSE + CLOSE (UNIT=31-REMOTE_UNIT) +C +C If remote folder has returned a last read time for the folder, +C and if in /LOGIN mode, or last selected folder was a different +C folder, or folder specified with "::", then update last read time. +C + IF (((FOLDER_NUMBER.NE.FOLDER1_NUMBER.OR.READIT.EQ.1) + & .AND.(DUMMY(1).NE.0.OR.DUMMY(2).NE.0)) + & .OR.FOLDER1_NUMBER.EQ.-1) THEN + LAST_READ_BTIM(1,FOLDER1_NUMBER+1) = DUMMY(1) + LAST_READ_BTIM(2,FOLDER1_NUMBER+1) = DUMMY(2) + IF (SYSLOG) THEN + LAST_SYS_BTIM(1,FOLDER1_NUMBER+1) = DUMMY(3) + LAST_SYS_BTIM(2,FOLDER1_NUMBER+1) = DUMMY(4) + END IF + END IF + IER = 0 + END IF + + RETURN + END + + + + + + + + + + SUBROUTINE UPDATE_FOLDER +C +C SUBROUTINE UPDATE_FOLDER +C +C FUNCTION: Updates folder info due to new message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (FOLDER_NUMBER.LT.0) RETURN + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + + F_NBULL = NBULL + + IF (FOLDER_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + + IF (.NOT.BTEST(SYSTEM,0)) THEN ! Is non-system message? + F_NEWEST_NOSYS_BTIM(1) = F_NEWEST_BTIM(1) ! If so, update latest + F_NEWEST_NOSYS_BTIM(2) = F_NEWEST_BTIM(2) ! system time. + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + SUBROUTINE SHOW_FOLDER +C +C SUBROUTINE SHOW_FOLDER +C +C FUNCTION: Shows the information on any folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /BULL_PERM/ SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + DIMENSION SET_PERM_FLAG(FLONG) + DIMENSION BRIEF_PERM_FLAG(FLONG) + DIMENSION NOTIFY_PERM_FLAG(FLONG) + + INCLUDE '($SSDEF)' + + INCLUDE '($RMSDEF)' + + EXTERNAL CLI$_ABSENT + + IF (INDEX(INCMD,'/A').GT.0.OR.INDEX(INCMD,'/a').GT.0) THEN + WRITE (6,'('' ERROR: /ALL is invalid qualifier.'')') + RETURN + END IF + + IF (CLI$GET_VALUE('SHOW_FOLDER',FOLDER1).EQ.%LOC(CLI$_ABSENT)) + & FOLDER1 = FOLDER + + IF (INDEX(FOLDER1,'::').NE.0) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Specified folder was not found.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (FOLDER.EQ.FOLDER1) THEN + WRITE (6,1000) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + ELSE + WRITE (6,1010) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + END IF + + IF (CLI$PRESENT('FULL')) THEN + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL).OR.(.NOT.IER)) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND. ! Is folder remote + & BTEST(FOLDER1_FLAG,0)) THEN ! and private? + WRITE (6,'('' Folder is a private folder.'')') + ELSE + WRITE (6,'('' Folder is not a private folder.'')') + END IF + ELSE + IF (SETPRV_PRIV()) THEN + READ_ACCESS = 1 + WRITE_ACCESS = 1 + ELSE + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + END IF + IF (WRITE_ACCESS) + & CALL SHOWACL(FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL') + END IF + IF (FOLDER_ACCESS(USERNAME,FOLDER1_FLAG,FOLDER1_OWNER)) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').EQ.0) THEN + WRITE (6,'('' Folder is located on node '', + & A,''.'')') FOLDER1_BBOARD(3:FLEN) + ELSE + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + WRITE (6,'('' Folder is located on node '', + & A,''. Remote folder name is '',A,''.'')') + & FOLDER1_BBOARD(3:FLEN-1), + & BULLDIR_HEADER(13:TRIM(BULLDIR_HEADER)) + END IF + ELSE IF (FOLDER1_BBOARD.NE.'NONE') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (FLEN.GT.0) THEN + WRITE (6,'('' BBOARD for folder is '',A,''.'')') + & FOLDER1_BBOARD(:FLEN) + END IF + IF ((USERB1.EQ.0.AND.GROUPB1.EQ.0).OR.BTEST(USERB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /SPECIAL.'')') + IF (BTEST(GROUPB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /VMSMAIL.'')') + END IF + END IF + ELSE + WRITE (6,'('' No BBOARD has been defined.'')') + END IF + IF (FOLDER1_BBEXPIRE.GT.0) THEN + WRITE (6,'('' Default expiration is '',I3,'' days.'')') + & FOLDER1_BBEXPIRE + ELSE IF (FOLDER1_BBEXPIRE.EQ.-1) THEN + WRITE (6,'('' Default expiration is permanent.'')') + ELSE + WRITE (6,'('' No default expiration set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' SYSTEM has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,1)) THEN + WRITE (6,'('' DUMP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,3)) THEN + WRITE (6,'('' NOPROMPT_EXPIRE has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,4)) THEN + WRITE (6,'('' STRIP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,5)) THEN + WRITE (6,'('' DIGEST has been set.'')') + END IF + IF (F1_EXPIRE_LIMIT.GT.0) THEN + WRITE (6,'('' EXPIRATION limit is '',I3,'' days.'')') + & F1_EXPIRE_LIMIT + END IF + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_HEADER(IER) + CALL READ_PERM + PERM = .FALSE. + IF (TEST2(SET_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER).AND. + & TEST2(SET_PERM_FLAG,FOLDER1_NUMBER)) THEN + PERM = .TRUE. + WRITE (6,'('' Default is BRIEF, which is permanent.'')') + ELSE + WRITE (6,'('' Default is BRIEF.'')') + END IF + ELSE + IF (TEST2(SET_PERM_FLAG,FOLDER1_NUMBER).AND. + & .NOT.TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER)) THEN + PERM = .TRUE. + WRITE (6,'('' Default is READNEW, which is permanent.'')') + ELSE + WRITE (6,'('' Default is READNEW.'')') + END IF + END IF + ELSE + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER).AND. + & .NOT.TEST2(SET_PERM_FLAG,FOLDER1_NUMBER)) THEN + PERM = .TRUE. + WRITE (6,'('' Default is SHOWNEW, which is permanent.'')') + ELSE + WRITE (6,'('' Default is SHOWNEW.'')') + END IF + END IF + END IF + IF (.NOT.PERM) THEN + IF (TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER).AND. + & TEST2(SET_PERM_FLAG,FOLDER1_NUMBER)) THEN + WRITE (6,'('' BRIEF is the permanent setting.'')') + ELSE IF (TEST2(SET_PERM_FLAG,FOLDER1_NUMBER).AND. + & .NOT.TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER)) THEN + WRITE (6,'('' READNEW is the permanent setting.'')') + ELSE IF (TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER).AND. + & .NOT.TEST2(SET_PERM_FLAG,FOLDER1_NUMBER)) THEN + WRITE (6,'('' SHOWNEW is the permanent setting.'')') + END IF + END IF + IF (TEST2(NOTIFY_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(NOTIFY_PERM_FLAG,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is NOTIFY, which is permanent.'')') + ELSE + WRITE (6,'('' Default is NOTIFY.'')') + END IF + ELSE + WRITE (6,'('' Default is NONOTIFY.'')') + END IF + CALL CLOSE_BULLUSER + END IF + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + +1000 FORMAT(' Current folder is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) +1010 FORMAT(' Folder name is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) + END + + + SUBROUTINE DIRECTORY_FOLDERS(FOLDER_COUNT) +C +C SUBROUTINE DIRECTORY_FOLDERS +C +C FUNCTION: Display all FOLDER entries. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + DATA SCRATCH_D1/0/ + + CHARACTER*17 DATETIME + + IF (FOLDER_COUNT.NE.0) GO TO 50 ! Skip init steps if this is + ! not the 1st page of folder + + IF (CLI$PRESENT('DESCRIBE')) THEN + NLINE = 2 ! Include folder descriptor if /DESCRIBE specified + ELSE + NLINE = 1 + END IF + +C +C Folder listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C folder file, and to avoid the possibility of the user holding the screen, +C and thus causing the folder file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + CALL INIT_QUEUE(SCRATCH_D1,FOLDER1_COM) + SCRATCH_D = SCRATCH_D1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDER = 0 + IER = 0 + FOLDER1 = ' ' ! Start folder search + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0) THEN + IF (INDEX(FOLDER1_BBOARD,'::').EQ.0.AND. + & BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + NUM_FOLDER = NUM_FOLDER + 1 + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + IF (NUM_FOLDER.EQ.0) THEN + WRITE (6,'('' There are no folders.'')') + RETURN + END IF + +C +C Folder entries are now in queue. Output queue entries to screen. +C + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + + FOLDER_COUNT = 1 ! Init folder number counter + +50 CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + WRITE (6,'(1X,''Folder'',22X,''Last message'',7X,''Messages'', + & 2X,''Owner'',/,1X,80(''-''))') + + IF (FOLDER_COUNT.EQ.-1) THEN + FOLDER_COUNT = FIRST_FOLDER - (PAGE_LENGTH-4)/NLINE + IF (FOLDER_COUNT.LT.1) FOLDER_COUNT = 1 + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + DO I=1,FOLDER_COUNT-1 + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + END DO + END IF + + IF (.NOT.PAGING) THEN + DISPLAY = (NUM_FOLDER-FOLDER_COUNT+1)*NLINE+2 + ELSE + DISPLAY = MIN((NUM_FOLDER-FOLDER_COUNT+1)*NLINE+2,PAGE_LENGTH-4) + ! If more entries than page size, truncate output + END IF + + FIRST_FOLDER = FOLDER_COUNT + + DO I=FOLDER_COUNT,FOLDER_COUNT+(DISPLAY-2)/NLINE-1 + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + DIFF = COMPARE_BTIM + & (LAST_READ_BTIM(1,FOLDER1_NUMBER+1),F1_NEWEST_BTIM) + IF (F1_NBULL.GT.0) THEN + CALL SYS$ASCTIM(,DATETIME,F1_NEWEST_BTIM,) + ELSE + DATETIME = ' NONE' + END IF + IF (DIFF.GE.0.OR.F1_NBULL.EQ.0) THEN + WRITE (6,1000) ' '//FOLDER1,DATETIME,F1_NBULL,FOLDER1_OWNER + ELSE + WRITE (6,1000) '*'//FOLDER1,DATETIME,F1_NBULL,FOLDER1_OWNER + END IF + IF (NLINE.EQ.2) WRITE (6,'(1X,A)') FOLDER1_DESCRIP + FOLDER_COUNT = FOLDER_COUNT + 1 ! Update folder counter + END DO + + IF (FOLDER_COUNT.GT.NUM_FOLDER) THEN ! Outputted all entries? + FOLDER_COUNT = -1 ! Yes. Set counter to -1. + ELSE + WRITE(6,1010) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(1X,A26,2X,A17,2X,I8,2X,A12) +1010 FORMAT(1X,/,' Press RETURN for more...',/) + + END + + + SUBROUTINE SET_ACCESS(ACCESS) +C +C SUBROUTINE SET_ACCESS +C +C FUNCTION: Set access on folder for specified ID. +C +C PARAMETERS: +C ACCESS - Logical: If .true., grant access, if .false. deny access +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + LOGICAL ACCESS,ALL,READONLY + + EXTERNAL CLI$_ABSENT + + CHARACTER ID*64,RESPONSE*1 + + CHARACTER INPUT*132 + + IF (CLI$PRESENT('ALL')) THEN + ALL = .TRUE. + ELSE + ALL = .FALSE. + END IF + + IF (CLI$PRESENT('READONLY')) THEN + READONLY = .TRUE. + ELSE + READONLY = .FALSE. + END IF + + IER = CLI$GET_VALUE('ACCESS_FOLDER',FOLDER1,LEN) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + FOLDER1 = FOLDER + ELSE IF (LEN.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if it exists + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + ELSE IF (.NOT.FOLDER_ACCESS(USERNAME,FOLDER1_FLAG,FOLDER1_OWNER)) THEN + WRITE (6, + & '('' ERROR: You are not able to modify access to the folder.'')') + ELSE + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + IF ((ALL.AND..NOT.READONLY).OR.(.NOT.ACCESS)) THEN + WRITE (6,'('' ERROR: Folder is not a private folder.'')') + RETURN + END IF + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Folder is not private. Do you want to make it so? (Y/N): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder access was not changed.'')') + RETURN + ELSE + FOLDER1_FLAG = IBSET(FOLDER1_FLAG,0) + IF (READONLY.AND.ALL) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + IF (ALL) THEN ! All finished, so exit + WRITE (6,'('' Access to folder has been modified.'')') + GOTO 100 + END IF + END IF + END IF + + IF (ALL) THEN + IF (ACCESS) THEN + CALL DEL_ACL(' ','R+W',IER) + IF (READONLY) THEN + CALL ADD_ACL('*','R',IER) + ELSE + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + END IF + ELSE + CALL DEL_ACL('*','R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access.'')') + CALL SYS_GETMSG(IER) + END IF + END IF + + DO WHILE (CLI$GET_VALUE('ACCESS_ID',INPUT,ILEN) + & .NE.%LOC(CLI$_ABSENT).AND..NOT.ALL) + IER = SYS_TRNLNM(INPUT,INPUT) + IF (INPUT(:1).EQ.'@') THEN + ILEN = INDEX(INPUT,',') - 1 + IF (ILEN.EQ.-1) ILEN = TRIM(INPUT) + OPEN (UNIT=3,STATUS='OLD',FILE=INPUT(2:ILEN), + & DEFAULTFILE='.DIS',IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Cannot find file '',A)') + & INPUT(2:ILEN) + RETURN + END IF + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + ELSE + FILE_OPEN = .TRUE. + END IF + ELSE + FILE_OPEN = .FALSE. + END IF + DO WHILE (TRIM(INPUT).GT.0) + COMMA = INDEX(INPUT,',') + IF (INPUT(:1).EQ.'[') COMMA = INDEX(INPUT,']') + 1 + IF (INPUT(:1).EQ.'"') COMMA = INDEX(INPUT(2:),'"') + 2 + IF (COMMA.GT.0) THEN + ID = INPUT(1:COMMA-1) + INPUT = INPUT(COMMA+1:) + ELSE + ID = INPUT + INPUT = ' ' + END IF + ILEN = TRIM(ID) + IF (ID.EQ.FOLDER1_OWNER) THEN + WRITE (6,'('' ERROR: Cannot modify access'', + & '' for owner of folder.'')') + ELSE + IF (ACCESS) THEN + IF (READONLY) THEN + CALL ADD_ACL(ID,'R',IER) + ELSE + CALL ADD_ACL(ID,'R+W',IER) + END IF + ELSE + CALL DEL_ACL(ID,'R+W',IER) + IF (.NOT.IER) CALL DEL_ACL(ID,'R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access for '',A, + & ''.'')') ID(:ILEN) + CALL SYS_GETMSG(IER) + ELSE + WRITE(6,'('' Access modified for '',A,''.'')') + & ID(:ILEN) + END IF + END IF + IF (TRIM(INPUT).EQ.0.AND.FILE_OPEN) THEN + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + FILE_OPEN = .FALSE. + END IF + END IF + END DO + END DO + +100 IF (OLD_FOLDER1_FLAG.NE.FOLDER1_FLAG) THEN + CALL OPEN_BULLFOLDER ! Open folder file + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FLAG = OLD_FOLDER1_FLAG + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + END IF + + RETURN + + END + + + + SUBROUTINE CHKACL(FILENAME,IERACL) +C +C SUBROUTINE CHKACL +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C IERACL - Error returned for attempt to open file. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) FILENAME + + INCLUDE '($ACLDEF)' + INCLUDE '($SSDEF)' + + CHARACTER*255 ACLENT,ACLSTR + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IERACL=SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + IF (IERACL.EQ.SS$_ACLEMPTY) THEN + IERACL = SS$_NORMAL.OR.IERACL + END IF + + RETURN + END + + + + SUBROUTINE CHECK_ACCESS(FILENAME,USERNAME,READ_ACCESS,WRITE_ACCESS) +C +C SUBROUTINE CHECK_ACCESS +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C USERNAME - Name of user to check access for. +C READ_ACCESS - Error returned indicating read access. +C WRITE_ACCESS - Error returned indicating write access. +C If initially set to -1, indicates just +C folder for read access. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER FILENAME*(*),USERNAME*(*),ACE*255,OUTPUT*80 + + INCLUDE '($ACLDEF)' + INCLUDE '($CHPDEF)' + INCLUDE '($ARMDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,CHP$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(4,CHP$_ACCESS,%LOC(ACCESS)) + CALL ADD_2_ITMLST(LEN(ACE),CHP$_MATCHEDACE,%LOC(ACE)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + FLAGS = 0 ! Default is no access + + ACCESS = ARM$M_READ ! Check if user has read access + READ_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + IF (.NOT.SETPRV_PRIV().AND.ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'READ').EQ.0) READ_ACCESS = 0 + ELSE IF (ICHAR(ACE(:1)).EQ.0.AND.READ_ACCESS) THEN + READ_ACCESS = 0 + END IF + + IF (WRITE_ACCESS.EQ.-1) THEN ! Only check read access + RETURN + ELSE IF (READ_ACCESS.EQ.0) THEN ! If no read access, then of + WRITE_ACCESS = 0 ! course there is no write access. + RETURN + END IF + + ACCESS = ARM$M_WRITE ! Check if user has write access + WRITE_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + IF (.NOT.SETPRV_PRIV().AND.ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'WRITE').EQ.0) WRITE_ACCESS = 0 + END IF + + RETURN + END + + + + + SUBROUTINE SHOWACL(FILENAME) +C +C SUBROUTINE SHOWACL +C +C FUNCTION: Shows users who are allowed to read private bulletin. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER*(*) FILENAME + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + CALL LIB$GET_VM(ACLLENGTH+8,ACLSTR) + CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) + + CALL READACL(FILENAME,%VAL(ACLSTR),ACLLENGTH) + + RETURN + END + + + + SUBROUTINE FOLDER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLFOLDER.INC' + + ENTRY WRITE_FOLDER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + WRITE (7,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + ENTRY REWRITE_FOLDER_FILE + + REWRITE (7) FOLDER_COM + + RETURN + + ENTRY REWRITE_FOLDER_FILE_TEMP + + REWRITE (7) FOLDER1_COM + + RETURN + + ENTRY READ_FOLDER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_TEMP(IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM(KEY_NUMBER,IER) + + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER_COM + END DO + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM_GT(KEY_NUMBER,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEYGT=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM_TEMP(KEY_NUMBER,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME_TEMP(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER1_COM + END DO + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER_COM + END DO + + RETURN + + END + + + SUBROUTINE USER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 SAVE_USERNAME + + ENTRY READ_USER_FILE(IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) USER_ENTRY + END DO + + TEMP_USER = USERNAME + USERNAME = SAVE_USERNAME + + RETURN + + ENTRY READ_USER_FILE_KEYNAME(KEY_NAME,IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=KEY_NAME,IOSTAT=IER) USER_ENTRY + END DO + + USERNAME = SAVE_USERNAME + TEMP_USER = KEY_NAME + + RETURN + + ENTRY READ_USER_FILE_HEADER(IER) + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=' ',IOSTAT=IER) USER_HEADER + END DO + + RETURN + + ENTRY WRITE_USER_FILE_NEW(IER) + + DO I=1,FLONG + SET_FLAG(I) = SET_FLAG_DEF(I) + BRIEF_FLAG(I) = BRIEF_FLAG_DEF(I) + NOTIFY_FLAG(I) = NOTIFY_FLAG_DEF(I) + END DO + + ENTRY WRITE_USER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + WRITE (4,IOSTAT=IER) USER_ENTRY + END DO + + RETURN + + END + + + + + + SUBROUTINE SET_GENERIC(GENERIC) +C +C SUBROUTINE SET_GENERIC +C +C FUNCTION: Enables or disables "GENERIC" display, i.e. displaying +C general bulletins continually for a certain amount of days. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change GENERIC.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + IF (IER.EQ.0) THEN + IF (GENERIC) THEN + IF (CLI$PRESENT('DAYS')) THEN + IER = CLI$GET_VALUE('DAYS',BULL_PARAMETER) + CALL LIB$MOVC3(4,%REF(BULL_PARAMETER),NEW_FLAG(2)) + ELSE + NEW_FLAG(2) = ' 7' + END IF + ELSE + NEW_FLAG(2) = 0 + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET_BRIEF_CONTINUOUS(BRIEF_CONTINUOUS) +C +C SUBROUTINE SET_BRIEF_CONTINUOUS +C +C FUNCTION: Enables or disables "BRIEF_CONTINUOUS" display, i.e. displaying +C the brief message continually until the new messages have been read. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + + IF (BRIEF_CONTINUOUS) THEN + NEW_FLAG(2) = -1 + ELSE + NEW_FLAG(2) = 0 + END IF + + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET_LOGIN(LOGIN) +C +C SUBROUTINE SET_LOGIN +C +C FUNCTION: Enables or disables bulletin display at login. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER TODAY*23 + + DIMENSION NOLOGIN_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change LOGIN.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + IF (IER.EQ.0) THEN + IF (LOGIN.AND.COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + CALL SYS_BINTIM(TODAY,LOGIN_BTIM) + ELSE IF (.NOT.LOGIN) THEN + LOGIN_BTIM(1) = NOLOGIN_BTIM(1) + LOGIN_BTIM(2) = NOLOGIN_BTIM(2) + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE GET_UAF(USERNAME,USER,GROUP,ACCOUNT,FLAGS,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER USERNAME*(*),ACCOUNT*(*) + + INCLUDE '($UAIDEF)' + + INTEGER*2 UIC(2) + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(LEN(ACCOUNT),UAI$_ACCOUNT,%LOC(ACCOUNT)) + CALL ADD_2_ITMLST(4,UAI$_UIC,%LOC(UIC)) + CALL END_ITMLST(GETUAI_ITMLST) + + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) + + USER = UIC(1) + GROUP = UIC(2) + + RETURN + END + + + + SUBROUTINE DCLEXH(EXIT_ROUTINE) + + IMPLICIT INTEGER (A-Z) + + INTEGER*4 EXBLK(4) + + EXBLK(2) = EXIT_ROUTINE + EXBLK(3) = 1 + EXBLK(4) = %LOC(EXBLK(4)) + + CALL SYS$DCLEXH(EXBLK(1)) + + RETURN + END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin6.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin6.for new file mode 100644 index 0000000..739cc47 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin6.for @@ -0,0 +1,1603 @@ +C +C BULLETIN6.FOR, Version 10/26/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE CLOSE_FILE +C +C SUBROUTINE CLOSE_FILE +C +C FUNCTION: To close out the bulletin files and enable CTRL-C & -Y +C + DATA LUN /0/ + + ENTRY CLOSE_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY CLOSE_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY CLOSE_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY CLOSE_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY CLOSE_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN) + + LUN = 0 + + RETURN + END + + + SUBROUTINE CLOSE_FILE_DELETE + + IMPLICIT INTEGER (A-Z) + + DATA LUN /0/ + + ENTRY CLOSE_BULLDIR_DELETE + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL_DELETE + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN,STATUS='DELETE') + + LUN = 0 + + RETURN + END + + + SUBROUTINE OPEN_FILE(UNIT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($FORIOSDEF)' + + INCLUDE '($PRVDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + DATA LUN /0/ + + LUN = UNIT - 9 ! 9 gets added to LUN + + ENTRY OPEN_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL ! No breaks while file is open + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + WRITE (4,FMT=USER_FMT) USER_HEADER_KEY,NEWEST_BTIM, + & BBOARD_BTIM,PRV$M_OPER.OR.PRV$M_CMKRNL.OR. + & PRV$M_SETPRV,(0,I=1,FLONG*4-1) + CLOSE (UNIT=4) + IDUMMY = FILE_LOCK(IER,IER1) + ELSE IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + FOLDER1 = 'GENERAL' + FOLDER1_OWNER = 'SYSTEM' + FOLDER1_DESCRIP = 'Default general bulletin folder.' + FOLDER1_BBOARD = 'NONE' + FOLDER1_BBEXPIRE = 14 + NBULL = 0 + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER2, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + WRITE (7,FMT=FOLDER_FMT,IOSTAT=IER2) + & FOLDER1,0,FOLDER1_OWNER,FOLDER1_DESCRIP + & ,FOLDER1_BBOARD,FOLDER1_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,4,0,F_NEWEST_NOSYS_BTIM + ! 4 means system folder + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = 0 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (IER.NE.0) THEN + WRITE (6,'( + & '' Cannot open file in OPEN_FILE, unit = '',I)') LUN + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT ! Enable CTRL-Y & -C & EXIT + END IF + + LUN = 0 + + RETURN + END + + + + SUBROUTINE TIMER_ERR(UNIT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*14 NAMES(5) + DATA NAMES/'directory','message','BULLUSER.DAT','BULLFOLDER.DAT', + & 'BULLINF.DAT'/ + INTEGER NAME(9) + DATA NAME/1,2,0,3,0,0,4,0,5/ + + IF (TEST_BULLCP().NE.2) THEN ! If BULLCP process, don't log error + WRITE(6,'('' ERROR: Unable to open '',A, + & '' file after 30 secs.'')') + & NAMES(NAME(UNIT))(:TRIM(NAMES(NAME(UNIT)))) + WRITE (6,'('' Please try again later.'')') + END IF + + CALL ENABLE_CTRL_EXIT ! No breaks while file is open + END + + + + SUBROUTINE OPEN_FILE_SHARED + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + EXTERNAL LNM_MODE_EXEC,ENABLE_CTRL_EXIT +C +C The following 2 files were used prior to V1.1. +C + CHARACTER*80 BULLDIR_FILE /'BULL_DIR:BULLDIR.DAT'/ + CHARACTER*80 BULLETIN_FILE /'BULL_DIR:BULLETIN.DAT'/ + + CHARACTER*25 SAVE_FOLDER + DATA SAVE_BLOCK/-1/ + + DATA LUN /0/ + + ENTRY OPEN_BULLINF_SHARED + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF_SHARED + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER_SHARED + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER_SHARED + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR_SHARED + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL_SHARED + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED,READONLY, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.(FOLDER_NUMBER.EQ.0 + & .OR.FOLDER.EQ.'GENERAL')) THEN + IER2 = LIB$RENAME_FILE(BULLETIN_FILE,'GENERAL.BULLFIL') + IER2 = LIB$RENAME_FILE(BULLDIR_FILE,'GENERAL.BULLDIR') + IF (IER2) IDUMMY = FILE_LOCK(IER,IER1) ! Don't break out of loop + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND.REMOTE_SET.AND.(SAVE_BLOCK.NE.BLOCK.OR. + & SAVE_FOLDER.NE.FOLDER)) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,BULL_POINT + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + SAVE_BLOCK = BLOCK + SAVE_FOLDER = FOLDER + CALL GET_REMOTE_MESSAGE(IER) + IER = 0 + END IF + ELSE IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED',IOSTAT=IER,SHARED,READONLY) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + + IF (IER.EQ.0) THEN + INQUIRE(UNIT=7,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.FOLDER_RECORD/4) THEN + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_BULLFOLDER(ASK_SIZE) + NTRIES = 0 + END IF + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.8) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=8,FILE='SYSUAF',DEFAULTFILE='SYS$SYSTEM:SYSUAF.DAT', + & ACCESS='KEYED',FORM='UNFORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,IOSTAT=IER,SHARED, + & USEROPEN=LNM_MODE_EXEC) + END DO + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.LUN.NE.8) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + CALL OPEN_FILE(LUN) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + ELSE IF (IER.NE.0) THEN + WRITE (6,'( + & '' Cannot open file in OPEN_FILE_SHARE, unit = '',I)') LUN + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT + END IF + + LUN = 0 + + RETURN + END + + + + + + SUBROUTINE CONVERT_BULLDIRS + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER BUFFER*115 + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP', + & IOSTAT=IER) + + IF (IER.NE.0) GO TO 900 ! No BULLDIR file found. + + READ (2'1,IOSTAT=IER1) BUFFER + + CALL LIB$MOVC3(4,%REF(BUFFER(39:)),NBULL) + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+5 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END IF + + IF (IER1.NE.0) GO TO 800 + + CALL SYS_BINTIM(BUFFER(1:11)//' '//BUFFER(12:19),NEWEST_EXBTIM) + CALL SYS_BINTIM(BUFFER(20:30)//' '//BUFFER(31:38),NEWEST_MSGBTIM) + BULLDIR_HEADER(29:40) = BUFFER(39:) + CALL SYS_BINTIM(BUFFER(51:61)//' '//BUFFER(62:69),SHUTDOWN_BTIM) + BULLDIR_HEADER(49:52) = BUFFER(70:) + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) BULLDIR_HEADER + + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ (2'ICOUNT,IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + MSG_NUM = ICOUNT - 1 + DESCRIP = BUFFER(1:) + FROM = BUFFER(54:) + BULLDIR_ENTRY(78:81) = BUFFER(85:) + BULLDIR_ENTRY(90:97) = BUFFER(108:) + CALL SYS_BINTIM(BUFFER(89:99)//' '//BUFFER(100:107),EX_BTIM) + CALL SYS_BINTIM(BUFFER(66:76)//' '//BUFFER(77:84),MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (9,IOSTAT=IER) BULLDIR_ENTRY + ICOUNT = ICOUNT + 1 + END IF + END DO + +800 CLOSE (UNIT=9,DISPOSE='KEEP') + CLOSE (UNIT=2) + +900 CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFILES +C +C SUBROUTINE CONVERT_BULLFILES +C +C FUNCTION: Converts bulletin files to new format file. +C Add expiration time to directory file, add extra byte to bulletin +C file to show where each bulletin starts (for redunancy sake in +C case crash occurs). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*81 BUFFER + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=107,ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP',FORM='FORMATTED', + & SHARED,READONLY,IOSTAT=IER) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=10,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=80, + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=81, + & FORM='FORMATTED') + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + NEWEST_EXTIME = '00:00:00.00' + READ (9'1,1000,IOSTAT=IER) + & NEWEST_EXDATE,NEWEST_DATE,NEWEST_TIME(:8), + & NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_DATE,SHUTDOWN_TIME(:8) + NEMPTY = 0 + IF (IER.EQ.0) CALL WRITEDIR(0,IER1) + + EXTIME = '00:00:00.00' + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ(9'ICOUNT,1010,IOSTAT=IER) + & DESCRIP,FROM,DATE,TIME(:8),LENGTH,EXDATE,SYSTEM,BLOCK + IF (IER.EQ.0) THEN + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER(1:80)//CHAR(1) + DO I=2,LENGTH + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER + END DO + CALL WRITEDIR(ICOUNT-1,IER1) + ICOUNT = ICOUNT + 1 + END IF + END DO + + CLOSE (UNIT=9) + CLOSE (UNIT=2) + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + RETURN + +1000 FORMAT(A11,A11,A8,A4,A4,A4,A11,A8) +1010 FORMAT(A53,A12,A11,A8,A4,A11,A4,A4) + + END + + SUBROUTINE CONVERT_BULLFILE +C +C SUBROUTINE CONVERT_BULLFILE +C +C FUNCTION: Converts bulletin data file to new format file. +C +C NOTE: CONVERT_BULLFILES converts from 80 to 81 byte length. +C This converts from 81 byte length to 128 compressed format. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*80 BUFFER,NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL CLOSE_BULLDIR + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + CALL OPEN_BULLFOLDER + +100 READ (7,FMT=FOLDER_FMT,ERR=200) + & FOLDER,FOLDER_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + NEW_FILE = FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFILOLD' + OPEN (UNIT=10,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL' + & ,STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=81,ACCESS='DIRECT', + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.BULLFIL;-1',NEW_FILE) + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + IF (IER.EQ.1) THEN + NBLOCK = 0 + DO I=1,NBULL + CALL READDIR(I,IER) + NBLOCK = NBLOCK + 1 + SBLOCK = NBLOCK + DO J=BLOCK,LENGTH+BLOCK-1 + READ(10'J,'(A)') BUFFER + ILEN = TRIM(BUFFER) + IF (ILEN.EQ.0) ILEN = 1 + CALL STORE_BULL(ILEN,BUFFER,NBLOCK) + END DO + CALL FLUSH_BULL(NBLOCK) + LENGTH = NBLOCK - SBLOCK + 1 + BLOCK = SBLOCK + CALL WRITEDIR(I,IER) + END DO + + NEMPTY = 0 + CALL WRITEDIR(0,IER) + END IF + + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL CLOSE_BULLDIR + GOTO 100 + +200 CALL OPEN_BULLDIR_SHARED + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFOLDER(ASK_SIZE) +C +C SUBROUTINE CONVERT_BULLFOLDER +C +C FUNCTION: Converts bulletin folder file to new format. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + INCLUDE '($FORIOSDEF)' + + CHARACTER*80 NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + + EODIR = MAX(INDEX(BULLFOLDER_FILE,':'),INDEX(BULLFOLDER_FILE,']')) + SUFFIX = INDEX(BULLFOLDER_FILE(EODIR:),'.') + EODIR - 1 + NEW_FILE = BULLFOLDER_FILE(:SUFFIX)//'OLD' + + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + END DO + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=19,FILE=NEW_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER),DISPOSE='DELETE') + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + IF (ASK_SIZE.EQ.173/4) THEN + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8,5A4)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + IF (IER.EQ.0) THEN + WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + & ,F_NEWEST_BTIM + F_NUMBER = F_NUMBER + 1 + END IF + END DO + ELSE + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + IF (IER.EQ.0) THEN + FOLDER_FLAG = 0 + IF (F_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_BULLDIRS + END IF + END DO + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + F_NEWEST_BTIM(1) = 0 + F_NEWEST_BTIM(2) = 0 + ELSE + CALL READDIR(0,IER) + IF (NEWEST_DATE.EQ.'5-NOV-1956 ') THEN + IF (NBULL.GT.0) THEN + CALL READDIR(NBULL,IER) + NEWEST_DATE = DATE + NEWEST_TIME = TIME + CALL WRITEDIR(0,IER) + END IF + END IF + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + CLOSE (UNIT=2) + END IF + WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,FOLDER_FLAG,0,F_NEWEST_BTIM + F_NUMBER = F_NUMBER + 1 + END IF + END DO + END IF + + CLOSE (UNIT=7) + CLOSE (UNIT=19,STATUS='SAVE') + + IER = LIB$RENAME_FILE(NEW_FILE,BULLFOLDER_FILE) + IER = LIB$RENAME_FILE(BULLFOLDER_FILE//';-1',NEW_FILE) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:TRIM(BBOARD_DIRECTORY)) + & //'BOARD.COM;*') ! BULLETIN$ is referenced in old file + + RETURN + END + + SUBROUTINE CONVERT_USERFILE +C +C SUBROUTINE CONVERT_USERFILE +C +C FUNCTION: Converts user file to new format which has 8 bytes added. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER BUFFER*74,NEW_FILE*80 + + CHARACTER*11 LOGIN_DATE,READ_DATE + CHARACTER*8 LOGIN_TIME,READ_TIME + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + EODIR = MAX(INDEX(BULLUSER_FILE,':'),INDEX(BULLUSER_FILE,']')) + SUFFIX = INDEX(BULLUSER_FILE(EODIR:),'.') + EODIR - 1 + NEW_FILE = BULLUSER_FILE(:SUFFIX)//'OLD' + IER = LIB$RENAME_FILE(BULLUSER_FILE,NEW_FILE) + + OPEN (UNIT=9,FILE=NEW_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + INQUIRE (UNIT=9,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IER = LIB$RENAME_FILE(NEW_FILE,BULLUSER_FILE) + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + IF (IER.EQ.0) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot convert user file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + CALL SYS_GETMSG(IER1) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + CALL ENABLE_CTRL_EXIT + END IF + + DO I=1,FLONG + NEW_FLAG(I) = 'FFFFFFFF'X + NOTIFY_FLAG(I) = 0 + BRIEF_FLAG(I) = 0 + SET_FLAG(I) = 0 + END DO + + IF (RECL.EQ.42.OR.RECL.EQ.50.OR.RECL.EQ.58.OR.RECL.EQ.66.OR. + & RECL.EQ.74) THEN ! Old format + IF (RECL.LE.58) RECL = 50 + IER = 0 + DO WHILE (IER.EQ.0) + READ (9,'(A)',IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + TEMP_USER = BUFFER(1:12) + LOGIN_DATE = BUFFER(13:23) + LOGIN_TIME = BUFFER(24:31) + READ_DATE = BUFFER(32:42) + READ_TIME = BUFFER(43:50) + IF (RECL.EQ.58) + & CALL LIB$MOVC3(8,%REF(BUFFER(51:)),SET_FLAG(1)) + IF (RECL.EQ.66) + & CALL LIB$MOVC3(8,%REF(BUFFER(59:)),NEW_FLAG(1)) + IF (RECL.EQ.74) + & CALL LIB$MOVC3(8,%REF(BUFFER(67:)),NOTIFY_FLAG(1)) + CALL SYS_BINTIM(LOGIN_DATE//' '//LOGIN_TIME,LOGIN_BTIM) + CALL SYS_BINTIM(READ_DATE//' '//READ_TIME,READ_BTIM) + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + IF (RECL.LT.66) THEN + READ (4,KEY=USER_HEADER_KEY,FMT=USER_FMT) TEMP_USER, + & LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + NEW_FLAG(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + ELSE ! Folder maxmimum increase + OFLONG = (RECL - 28) / 16 ! Old #longwords/flag + DO WHILE (IER.EQ.0) + READ (9,FMT='(A12,<4+OFLONG*4>A4)',IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM, + & (NEW_FLAG(I),I=1,OFLONG),(SET_FLAG(I),I=1,OFLONG), + & (BRIEF_FLAG(I),I=1,OFLONG),(NOTIFY_FLAG(I),I=1,OFLONG) + IF (IER.EQ.0) THEN + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + END IF + + IER = 0 + + CLOSE (UNIT=9) + CLOSE (UNIT=4) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + END + + + SUBROUTINE READDIR(BULLETIN_NUM,ICOUNT) +C +C SUBROUTINE READDIR +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file and returns the information for that entry. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, gives header info, i.e number of bulls, +C number of blocks in bulletin file, etc. +C OUTPUTS: +C ICOUNT - The last record read by this routine. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + CHARACTER*3 CFOLDER_NUMBER + + ICOUNT = BULLETIN_NUM + + IF (ICOUNT.EQ.0) THEN + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=0,IOSTAT=IER) BULLDIR_HEADER + END DO + IF (IER.EQ.0) THEN + CALL CONVERT_HEADER_FROMBIN + DIR_NUM = 0 + END IF + ELSE + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 8,0 + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_HEADER + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + CALL CONVERT_HEADER_FROMBIN + RETURN + END IF + END IF + IF (IER.EQ.0) THEN + IF (NBULL.LT.0) THEN ! This indicates bulletin deletion + ! was incomplete. + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR + CALL CLEANUP_DIRFILE(1) + CALL UPDATE_FOLDER + END IF + IF (NEMPTY.EQ.' ') NEMPTY = 0 +C +C Check to see if cleanup of empty file space is necessary, which is +C defined here as being 50 blocks (200 128byte records). Also check +C to see if cleanup was in progress but didn't properly finish. +C + IF (NEMPTY.GT.200.AND.TEST_BULLCP().EQ.0) THEN + WRITE (CFOLDER_NUMBER,'(I3)') FOLDER_NUMBER + IER1 = LIB$SPAWN('$'//COMMAND_PROMPT(1:INDEX( + & COMMAND_PROMPT,'>')-1)//'/CLEANUP='//CFOLDER_NUMBER, + & 'NL:','NL:',1,'BULL_CLEANUP') + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLEANUP_BULLFILE + END IF + END IF + ELSE + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + IF (DIR_NUM.EQ.ICOUNT-1) THEN + READ(2,IOSTAT=IER) BULLDIR_ENTRY + IF (MSG_NUM.NE.ICOUNT) IER = 36 + ELSE + READ(2,KEYID=0,KEY=ICOUNT,IOSTAT=IER) BULLDIR_ENTRY + END IF + END DO + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + DIR_NUM = -1 + END IF + ELSE + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 8,ICOUNT + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_ENTRY + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + CALL CONVERT_ENTRY_FROMBIN + RETURN + END IF + END IF + END IF + + IF (IER.EQ.0) ICOUNT = ICOUNT + 1 + + UNLOCK 2 + + RETURN + + END + + + + + + SUBROUTINE READDIR_KEYGE(IER) +C +C SUBROUTINE READDIR_KEYGE +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file corresponding to or later than the date specified. +C +C INPUTS: +C MSG_KEY - Message key (passed via BULLDIR.INC common block). +C OUTPUTS: +C IER - If not 0, no entry found. Else contains message number. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ(2,KEYID=1,KEYGT=MSG_KEY,IOSTAT=IER) BULLDIR_ENTRY + END DO + IF (IER.EQ.0) THEN + IER = MSG_NUM + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + IER = 0 + DIR_NUM = -1 + END IF + UNLOCK 2 + ELSE + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 8,-1,MSG_KEY + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER1) IER,BULLDIR_ENTRY + END IF + IF (IER1.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE IF (IER.NE.0) THEN + CALL CONVERT_ENTRY_FROMBIN + END IF + END IF + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,NEWEST_EXBTIM,) + + NEWEST_EXDATE = DATETIME + NEWEST_EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,NEWEST_MSGBTIM,) + + NEWEST_DATE = DATETIME + NEWEST_TIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,SHUTDOWN_BTIM,) + + SHUTDOWN_DATE = DATETIME + SHUTDOWN_TIME = DATETIME(13:) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,EX_BTIM,) + + EXDATE = DATETIME + EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,MSG_BTIM,) + + DATE = DATETIME + TIME = DATETIME(13:) + + RETURN + END + + + + + + SUBROUTINE WRITEDIR(BULLETIN_NUM,IER) +C +C SUBROUTINE WRITEDIR +C +C FUNCTION: Writes the entry for the specified bulletin in the +C directory file. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, write the header of the directory file. +C OUTPUTS: +C IER - Error status from WRITE. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + INCLUDE 'BULLDIR.INC' + + CONV = .TRUE. + + GO TO 10 + + ENTRY WRITEDIR_NOCONV(BULLETIN_NUM,IER) + + CONV = .FALSE. + +10 IF (BULLETIN_NUM.EQ.0) THEN + IF (CONV) CALL CONVERT_HEADER_TOBIN + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,0,BULLDIR_HEADER + ELSE + IER = -1 + IF (DIR_NUM.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=0,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + IF (IER.NE.0) THEN + WRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + ELSE + IF (CONV) CALL CONVERT_ENTRY_TOBIN + MSG_NUM = BULLETIN_NUM + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,BULLETIN_NUM,BULLDIR_ENTRY + ELSE + IER = -1 + IF (DIR_NUM.EQ.MSG_NUM) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=BULLETIN_NUM,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + ELSE + WRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + END IF + END IF + END IF + + IF (REMOTE_SET.AND.IER.GT.0) CALL ERROR_AND_EXIT + + DIR_NUM = -1 + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(NEWEST_EXDATE//' '//NEWEST_EXTIME,NEWEST_EXBTIM) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_MSGBTIM) + + CALL SYS_BINTIM(SHUTDOWN_DATE//' '//SHUTDOWN_TIME,SHUTDOWN_BTIM) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(EXDATE//' '//EXTIME,EX_BTIM) + + CALL SYS_BINTIM(DATE//' '//TIME,MSG_BTIM) + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + + RETURN + END + + + + + SUBROUTINE READACL(FILENAME,ACLENT,ACLLENGTH) +C +C SUBROUTINE READACL +C +C FUNCTION: Reads the ACL of a file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C ACLENT - String which will be large enough to hold ACL information. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*(*),OUTPUT*80,ACLSTR*255,FILENAME*(*) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + BIG = .NOT.IER + IF (BIG) THEN + IER = SYS$PARSE_ACL('(ID=*,ACCESS=NONE)',ACLENT,,) + ACLLENGTH = ACL$S_ADDACLENT + CTXT = 0 + END IF + + DO ACC_TYPE=1,2 + POINT = 1 + OUTLEN = 0 + DO WHILE ((POINT.LT.ACLLENGTH).AND.IER) + IF (.NOT.BIG) THEN + IER = SYS$FORMAT_ACL(ACLENT(POINT:POINT-1+ + & ICHAR(ACLENT(POINT:POINT))),ACLLEN,ACLSTR,,,,) + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_FNDACETYP,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST) + & ,,,CTXT,,) + IER = SYS$FORMAT_ACL(ACLENT(:ICHAR(ACLENT(1:1))), + & ACLLEN,ACLSTR,,,,) + CALL LIB$MOVC3(4,%REF(ACLENT(5:)),ACCESS) + IF (ACCESS.EQ.0) IER = .FALSE. + END IF + AC = INDEX(ACLSTR,',ACCESS') + IF ((ACC_TYPE.EQ.1.AND.INDEX(ACLSTR(AC:),'WRITE').GT.0).OR. + & (ACC_TYPE.EQ.2.AND.INDEX(ACLSTR(AC:),'READ').GT.0.AND. + & INDEX(ACLSTR(AC:),'WRITE').EQ.0)) THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,',ACCESS') - 1 + IF (ACLSTR(END_ID:END_ID).EQ.']') THEN + START_ID = END_ID - 1 + ASCII = .FALSE. + DO WHILE (ACLSTR(START_ID:START_ID).NE.'['.AND. + & ACLSTR(START_ID:START_ID).NE.'='.AND. + & (ACLSTR(START_ID:START_ID).NE.','.OR..NOT.ASCII)) + IF (ACLSTR(START_ID:START_ID).NE.','.AND. + & (ACLSTR(START_ID:START_ID).LT.'0'.OR. + & ACLSTR(START_ID:START_ID).GT.'9')) ASCII = .TRUE. + IF (ACLSTR(START_ID:START_ID).NE.','.OR..NOT.ASCII) THEN + START_ID = START_ID - 1 + END IF + END DO + IF (ASCII) THEN + START_ID = START_ID + 1 + END_ID = END_ID - 1 + IF (ACLSTR(START_ID:START_ID).EQ.'*') THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,'ACCESS') - 2 + END IF + END IF + END IF + IF (OUTLEN.EQ.0) THEN + IF (FILENAME.NE.BULLUSER_FILE) THEN + IF (ACC_TYPE.EQ.1) THEN + WRITE (6,'( + & '' These users can read and write to this folder:'')') + ELSE + WRITE (6,'( + & '' These users can only read this folder:'')') + END IF + ELSE + WRITE (6,'('' The following are rights identifiers'', + & '' which will give privileges.'')') + END IF + OUTLEN = 1 + END IF + IDLEN = END_ID - START_ID + 1 + IF (OUTLEN+IDLEN-1.GT.80) THEN + WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-1) + OUTPUT = ACLSTR(START_ID:END_ID)//',' + OUTLEN = IDLEN + 2 + ELSE IF (OUTLEN+IDLEN-1.EQ.80) THEN + WRITE (6,'(1X,A)') + & OUTPUT(:OUTLEN-1)//ACLSTR(START_ID:END_ID) + OUTLEN = 1 + ELSE + OUTPUT(OUTLEN:) = ACLSTR(START_ID:END_ID)//',' + OUTLEN = OUTLEN + IDLEN + 1 + END IF + END IF + POINT = POINT + ICHAR(ACLENT(POINT:POINT)) + END DO + IF (OUTLEN.GT.1) WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-2) + END DO + + RETURN + END + + + + + SUBROUTINE CONVERT_INFFILE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + OPEN (UNIT=10,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + INQUIRE (UNIT=10,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + RECL = RECL/8 + + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + DO WHILE (IER.EQ.0) + READ (10,IOSTAT=IER) TEMP_USER,((LAST_READ_BTIM(J,I),J=1,2),I=1,RECL) + IF (IER.EQ.0) WRITE (9) TEMP_USER, + & ((LAST_READ_BTIM(J,I),J=1,2),I=1,FOLDER_MAX) + END DO + + CLOSE (UNIT=10,STATUS='DELETE') + + CLOSE (UNIT=9) + + RETURN + END + + + SUBROUTINE ERROR_AND_EXIT + + IMPLICIT INTEGER (A-Z) + + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + CALL ENABLE_CTRL_EXIT + + RETURN + END + + + + + SUBROUTINE COPY_ACL(INFILE,OUTFILE) +C +C SUBROUTINE COPY_ACL +C +C FUNCTION: +C Copy ACLs from one file to another file +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER*(*) INFILE,OUTFILE + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) + ! Get length needed to store acl output + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,,,) + + CALL LIB$GET_VM(ACLLENGTH+8,ACLSTR) ! Create character string to + CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) ! store acl + + CALL COPY_ACL1(INFILE,OUTFILE,%VAL(ACLSTR),ACLLENGTH) + ! Pass location of string + CALL LIB$FREE_VM(ACLLENGTH+8,ACLSTR) + + RETURN + END + + + SUBROUTINE COPY_ACL1(INFILE,OUTFILE,ACLENT,ACLLENGTH) +C +C SUBROUTINE COPY_ACL1 +C +C FUNCTION: Called by COPY_ACL to actually do the copy. Need 2 routines +C since must convert location of string into a character string. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*(*),INFILE*(*),OUTFILE*(*) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,,,) + ! Read input file acl + + IF (.NOT.IER) THEN + IER = SYS$PARSE_ACL('(ID=*,ACCESS=NONE)',ACLENT,,) + IF (.NOT.IER) RETURN + ACLLENGTH = ACL$S_ADDACLENT + CTXT = 0 + DO WHILE (IER) + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(1:1)),ACL$C_ADDACLENT, + & %LOC(ACLENT)) + CALL END_ITMLST(ACL1_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL + & (,ACL$C_FILE,OUTFILE,%VAL(ACL1_ITMLST),,,) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_FNDACETYP,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST) + & ,,,CTXT,,) + CALL LIB$MOVC3(4,%REF(ACLENT(5:)),ACCESS) + IF (ACCESS.EQ.0) RETURN ! ID=*, ACCESS=NONE, which has + ! (and must) be applied first + END DO + RETURN + END IF + + CALL INIT_ITMLST ! Initialize item list + + POINT = 1 + DO WHILE (POINT.LT.ACLLENGTH) ! Transfer all acls to output file + CALL ADD_2_ITMLST(ICHAR(ACLENT(POINT:POINT)),ACL$C_ADDACLENT, + & %LOC(ACLENT(POINT:))) + POINT = POINT + ICHAR(ACLENT(POINT:POINT)) + END DO + + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,OUTFILE,%VAL(ACL_ITMLST),,,) + + RETURN + END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin7.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin7.for new file mode 100644 index 0000000..becab25 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin7.for @@ -0,0 +1,1929 @@ +C +C BULLETIN7.FOR, Version 10/23/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE UPDATE_LOGIN(ADD_BULL) +C +C SUBROUTINE UPDATE_LOGIN +C +C FUNCTION: Updates the login file when a bulletin has been deleted +C or added. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($SSDEF)' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + DIMENSION READ_BTIM_SAVE(2),TEMP_BTIM(2) + +C +C We want to keep the last read date for comparison when selecting new +C folders, so save it for later restoring. +C + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL OPEN_BULLUSER_SHARED + +C +C Newest date/time in user file only applies to general bulletins. +C This was present before adding folder capability. +C We set flags in user entry to show new folder added for folder bulletins. +C However, the newest bulletin for each folder is not continually updated, +C As it is only used when comparing to the last bulletin read time, and to +C store this for each folder would be too expensive. +C + + TEMP_BTIM(1) = NEWEST_BTIM(1) + TEMP_BTIM(2) = NEWEST_BTIM(2) + CALL READ_USER_FILE_HEADER(IER) + NEWEST_BTIM(1) = TEMP_BTIM(1) + NEWEST_BTIM(2) = TEMP_BTIM(2) + + IF (IER.NE.0) THEN + CALL CLOSE_BULLUSER + RETURN + ELSE IF (FOLDER_NUMBER.EQ.0) THEN + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_BTIM) + REWRITE (4,IOSTAT=IER) USER_HEADER + END IF + + BROAD_MSG = .FALSE. + IF (ADD_BULL.AND.FOLDER_NUMBER.GE.0) THEN ! Message added? + IF (INCMD(1:3).NE.'ADD') THEN + BROAD_MSG = .TRUE. + ELSE IF (.NOT.CLI$PRESENT('BROADCAST')) THEN + BROAD_MSG = .TRUE. + END IF + END IF + + IF (BROAD_MSG) THEN + IF (FOLDER_BBOARD(:2).NE.'::'.AND. + & FOLDER_NUMBER.GT.0) THEN ! Folder private? + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CHECK_ACL = 0 + ELSE + CHECK_ACL = 1 + END IF + ELSE + CHECK_ACL = 0 + END IF + + CALL NOTIFY_USERS(CHECK_ACL) + END IF + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + ! Reobtain present values as calling programs still uses them + + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + + CALL CLOSE_BULLUSER + + RETURN + + END + + + + + SUBROUTINE NOTIFY_USERS(CHECK_ACL) +C +C SUBROUTINE NOTIFY_USERS +C +C FUNCTION: Notify users with SET NOTIFY set of new message. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($BRKDEF)' + + CHARACTER OUTPUT*160,TERMINAL*7,FLAGS*1 + CHARACTER*1 CR/13/,LF/10/,BELL/7/ + CHARACTER*12 SENT_TEMP_USER + + OUTPUT = BELL//CR//LF//LF// + & 'New bulletin added to folder '//FOLDER(1:TRIM(FOLDER)) + & //'. From: '//FROM(1:TRIM(FROM))//CR//LF// + & 'Description: '//DESCRIP(1:TRIM(DESCRIP)) + + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',FLAGS) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',FLAGS) + END IF + + BFLAG = 0 + READ (FLAGS(:1),'(I1)',IOSTAT=IER) FLAG + IF (BTEST(FLAG,1).AND.IER.EQ.0) BFLAG = BRK$M_CLUSTER + + CALL SYS$SETRWM(%VAL(1)) ! Don't wait if can't broadcast + + CALL INIT_QUEUE(TEMP_USER_QUEUE,TEMP_USER) + WRITE_TEMP_USER = TEMP_USER_QUEUE + + DO WHILE (GETUSERS(TEMP_USER,TERMINAL)) + READ_TEMP_USER = TEMP_USER_QUEUE + SENT_TEMP_USER = ' ' + DO WHILE (TEMP_USER.NE.SENT_TEMP_USER.AND. + & READ_TEMP_USER.NE.WRITE_TEMP_USER) + CALL READ_QUEUE(%VAL(READ_TEMP_USER),READ_TEMP_USER, + & SENT_TEMP_USER) + END DO + IF (TEMP_USER.NE.SENT_TEMP_USER) THEN + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + CALL WRITE_QUEUE(%VAL(WRITE_TEMP_USER),WRITE_TEMP_USER, + & TEMP_USER) + ELSE + IER = 2 + END IF + IF (IER.EQ.0.AND.TEMP_USER.NE.FROM.AND. + & TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + IF (CHECK_ACL) THEN + CALL CHECK_ACCESS + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL', + & TEMP_USER,IER,WRITE_ACCESS) + ELSE + IER = 1 + END IF + IF (IER) THEN + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & TEMP_USER(:TRIM(TEMP_USER)),%VAL(BRK$C_USERNAME) + & ,,,%VAL(BFLAG),,,,) + ELSE + CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + REWRITE (4,IOSTAT=IER) TEMP_USER//USER_ENTRY(13:) + END IF + END IF + END DO + CALL SYS$SETRWM(%VAL(0)) + + RETURN + END + + + + + + SUBROUTINE ADD_ENTRY +C +C SUBROUTINE ADD_ENTRY +C +C FUNCTION: Enters a new directory entry in the directory file. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY_TIME*32 + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + IF (REMOTE_SET) THEN + LOCAL = .TRUE. + IF (INCMD(:3).EQ.'ADD') LOCAL = CLI$PRESENT('LOCAL') + IF (LOCAL) THEN + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,0,0,0,0 + ELSE + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,CLI$PRESENT('BROADCAST'), + & CLI$PRESENT('BELL'),CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER') + END IF + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,TODAY_TIME,F1_NEWEST_BTIM,) + NEWEST_DATE = TODAY_TIME(1:11) + NEWEST_TIME = TODAY_TIME(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + CALL UPDATE_LOGIN(.TRUE.) + RETURN + END IF + + CALL SYS$ASCTIM(,TODAY_TIME,,) + DATE = TODAY_TIME(1:11) + TIME = TODAY_TIME(13:) + + CALL READDIR(0,IER) + + IF (IER.NE.1) THEN + NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = '00:00:00.00' + NBULL = 0 + NBLOCK = 0 + SHUTDOWN = 0 + NEMPTY = 0 + END IF + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + NBULL = NBULL + 1 + BLOCK = NBLOCK + 1 + NBLOCK = NBLOCK + LENGTH + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + CALL UPDATE_LOGIN(.TRUE.) + + CALL WRITEDIR(NBULL,IER) + + CALL WRITEDIR(0,IER) + + RETURN + END + + + + + INTEGER FUNCTION COMPARE_BTIM(BTIM1,BTIM2) +C +C FUNCTION COMPARE_BTIM +C +C FUCTION: Compares times in binary format to see which is farther in future. +C +C INPUTS: +C BTIM1 - First time in binary format +C BTIM2 - Second time in binary format +C OUTPUT: +C Returns +1 if first time is farther in future +C Returns -1 if second time is farther in future +C Returns 0 if equal time +C + IMPLICIT INTEGER (A - Z) + + DIMENSION BTIM1(2),BTIM2(2),DIFF(2) + + CALL LIB$SUBX(BTIM1,BTIM2,DIFF) + + IF (DIFF(2).LT.0) THEN + COMPARE_BTIM = -1 + ELSE IF (DIFF(2).GE.0) THEN + COMPARE_BTIM = +1 + END IF + + RETURN + END + + + + + + INTEGER FUNCTION MINUTE_DIFF(DATE2,DATE1) +C +C FUNCTION MINUTE_DIFF +C +C FUNCTION: Finds difference in minutes between 2 binary times. +C +C + IMPLICIT INTEGER (A-Z) + + DIMENSION DATE1(2),DATE2(2) + + CALL LIB$DAY(DAYS1,DATE1,MSECS1) + CALL LIB$DAY(DAYS2,DATE2,MSECS2) + + MINUTE_DIFF = (DAYS2-DAYS1)*24*60 + (MSECS2-MSECS1)/6000 + + RETURN + END + + + + + + + INTEGER FUNCTION COMPARE_DATE(DATE1,DATE2) +C +C FUNCTION COMPARE_DATE +C +C FUCTION: Compares dates to see which is farther in future. +C +C INPUTS: +C DATE1 - First date (dd-mm-yy) +C DATE2 - Second date (If is equal to ' ', then use present date) +C OUTPUT: +C Returns the difference in days between the two dates. +C If the DATE1 is farther in the future, the output is positive, +C else it is negative. +C + IMPLICIT INTEGER (A - Z) + + CHARACTER*(*) DATE1,DATE2 + INTEGER USER_TIME(2) + + CALL SYS_BINTIM(DATE1,USER_TIME) + + CALL VERIFY_DATE(USER_TIME) +C +C LIB$DAY crashes if date invalid, which happened once due to an unknown +C hardware or software error which created a date very far in the future. +C + CALL LIB$DAY(DAY1,USER_TIME) + + IF (DATE2.NE.' ') THEN + CALL SYS_BINTIM(DATE2,USER_TIME) + CALL VERIFY_DATE(USER_TIME) + ELSE + CALL SYS$GETTIM(USER_TIME) + END IF + + CALL LIB$DAY(DAY2,USER_TIME) + + COMPARE_DATE = DAY1 - DAY2 + + RETURN + END + + + + SUBROUTINE VERIFY_DATE(BTIM) + + IMPLICIT INTEGER (A-Z) + + DIMENSION BTIM(2),TEMP(2) + + CALL SYS_BINTIM(' 5-NOV-2011 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.GT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + CALL SYS_BINTIM(' 5-NOV-1955 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.LT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + RETURN + END + + + + INTEGER FUNCTION COMPARE_TIME(TIME1,TIME2) +C +C FUNCTION COMPARE_TIME +C +C FUCTION: Compares times to see which is farther in future. +C +C INPUTS: +C TIME1 - First time (hh:mm:ss.xx) +C TIME2 - Second time +C OUTPUT: +C Outputs (TIME1-TIME2) in seconds. Thus, if TIME1 is further +C in the future, outputs positive number, else negative. +C + + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) TIME1,TIME2 + CHARACTER*23 TODAY_TIME + CHARACTER*11 TEMP2 + + IF (TIME2.EQ.' ') THEN + CALL SYS$ASCTIM(,TODAY_TIME,,) + TEMP2 = TODAY_TIME(13:) + ELSE + TEMP2 = TIME2 + END IF + + COMPARE_TIME = 3600*10*(ICHAR(TIME1(1:1))-ICHAR(TEMP2(1:1))) + & +3600*(ICHAR(TIME1(2:2))-ICHAR(TEMP2(2:2))) + & +60*10*(ICHAR(TIME1(4:4))-ICHAR(TEMP2(4:4))) + & +60*(ICHAR(TIME1(5:5))-ICHAR(TEMP2(5:5))) + & +10*(ICHAR(TIME1(7:7))-ICHAR(TEMP2(7:7))) + & +(ICHAR(TIME1(8:8))-ICHAR(TEMP2(8:8))) + + IF (COMPARE_TIME.EQ.0) THEN + COMPARE_TIME = 10*(ICHAR(TIME1(10:10))-ICHAR(TEMP2(10:10))) + & +(ICHAR(TIME1(11:11))-ICHAR(TEMP2(11:11))) + IF (COMPARE_TIME.GT.0) THEN + COMPARE_TIME = 1 + ELSE IF (COMPARE_TIME.LT.0) THEN + COMPARE_TIME = -1 + END IF + END IF + + RETURN + END + +C------------------------------------------------------------------------- +C +C The following are subroutines to create a linked-list queue for +C temporary buffer storage of data that is read from files to be +C outputted to the terminal. This is done so as to be able to close +C the file as soon as possible. +C +C Each record in the queue has the following format. The first two +C words are used for creating a character variable. The first word +C contains the length of the character variable, the second contains +C the address. The address is simply the address of the 3rd word of +C the record. The last word in the record contains the address of the +C next record. Every time a record is written, if that record has a +C zero link, it adds a new record for the next write operation. +C Therefore, there will always be an extra record in the queue. To +C check for the end of the queue, the last word (link to next record) +C is checked to see if it is zero. +C +C------------------------------------------------------------------------- + SUBROUTINE INIT_QUEUE(HEADER,DATA) + CHARACTER*(*) DATA + INTEGER HEADER + IF (HEADER.NE.0) RETURN ! Queue already initialized + LENGTH = LEN(DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + CALL LIB$GET_VM(LENGTH+12,HEADER) + CALL MAKE_CHAR(%VAL(HEADER),LEN(DATA),LENGTH) + RETURN + END + + + SUBROUTINE WRITE_QUEUE(RECORD,NEXT,DATA) + INTEGER RECORD(1) + CHARACTER*(*) DATA + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,DATA,%VAL(%LOC(RECORD))) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + IF (NEXT.NE.0) RETURN + CALL LIB$GET_VM(LENGTH+12,NEXT) + CALL MAKE_CHAR(%VAL(NEXT),RECORD(1),LENGTH) + RECORD((LENGTH+12)/4) = NEXT + RETURN + END + + SUBROUTINE READ_QUEUE(RECORD,NEXT,DATA) + CHARACTER*(*) DATA + INTEGER RECORD(1) + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,%VAL(%LOC(RECORD)),DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + RETURN + END + + SUBROUTINE COPY_CHAR(LENGTH,INCHAR,OUTCHAR) + CHARACTER*(*) INCHAR,OUTCHAR + OUTCHAR = INCHAR(:LENGTH) + RETURN + END + + SUBROUTINE MAKE_CHAR(IARRAY,CHAR_LEN,REAL_LEN) + IMPLICIT INTEGER (A-Z) + DIMENSION IARRAY(1) + IARRAY(1) = CHAR_LEN + IARRAY(2) = %LOC(IARRAY(3)) + IARRAY(REAL_LEN/4+3) = 0 + RETURN + END + + + + SUBROUTINE DISABLE_PRIVS +C +C SUBROUTINE DISABLE_PRIVS +C +C FUNCTION: Disable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + DATA PRV_DEPTH /0/ + + COMMON /REALPROC/ REALPROCPRIV(2) + + PRV_DEPTH = PRV_DEPTH + 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(0),,,SETPRV) ! Get privileges + + SETPRV(1) = SETPRV(1).AND..NOT.REALPROCPRIV(1) + + CALL SYS$SETPRV(%VAL(0),SETPRV,,) ! Disable installed privs + + RETURN + END + + + + SUBROUTINE ENABLE_PRIVS +C +C SUBROUTINE ENABLE_PRIVS +C +C FUNCTION: Enable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + PRV_DEPTH = PRV_DEPTH - 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(1),SETPRV,,) ! Enable image privs + + RETURN + END + + + + SUBROUTINE CHECK_PRIV_IO(ERROR) +C +C SUBROUTINE CHECK_PRIV_IO +C +C FUNCTION: Checks SYS$OUTPUT and SYS$ERROR to see if they need +C privileges to output to. +C + + IMPLICIT INTEGER (A-Z) + + CALL DISABLE_PRIVS ! Disable SYSPRV + + OPEN (UNIT=6,FILE='SYS$OUTPUT',IOSTAT=IER,STATUS='NEW') + CLOSE (UNIT=6,STATUS='DELETE') + + OPEN (UNIT=4,FILE='SYS$ERROR',IOSTAT=IER1,STATUS='NEW') + IF (IER.NE.0.OR.IER1.NE.0) THEN + IF (IER1.EQ.0) WRITE (4,100) + IF (IER.EQ.0) WRITE (6,200) + ERROR = 1 + ELSE + CLOSE (UNIT=4,STATUS='DELETE') + ERROR = 0 + END IF + + CALL ENABLE_PRIVS ! Enable SYSPRV + +100 FORMAT(1X,'ERROR: SYS$OUTPUT cannot be opened.') +200 FORMAT(1X,'ERROR: SYS$ERROR cannot be opened.') + + RETURN + END + + + SUBROUTINE CHANGE_FLAG(CMD,FLAG) +C +C SUBROUTINE CHANGE_FLAG +C +C FUNCTION: Sets flags for specified folder. +C +C INPUTS: +C CMD - LOGICAL*4 value. If TRUE, set flag. +C If FALSE, clear flag. +C FLAG - If 1, modify NEW_FLAG, if 2, modify SET_FLAG +C If 3, modify BRIEF_FLAG, 4, modify NOTIFY_FLAG +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG) + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + + DATA CHANGE_FOLDER /.FALSE./ + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) + IF (IER) THEN + FOLDER_NUMBER_SAVE = FOLDER_NUMBER + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + CALL CLOSE_BULLFOLDER + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder found.'')') + RETURN + END IF + END IF + FOLDER_NUMBER = FOLDER1_NUMBER + CHANGE_FOLDER = .TRUE. + END IF + +C +C Find user entry in BULLUSER.DAT to update information. +C + + ENTRY CHANGE_FLAG_NOCMD(CMD,FLAG) + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.GT.0) THEN ! No entry (how did this happen??) + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's today + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) ! Fake new entry + CALL READ_USER_FILE_HEADER(IER) + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + ELSE + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + IF (CMD.AND.FLAG.EQ.4.AND.FOLDER_BBOARD(:2).EQ.'::') THEN + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*NOTIFY',IOSTAT=IER) TEMP_USER,NOTIFY_REMOTE + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + NOTIFY_REMOTE(I) = 0 + END DO + CALL SET2(NOTIFY_REMOTE,FOLDER_NUMBER) + WRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + ELSE + CALL SET2(NOTIFY_REMOTE,FOLDER_NUMBER) + REWRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + END IF + END IF + + CALL CLOSE_BULLUSER + + IF (CHANGE_FOLDER) THEN + FOLDER_NUMBER = FOLDER_NUMBER_SAVE + CHANGE_FOLDER = .FALSE. + END IF + + RETURN + + END + + + + + SUBROUTINE SET_VERSION +C +C SUBROUTINE SET_VERSION +C +C FUNCTION: Sets version number. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + +C +C Find user entry in BULLUSER.DAT to update information. +C + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.EQ.0) THEN + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY ! Write modified entry + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + CALL CLOSE_FILE (4) + RETURN + + END + + + + + + SUBROUTINE CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) +C +C SUBROUTINE CHECK_NEWUSER +C +C FUNCTION: Checks flags for a new: Whether DISMAIL is set, +C and what the last password change was. +C +C INPUTS: +C USERNAME - Username +C OUTPUTS: +C DISMAIL - Returns 1 if account has DISMAIL. +C returns 0 if account has no DISMAIL. +C PASSCHANGE - Date of last password change. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + INTEGER PASSCHANGE(2) + + INCLUDE '($UAIDEF)' + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(8,UAI$_PWD_DATE,%LOC(PASSCHANGE)) + CALL END_ITMLST(GETUAI_ITMLST) + + DISMAIL = 0 ! Set return false + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) ! Read Record + IF (IER) THEN ! If username found + IF (BTEST(FLAGS,UAI$V_NOMAIL)) THEN ! DISMAIL SET? + DISMAIL = 1 ! Yep + END IF + END IF + + RETURN ! Return + END ! End + + + + INTEGER FUNCTION SYS_TRNLNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM = SYS$TRNLNM(,'LNM$FILE_DEV',INPUT(:TRIM(INPUT)),, + & %VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM) OUTPUT = OUTPUT(:OLEN) + + RETURN + END + + + + + INTEGER FUNCTION SYS_TRNLNM_SYSTEM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM_SYSTEM = SYS$TRNLNM(,'LNM$SYSTEM', + & INPUT(:TRIM(INPUT)),,%VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM_SYSTEM) OUTPUT = OUTPUT(:OLEN) + + RETURN + END + + + + INTEGER FUNCTION FILE_LOCK(IER,IER1) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($RMSDEF)' + + DATA INIT /.TRUE./ + + IF (INIT) THEN + FILE_LOCK = 1 + INIT = .FALSE. + ELSE + IF (IER.GT.0) THEN + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.RMS$_FLK) THEN + FILE_LOCK = 1 + CALL WAIT_SEC('01') + ELSE + FILE_LOCK = 0 + INIT = .TRUE. + END IF + ELSE + FILE_LOCK = 0 + IER1 = 0 + INIT = .TRUE. + END IF + END IF + + RETURN + END + + + + SUBROUTINE ENABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + COMMON /KEYPAD/ KEYPAD_MODE + + QUIT = 1 + + ENTRY ENABLE_CTRL_EXIT + + QUIT = QUIT.AND.1 ! If called via entry, QUIT = 0 + IF (QUIT.EQ.1) LEVEL = LEVEL - 1 + + IF (LEVEL.LT.0.AND.QUIT.EQ.1) THEN + WRITE (6,'('' ERROR: Error in CTRL.'')') + END IF + + IF (LEVEL.EQ.0.OR.QUIT.EQ.0) THEN + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + END IF + + IF (QUIT.EQ.0) THEN + IF (KEYPAD_MODE.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,) + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1) + END IF + CALL UPDATE_USERINFO + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL EXIT + END IF + QUIT = 0 ! Reinitialize + + RETURN + END + + + SUBROUTINE DISABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + DATA LEVEL /0/ + + IF (LEVEL.EQ.0) CALL LIB$DISABLE_CTRL(CTRLY,) + LEVEL = LEVEL + 1 + + RETURN + END + + + + + SUBROUTINE CLEANUP_BULLFILE +C +C SUBROUTINE CLEANUP_BULLFILE +C +C FUNCTION: Searches for empty space in bulletin file and deletes it. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER FILENAME*132,BUFFER*128 + + CALL OPEN_BULLDIR_SHARED + +C +C NOTE: Can't use READDIR for reading header since it'll spawn a +C BULL/CLEANUP. (Fooey). +C + + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=HEADER_KEY,IOSTAT=IER) BULLDIR_HEADER + END DO + + IF (NEMPTY.EQ.0) THEN ! No cleanup necessary + CALL CLOSE_BULLDIR + RETURN + ELSE IF (NEMPTY.GT.0) THEN + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,,) + + OPEN (UNIT=11,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + 1 STATUS='UNKNOWN',IOSTAT=IER,DISPOSE='DELETE', + 1 RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',INITIALSIZE=((NBLOCK-NEMPTY)*128)/512) + ! Compressed version is number 1 + + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot open temporary file for'' + & ,'' compressing '',A)') FOLDER(:TRIM(FOLDER)) + CALL ERRSNS(IDUMMY,IER) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL CLOSE_BULLDIR + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + END IF + + CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL', + & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL') + + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + + NBLOCK = 0 + + DO I=1,NBULL ! Copy bulletins to new file + CALL READDIR(I,IER) + ICOUNT = BLOCK + DO J=1,LENGTH + NBLOCK = NBLOCK + 1 + DO WHILE (REC_LOCK(IER1)) + READ(1'ICOUNT,IOSTAT=IER1) BUFFER + END DO + IF (IER1.NE.0) THEN ! This file is corrupt + NBLOCK = NBLOCK - 1 + NBULL = I - 1 + GO TO 100 + END IF + WRITE(11) BUFFER + ICOUNT = ICOUNT + 1 + END DO + END DO + +100 CALL CLOSE_BULLFIL + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + RETURN + END IF + + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+1 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.NE.0) THEN + CLOSE (UNIT=11) + CALL CLOSE_BULLDIR + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + RETURN + END IF + END IF + + CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR', + & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR') + + NEMPTY = 0 + WRITE (12,IOSTAT=IER) BULLDIR_HEADER ! Write directory header + + NBLOCK = 0 ! Update directory entry pointers + DO I=1,NBULL + CALL READDIR(I,IER) + BLOCK = NBLOCK + 1 + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (12,IOSTAT=IER) BULLDIR_ENTRY + NBLOCK = NBLOCK + LENGTH + END DO + + CLOSE (UNIT=12,STATUS='KEEP') + CLOSE (UNIT=11,STATUS='KEEP') + + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + + NEMPTY = -1 ! Copying done, indicate that in case of crash + WRITE (2,IOSTAT=IER) BULLDIR_HEADER ! Write new directory header + + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + + RETURN + END + + + + + SUBROUTINE CLEANUP_DIRFILE(DELETE_ENTRY) +C +C SUBROUTINE CLEANUP_DIRFILE +C +C FUNCTION: Reorder directory file after deletions. +C Is called either directly after a deletion, or is +C called if it is detected that a deletion was not fully +C completed due to the fact that the deleting process +C was abnormally terminated. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + CHARACTER*11 DATE_SAVE,EXDATE_SAVE + CHARACTER*11 TIME_SAVE,EXTIME_SAVE + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + DATE_SAVE = DATE + TIME_SAVE = TIME + EXDATE_SAVE = EXDATE + EXTIME_SAVE = EXTIME + + NBULL = -NBULL ! Negative # Bulls signals deletion in progress + MOVE_TO = 0 ! Moving directory entries starting here + MOVE_FROM = 0 ! Moving directory entries from here + I = DELETE_ENTRY ! Start search point for first deleted entries + DO WHILE (MOVE_TO.EQ.0.AND.I.LE.NBULL) + CALL READDIR(I,IER) + IF (IER.NE.I+1) THEN ! Have we found a deleted entry? + MOVE_TO = I ! If so, start moving entries to here + J=I+1 ! Search for next entry in file + DO WHILE (MOVE_FROM.EQ.0.AND.J.LE.NBULL) + CALL READDIR(J,IER) + IF (IER.EQ.J+1) MOVE_FROM = J + J = J + 1 + END DO + IF (MOVE_FROM.EQ.0) THEN ! There are no more entries + NBULL = I - 1 ! so just update number of bulletins + CALL WRITEDIR(0,IER) + RETURN + END IF + LENGTH = -LENGTH ! Indicate starting point by writing + CALL WRITEDIR(I,IER) ! next entry into deleted entry + FIRST_DELETE = I ! with negative length + MOVE_FROM = MOVE_FROM + 1 ! Set up pointers to move rest of + MOVE_TO = MOVE_TO + 1 ! the entries + ELSE IF (LENGTH.LT.0) THEN ! If negative length found, deletion + FIRST_DELETE = I ! was previously in progress + J = I ! Try to find where entry came from + CALL INIT_QUEUE(ENTRY_Q1,BULLDIR_ENTRY) + ENTRY_Q = ENTRY_Q1 + DO K=J,NBULL + CALL READDIR(K,IER) + IF (IER.EQ.K+1) THEN + CALL WRITE_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + END IF + END DO + ENTRY_QLAST = ENTRY_Q + ENTRY_Q2 = ENTRY_Q1 + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q2.NE.ENTRY_QLAST) + CALL READ_QUEUE(%VAL(ENTRY_Q2),ENTRY_Q,BULLDIR_ENTRY) + ENTRY_Q2 = ENTRY_Q + BLOCK_SAVE = BLOCK + MSG_NUM_SAVE = MSG_NUM + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q.NE.ENTRY_QLAST) + ! Search for duplicate entries + CALL READ_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + IF (BLOCK_SAVE.EQ.BLOCK) THEN + MOVE_TO = MSG_NUM_SAVE + 1 + MOVE_FROM = MSG_NUM + 1 + END IF + END DO + ! If no duplicate entry found for this + ! entry, see if one exists for any + END DO ! of the other entries + END IF + I = I + 1 + END DO + + IF (I.LE.NBULL) THEN ! Move reset of entries if necessary + IF (MOVE_FROM.GT.0) THEN + DO J=MOVE_FROM,NBULL + CALL READDIR(J,IER) + IF (IER.EQ.J+1) THEN ! Skip any other deleted entries + CALL WRITEDIR(MOVE_TO,IER) + MOVE_TO = MOVE_TO + 1 + END IF + END DO + END IF + DO J=MOVE_TO,NBULL ! Delete empty records at end of file + CALL READDIR(J,IER) + DELETE(UNIT=2,IOSTAT=IER) + END DO + NBULL = MOVE_TO - 1 ! Update # bulletin count + END IF + + CALL READDIR(FIRST_DELETE,IER) + IF (IER.EQ.FIRST_DELETE+1.AND.LENGTH.LT.0) THEN + LENGTH = -LENGTH ! Fix entry which has negative length + CALL WRITEDIR(FIRST_DELETE,IER) + END IF + + CALL WRITEDIR(0,IER) + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + DATE = DATE_SAVE + TIME = TIME_SAVE + EXDATE = EXDATE_SAVE + EXTIME = EXTIME_SAVE + + RETURN + END + + + SUBROUTINE SHOW_FLAGS +C +C SUBROUTINE SHOW_FLAGS +C +C FUNCTION: Show user flags. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + +C +C Find user entry in BULLUSER.DAT to obtain flags. +C + + CALL OPEN_BULLUSER_SHARED ! Open user file + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + WRITE (6,'('' For the selected folder '',A)') FOLDER(1:TRIM(FOLDER)) + + IF (TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' NOTIFY is set.'')') + END IF + + IF (TEST2(SET_FLAG,FOLDER_NUMBER).AND. + & (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER))) THEN + WRITE (6,'('' READNEW is set.'')') + ELSE IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' BRIEF is set.'')') + ELSE IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' SHOWNEW is set.'')') + ELSE IF (.NOT.TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' No flags are set.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(2) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBSET(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + SUBROUTINE CLR2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBCLR(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + LOGICAL FUNCTION TEST2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + TEST2 = BTEST(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + + INTEGER FUNCTION GETUSERS(USERNAME,TERMINAL) +C +C FUNCTION GETUSERS +C +C FUNCTION: +C To get names of all users that are logged in. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + +!*** MODULE $PSCANDEF *** + PARAMETER pscan$_BEGIN = '00000000'X + PARAMETER pscan$_ACCOUNT = '00000001'X + PARAMETER pscan$_AUTHPRI = '00000002'X + PARAMETER pscan$_CURPRIV = '00000003'X + PARAMETER pscan$_GRP = '00000004'X + PARAMETER pscan$_HW_MODEL = '00000005'X + PARAMETER pscan$_HW_NAME = '00000006'X + PARAMETER pscan$_JOBPRCCNT = '00000007'X + PARAMETER pscan$_JOBTYPE = '00000008'X + PARAMETER pscan$_MASTER_PID = '00000009'X + PARAMETER pscan$_MEM = '0000000A'X + PARAMETER pscan$_MODE = '0000000B'X + PARAMETER pscan$_NODE_CSID = '0000000C'X + PARAMETER pscan$_NODENAME = '0000000D'X + PARAMETER pscan$_OWNER = '0000000E'X + PARAMETER pscan$_PRCCNT = '0000000F'X + PARAMETER pscan$_PRCNAM = '00000010'X + PARAMETER pscan$_PRI = '00000011'X + PARAMETER pscan$_PRIB = '00000012'X + PARAMETER pscan$_STATE = '00000013'X + PARAMETER pscan$_STS = '00000014'X + PARAMETER pscan$_TERMINAL = '00000015'X + PARAMETER pscan$_UIC = '00000016'X + PARAMETER pscan$_USERNAME = '00000017'X + PARAMETER pscan$_GETJPI_BUFFER_SIZE = '00000018'X + PARAMETER pscan$_END = '00000019'X + PARAMETER pscan$k_type = '00000081'X + PARAMETER pscan$M_OR = '00000001'X + PARAMETER pscan$M_BIT_ALL = '00000002'X + PARAMETER pscan$M_BIT_ANY = '00000004'X + PARAMETER pscan$M_GEQ = '00000008'X + PARAMETER pscan$M_GTR = '00000010'X + PARAMETER pscan$M_LEQ = '00000020'X + PARAMETER pscan$M_LSS = '00000040'X + PARAMETER pscan$M_PREFIX_MATCH = '00000080'X + PARAMETER pscan$M_WILDCARD = '00000100'X + PARAMETER pscan$M_CASE_BLIND = '00000200'X + PARAMETER pscan$M_EQL = '00000400'X + PARAMETER pscan$M_NEQ = '00000800'X + STRUCTURE /item_specific_flags/ + PARAMETER pscan$S_OR = 1 + PARAMETER pscan$V_OR = 0 + PARAMETER pscan$S_BIT_ALL = 1 + PARAMETER pscan$V_BIT_ALL = 1 + PARAMETER pscan$S_BIT_ANY = 1 + PARAMETER pscan$V_BIT_ANY = 2 + PARAMETER pscan$S_GEQ = 1 + PARAMETER pscan$V_GEQ = 3 + PARAMETER pscan$S_GTR = 1 + PARAMETER pscan$V_GTR = 4 + PARAMETER pscan$S_LEQ = 1 + PARAMETER pscan$V_LEQ = 5 + PARAMETER pscan$S_LSS = 1 + PARAMETER pscan$V_LSS = 6 + PARAMETER pscan$S_PREFIX_MATCH = 1 + PARAMETER pscan$V_PREFIX_MATCH = 7 + PARAMETER pscan$S_WILDCARD = 1 + PARAMETER pscan$V_WILDCARD = 8 + PARAMETER pscan$S_CASE_BLIND = 1 + PARAMETER pscan$V_CASE_BLIND = 9 + PARAMETER pscan$S_EQL = 1 + PARAMETER pscan$V_EQL = 10 + PARAMETER pscan$S_NEQ = 1 + PARAMETER pscan$V_NEQ = 11 + BYTE %FILL (2) + END STRUCTURE + + CHARACTER USERNAME*(*),TERMINAL*(*) + + DATA CONTEXT/0/ + + IF (CONTEXT.EQ.0) THEN + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST_WITH_RET(0,PSCAN$_NODE_CSID,0,PSCAN$M_NEQ) + CALL ADD_2_ITMLST(0,PSCAN$_MODE,JPI$K_INTERACTIVE) + CALL END_ITMLST(PSCAN_ITMLST) ! Get address of itemlist + + IER = SYS$PROCESS_SCAN(CONTEXT,%VAL(PSCAN_ITMLST)) + END IF + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL ADD_2_ITMLST(LEN(TERMINAL),JPI$_TERMINAL,%LOC(TERMINAL)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = 1 + TERMINAL(1:1) = CHAR(0) + DO WHILE (IER.AND.TERMINAL(1:1).EQ.CHAR(0)) + ! Get next interactive process + IER = SYS$GETJPIW(,CONTEXT,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + + IF (.NOT.IER) CONTEXT = 0 + + GETUSERS = IER + + RETURN + END + + + + + + SUBROUTINE OPEN_USERINFO +C +C SUBROUTINE OPEN_USERINFO +C +C FUNCTION: Opens the file in SYS$LOGIN which contains user information. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /USERINFO/ USERINFO_READ,OLD_LAST_READ_BTIM(2,FOLDER_MAX) + COMMON /USERINFO/ OLD_LAST_SYS_BTIM(2,FOLDER_MAX) + DATA USERINFO_READ /.FALSE./ + + INTEGER TODAY_BTIM(2) + + CALL OPEN_BULLINF_SHARED + + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + + IF (IER.EQ.0) THEN ! Check to see if dates all in future + CALL SYS_BINTIM('-',TODAY_BTIM) ! Get today's date + DO I=1,FOLDER_MAX + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,I),TODAY_BTIM) + IF (DIFF.GE.0) THEN ! Must have been in a time wrap + LAST_READ_BTIM(1,I) = TODAY_BTIM(1) + LAST_READ_BTIM(2,I) = TODAY_BTIM(2) + END IF + END DO + END IF + + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2 ! Is this BULLCP process? + & .AND.CONFIRM_USER(USERNAME).NE.0) THEN ! Not real user? + USERNAME = 'DECNET' + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + + IF (IER.NE.0) THEN + OPEN (UNIT=10,FILE='SYS$LOGIN:BULLETIN.INF',STATUS='OLD', + & RECORDTYPE='FIXED',FORM='UNFORMATTED',IOSTAT=IER) + INQUIRE(UNIT=10,RECORDSIZE=INF_SIZE) + IF (IER.EQ.0) THEN + READ (10) + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,INF_SIZE/2) + CLOSE (UNIT=10,STATUS='DELETE') + ELSE + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Find user's info + CALL CLOSE_BULLUSER + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2) THEN ! BULLCP process? + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's date + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) + CALL READ_USER_FILE_HEADER(IER) + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + END IF + IF (IER.EQ.0) THEN + DO I=1,FOLDER_MAX + LAST_READ_BTIM(1,I) = READ_BTIM(1) + LAST_READ_BTIM(2,I) = READ_BTIM(2) + END DO + END IF + END IF + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + + LUSER = TRIM(USERNAME) + USERNAME(LUSER:LUSER) = CHAR(128.OR.ICHAR(USERNAME(LUSER:LUSER))) + READ (9,KEY=USERNAME,IOSTAT=IER1) USERNAME, + & ((LAST_SYS_BTIM(1,I),LAST_SYS_BTIM(2,I)),I=1,FOLDER_MAX) + USERNAME(LUSER:LUSER) = CHAR(127.AND.ICHAR(USERNAME(LUSER:LUSER))) + IF (IER1.NE.0) THEN + DO I=1,FOLDER_MAX + LAST_SYS_BTIM(1,I) = 0 + LAST_SYS_BTIM(2,I) = 0 + END DO + END IF + + CALL CLOSE_BULLINF + + CALL LIB$MOVC3(FOLDER_MAX*2*4,LAST_READ_BTIM,OLD_LAST_READ_BTIM) + CALL LIB$MOVC3(FOLDER_MAX*2*4,LAST_SYS_BTIM,OLD_LAST_SYS_BTIM) + + USERINFO_READ = .TRUE. + + RETURN + END + + + + SUBROUTINE UPDATE_USERINFO +C +C SUBROUTINE UPDATE_USERINFO +C +C FUNCTION: Updates the latest message read times for each folder. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /USERINFO/ USERINFO_READ,OLD_LAST_READ_BTIM(2,FOLDER_MAX) + COMMON /USERINFO/ OLD_LAST_SYS_BTIM(2,FOLDER_MAX) + + IF (.NOT.USERINFO_READ) RETURN + + DIFF = .FALSE. + FNUM = 1 + + DO WHILE (.NOT.DIFF.AND.FNUM.LE.FOLDER_MAX) + DIFF = LAST_READ_BTIM(1,FNUM).NE.OLD_LAST_READ_BTIM(1,FNUM) + IF (.NOT.DIFF) THEN + DIFF = LAST_READ_BTIM(2,FNUM).NE.OLD_LAST_READ_BTIM(2,FNUM) + END IF + FNUM = FNUM + 1 + END DO + + DIFF1 = .FALSE. + FNUM = 1 + + DO WHILE (.NOT.DIFF1.AND.FNUM.LE.FOLDER_MAX) + DIFF1 = LAST_SYS_BTIM(1,FNUM).NE.OLD_LAST_SYS_BTIM(1,FNUM) + IF (.NOT.DIFF1) THEN + DIFF1 = LAST_SYS_BTIM(2,FNUM).NE.OLD_LAST_SYS_BTIM(2,FNUM) + END IF + FNUM = FNUM + 1 + END DO + + IF (.NOT.(DIFF.OR.DIFF1)) RETURN + + CALL OPEN_BULLINF_SHARED + + IF (DIFF) THEN + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) REWRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + + IF (DIFF1) THEN + LUSER = TRIM(USERNAME) + USERNAME(LUSER:LUSER) = CHAR(128.OR.ICHAR(USERNAME(LUSER:LUSER))) + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_SYS_BTIM(1,I),LAST_SYS_BTIM(2,I)),I=1,FOLDER_MAX) + ELSE + WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_SYS_BTIM(1,I),LAST_SYS_BTIM(2,I)),I=1,FOLDER_MAX) + END IF + USERNAME(LUSER:LUSER) = CHAR(127.AND.ICHAR(USERNAME(LUSER:LUSER))) + END IF + + CALL CLOSE_BULLINF + + RETURN + END + + + INTEGER FUNCTION SYS_BINTIM(TIME,BTIM) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*(*) TIME + + IF (TRIM(TIME).EQ.20) THEN + SYS_BINTIM = SYS$BINTIM(TIME//'.00',BTIM) + ELSE + SYS_BINTIM = SYS$BINTIM(TIME,BTIM) + END IF + + RETURN + END + + + + + SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C FUNCTION: +C +C Update user's last read bulletin date. If new bulletins have been +C added since the last time bulletins have been read, position bulletin +C pointer so that next bulletin read is the first new bulletin, and +C alert user. If READNEW set and no new bulletins, just exit. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /POINT/ BULL_POINT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM + + COMMON /LOGIN_BTIM/ LOGIN_BTIM_SAVE(2) + + IF (.NOT.LOGIN_SWITCH) THEN + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + CALL UPDATE_READ(0) ! Update login time + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL SELECT_FOLDER(.TRUE.,IER) + IF (IER) RETURN + END IF + CALL READ_IN_FOLDERS ! Read folder info + ELSE + LOGIN_SWITCH = .FALSE. ! So LOGIN_FOLDER entry doesn't + END IF ! think it's called via LOGIN + + FOLDER_Q = SAVE_FOLDER_Q1 + + DO I = 1,SAVE_FOLDER_NUM + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + CALL CLR2(NEW_MSG,FOLDER_NUMBER) ! Clear new message flag + IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL SET2(NEW_MSG,FOLDER_NUMBER) + ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & (FOLDER_NUMBER.GT.0.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND.READIT.EQ.1)) THEN + IF (READIT.EQ.1.AND.SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM, + & F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.READIT.EQ.1) THEN + IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & NEW_FLAG(2).NE.-1) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + END IF + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.DIFF.GE.0) THEN + IER = MINUTE_DIFF(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + IF (IER.LE.15) DIFF = -1 + END IF + END IF + END IF + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN ! If new unread messages + CALL SET2(NEW_MSG,FOLDER_NUMBER) ! Set new message flag + END IF + END IF + END DO + + FOLDER_Q = SAVE_FOLDER_Q1 + + IF (READIT.EQ.0) THEN ! If not in READNEW mode + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + NEW_MESS = .FALSE. + DO I = 1,SAVE_FOLDER_NUM-1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN ! Are there unread messages? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_NOSYS_BTIM) + IF (DIFF.GT.0) THEN ! Unread non-system messages? + DIFF = COMPARE_BTIM(LOGIN_BTIM,F_NEWEST_BTIM) + ! No. Unread system messages? + IF (DIFF.GT.0) THEN ! No, update last read time. + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(2) + END IF + END IF + IF (DIFF.LT.0) THEN + WRITE (6,'('' There are new messages in '', + & ''folder '',A,''.'',$)') FOLDER(1:TRIM(FOLDER)) + NEW_MESS = .TRUE. + END IF + END IF + END IF + END DO + IF (NEW_MESS) THEN + WRITE (6,'('' Type SELECT followed by foldername to'', + & '' read above messages.'')') + END IF + SAVE_FOLDER_Q1 = 0 + FOLDER_NUMBER = 0 + CALL SELECT_FOLDER(.FALSE.,IER) + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN + CALL FIND_NEWEST_BULL ! See if there are new messages + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new GENERAL messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + END IF + ELSE ! READNEW mode. + DO I = 1,SAVE_FOLDER_NUM + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + CALL SELECT_FOLDER(.FALSE.,IER) + IF (IER) THEN + IF (SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.TEST2(BRIEF_FLAG,FOLDER_NUMBER) + & .AND.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + IF (DIFF.LT.0) THEN + IF (FOLDER_NUMBER.GT.0) CALL LOGIN_FOLDER + IF (BULL_POINT.NE.-1.OR.NEW_FLAG(2).EQ.-1.OR. + & .NOT.TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) + & WRITE (6,'('' There are new messages in folder '' + & ,A,''.'')') FOLDER(1:TRIM(FOLDER)) + ELSE + WRITE (6,'('' There are new messages in folder '' + & ,A,''.'')') FOLDER(1:TRIM(FOLDER)) + END IF + DIFF = 0 + END IF + END IF + IF (DIFF.LT.0) THEN + IF (FOLDER_NUMBER.GT.0) CALL LOGIN_FOLDER + IF (BULL_POINT.NE.-1) THEN + IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + SAVE_BULL_POINT = BULL_POINT + REDO = .TRUE. + DO WHILE (REDO) + REDO = .FALSE. + CALL READNEW(REDO) + IF (REDO) CALL REDISPLAY_DIRECTORY + BULL_POINT = SAVE_BULL_POINT + END DO + END IF + END IF + END IF + END IF + END IF + END DO + CALL EXIT + END IF + + RETURN + END + + + + + SUBROUTINE READ_IN_FOLDERS + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM + DATA SAVE_FOLDER_Q1/0/,SAVE_FOLDER_NUM/0/ + + COMMON /READIT/ READIT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL INIT_QUEUE(SAVE_FOLDER_Q1,FOLDER_COM) + FOLDER_Q = SAVE_FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Go find folders + + FOLDER_NUMBER = 0 + CALL READ_FOLDER_FILE_KEYNUM(FOLDER_NUMBER,IER) + DO WHILE (IER.EQ.0) + SAVE_FOLDER_NUM = SAVE_FOLDER_NUM + 1 + IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ELSE IF ((NEW_FLAG(1).LT.142.OR.NEW_FLAG(1).GT.143).AND. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + CALL CHANGE_FLAG_NOCMD(0,3) + CALL SET_VERSION + ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & (FOLDER_NUMBER.GT.0.AND.(BTEST(FOLDER_FLAG,2).OR. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)).AND.READIT.EQ.1)) THEN +C +C Unknown problem caused system folder flag in folder file to disappear +C so this tests to see if the flag has disappeared and resets if needed. +C + IF (TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND. + & .NOT.BTEST(FOLDER_FLAG,2)) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + CALL REWRITE_FOLDER_FILE + ELSE IF (.NOT.TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND. + & BTEST(FOLDER_FLAG,2)) THEN + CALL MODIFY_SYSTEM_LIST(1) + END IF + END IF + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + CALL READ_FOLDER_FILE_KEYNUM_GT(FOLDER_NUMBER,IER) + END DO + + CALL CLOSE_BULLFOLDER + + FOLDER_Q = SAVE_FOLDER_Q1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + RETURN + END + + + + + SUBROUTINE DISCONNECT_REMOTE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + WRITE (6,'('' ERROR: Connection to remote folder disconnected.'')') + + FOLDER_NUMBER = -1 + FOLDER1 = 'GENERAL' + + CALL SELECT_FOLDER(.FALSE.,IER) + + WRITE (6,'('' Resetting to GENERAL folder.'')') + + RETURN + END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin8.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin8.for new file mode 100644 index 0000000..2a5d215 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin8.for @@ -0,0 +1,1654 @@ +C +C BULLETIN8.FOR, Version 11/28/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE START_DECNET + + IMPLICIT INTEGER (A - Z) + + CHARACTER NAMEDESC*9 /'BULLETIN1'/ + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for + INTEGER*2 MBX_IOSB ! terminal QIO calls. + LOGICAL*1 MBX_BUF + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(208,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + DIMENSION NFBDESC(2) + LOGICAL*1 NFB(5) + + EXTERNAL IO$_ACPCONTROL + + PARAMETER NFB$C_DECLNAME = '15'X + + IF (CONFIRM_USER('DECNET').EQ.0) THEN + CALL SETDEFAULT('DECNET') + END IF + +C CALL SET_TIMER('02') + + IER = SYS$CREMBX(%VAL(0),MBX_CHAN,%VAL(132),%VAL(528),,, + & 'BULL_MBX') + IF (.NOT.IER) CALL EXIT(IER) + + IER = SYS$ASSIGN('_NET:',DCL_CHAN,,'BULL_MBX') ! Assign net device + IF (.NOT.IER) CALL EXIT(IER) + + NFBDESC(1) = 5 + NFBDESC(2) = %LOC(NFB) + + NFB(1) = NFB$C_DECLNAME + + IER = SYS$QIOW(,%VAL(DCL_CHAN),IO$_ACPCONTROL,,,, + & NFBDESC,NAMEDESC,,,,) + IF (.NOT.IER) CALL EXIT(IER) + + DO I=1,MAXLINK + CALL LIB$GET_EF(READ_EFS(I)) + CALL LIB$GET_EF(WRITE_EFS(I)) + END DO + + CALL READ_MBX + + RETURN + END + + + SUBROUTINE SETDEFAULT(USERNAME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LNMDEF)' + + INCLUDE '($PSLDEF)' + + INCLUDE '($UAIDEF)' + + CHARACTER DEFDIR*64,DEFDEV*16,USERNAME*(*),ACCOUNT*9 + 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 + + IMPLICIT INTEGER (A-Z) + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + 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) + + IER = SYS$QIO(%VAL(MBX_EF),%VAL(MBX_CHAN),IO$_READVBLK,MBX_IOSB, + & MBX_AST,,MBX_BUF,%VAL(132),,,,) + IF (.NOT.IER) CALL EXIT(IER) + + RETURN + + END + + + + + SUBROUTINE MBX_AST + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($MSGDEF)' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(208,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + 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*6,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 CONNECT(NODENAME,USERNAME,FROMNAME) + ELSE IF ((MBXMSG.EQ.MSG$_INTMSG.OR.MBXMSG.EQ.MSG$_REJECT.OR. + & MBXMSG.EQ.MSG$_CONFIRM).AND.MBX_IOSB(1)) THEN + CALL READ_MBX + 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 + END IF + + RETURN + END + + + + + SUBROUTINE READ_CHAN(CHAN,UNIT_INDEX) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(208,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + EXTERNAL READ_AST + + EXTERNAL IO$_READVBLK + + IER = SYS$QIO(%VAL(READ_EFS(UNIT_INDEX)),%VAL(CHAN),IO$_READVBLK, + & READ_IOSB(1,UNIT_INDEX),READ_AST, + & %VAL(UNIT_INDEX),READ_BUF(1,UNIT_INDEX),%VAL(208),,,,) + + RETURN + + END + + + + + SUBROUTINE WRITE_CHAN(NUM,OUTPUT,UNIT_INDEX,IER) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(208,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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)) + + IER = SYS$QIO(%VAL(WRITE_EFS(UNIT_INDEX)), + & %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 WRITE_AST(ASTPRM) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) + COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDER_NAME(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,FOLDER_NAME*25,FROM_SAVE*12,NODE_SAVE*12 + + CHARACTER*128 INPUT + + 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) + END IF + + RETURN + END + + + + SUBROUTINE READ_AST(ASTPRM) + + IMPLICIT INTEGER (A-Z) + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(208,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) + + UNIT_INDEX = %LOC(ASTPRM) + + IF (.NOT.READ_IOSB(1,UNIT_INDEX)) RETURN + + IO(UNIT_INDEX) = IO(UNIT_INDEX) + 1 + + CALL EXECUTE_COMMAND(UNIT_INDEX) + + CALL READ_CHAN(DEVS(UNIT_INDEX),UNIT_INDEX) + + RETURN + END + + + + + + SUBROUTINE CONNECT(NODENAME,USERNAME,FROMNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /ANY_ACTIVITY/ CONNECT_COUNT + DATA CONNECT_COUNT /0/ + + CHARACTER*(*) USERNAME,FROMNAME + + EXTERNAL IO$_ACCESS,IO$M_ABORT + + CONNECT_COUNT = CONNECT_COUNT + 1 + + IO_REJECT = %LOC(IO$_ACCESS)+%LOC(IO$M_ABORT) + + CALL CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, + & NODENAME,USERNAME,FROMNAME) + + IF (REJECT.NE.IO_REJECT) THEN + CALL READ_CHAN(CHAN,UNIT_INDEX) + END IF + + CALL READ_MBX + + RETURN + END + + + SUBROUTINE CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, + & NODENAME,USERNAME,FROMNAME) + + IMPLICIT INTEGER (A-Z) + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN + + COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for + INTEGER*2 MBX_IOSB ! terminal QIO calls. + LOGICAL*1 MBX_BUF + + PARAMETER MAXLINK = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(256,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(208,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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),FOLDER_NAME(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,FOLDER_NAME*25,FROM_SAVE*12,NODE_SAVE*12 + + 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 + ELSE + IER = SYS$ASSIGN('_NET:',DEV_CHAN,,'BULL_MBX') + + 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).GT.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 + 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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(208,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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 + + IF (UNITS(UNIT_INDEX).EQ.0) RETURN + + CALL SYS$DASSGN(%VAL(DEVS(UNIT_INDEX))) + + CALL UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + COUNT = COUNT - 1 + DEVS(UNIT_INDEX) = 0 + UNITS(UNIT_INDEX) = 0 + + 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 TIMBUF*13,MIN*2 + DATA TIMBUF/'0 00:00:00.00'/ + + EXTERNAL CHECK_CONNECTIONS + + CALL LIB$GET_EF(WAITEFN) + + TIMBUF(6:7) = MIN + + IER=SYS$BINTIM(TIMBUF,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 = 10 + + COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(208,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(208,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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),FOLDER_NAME(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,FOLDER_NAME*25,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 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + 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*53 + CHARACTER NODENAME*6,BULLCP_USER*12,INQUEUE*128 + + EQUIVALENCE (BUFFER,CMD_TYPE),(BUFFER,INQUEUE) + + INTEGER BULLCP_PRIV(2) + + BULLCP_PRIV(1) = PROCPRIV(1) + BULLCP_PRIV(2) = PROCPRIV(2) + + ILEN = READ_IOSB(2,UNIT_INDEX) + CALL LIB$MOVC3(ILEN,READ_BUF(1,UNIT_INDEX),%REF(BUFFER)) + + REC_SAVE(UNIT_INDEX) = 0 + USERNAME = USER_SAVE(UNIT_INDEX) + FOLDER = FOLDER_NAME(UNIT_INDEX) + FOLDER_NUMBER = FOLDER_NUM(UNIT_INDEX) + NODENAME = NODE_SAVE(UNIT_INDEX) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,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) THEN ! Do we need priv info? + IF (PROCPRIV(1).EQ.0.AND.PROCPRIV(2).EQ.0) THEN + CALL GET_USER_PRIV(USERNAME,PRIV_SAVE(1,UNIT_INDEX)) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,UNIT_INDEX) + IF ( (PROCPRIV(1).AND.NEEDPRIV(1)).EQ.0.AND. + & (PROCPRIV(2).AND.NEEDPRIV(2)).EQ.0) THEN + CALL CHECK_BULLETIN_PRIV(USERNAME) + PRIV_SAVE(1,UNIT_INDEX) = PROCPRIV(1) + PRIV_SAVE(2,UNIT_INDEX) = PROCPRIV(2) + END IF + END IF + 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:1))) + CALL WRITE_CHAN(4,BUFFER,UNIT_INDEX,IER1) + ELSE + CALL LIB$MOVC3(4,0,%REF(BUFFER(1: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:1))) + CALL LIB$MOVC3(4,READ_ONLY,%REF(BUFFER(5: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13:13))) + ELSE + CALL LIB$MOVC3(8,LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & %REF(BUFFER(9: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13: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: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 + FOLDER_NAME(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(53,%REF(BUFFER(5:5)),%REF(DESCRIP)) + CALL LIB$MOVC3(11,%REF(BUFFER(58:58)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(69:69)),%REF(EXTIME)) + CALL LIB$MOVC3(4,%REF(BUFFER(80:80)),SYSTEM) + 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 (FOLDER_OWNER.NE.USERNAME.AND. + & F_EXPIRE_LIMIT.GT.0) 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(84:84)),BROAD) + IF (BROAD.AND..NOT.SETPRV_PRIV().AND..NOT.OPER_PRIV()) THEN + BROAD = 0 + END IF + CALL LIB$MOVC3(4,%REF(BUFFER(88:88)),BELL) + CALL LIB$MOVC3(4,%REF(BUFFER(92:92)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(97:97)),CLUSTER) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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 + 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 (1) + 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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + IF (ICOUNT.GE.0) THEN + CALL READDIR(ICOUNT,IER) + ELSE + CALL LIB$MOVC3(8,%REF(BUFFER(9:9)),%REF(MSG_KEY(1:1))) + CALL READDIR_KEYGE(IER) + END IF + CALL CLOSE_BULLDIR + CALL LIB$MOVC3(4,IER,%REF(BUFFER(1: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:5)),SBULL) + CALL LIB$MOVC3(4,%REF(BUFFER(9:9)),EBULL) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),BULL_DELETE) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR + CALL LIB$MOVC3(53,%REF(BUFFER(5:5)),%REF(DESCRIP_TEMP)) + CALL LIB$MOVC3(4,%REF(BUFFER(58:58)),ICOUNT) + 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(53,%REF(BUFFER(62:62)),%REF(DESCRIP)) + CALL LIB$MOVC3(4,%REF(BUFFER(115:115)),%REF(MSGTYPE)) + CALL LIB$MOVC3(11,%REF(BUFFER(119:119)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(130:130)),%REF(EXTIME)) + 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:5)),BULL_DELETE) + DESCRIP_TEMP = BUFFER(9:61) + 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(11,%REF(BUFFER(62:62)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(73:73)),%REF(EXTIME)) + 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 + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) + CALL GET_NEWEST_MSG(%REF(BUFFER(5: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: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:5)),BLENGTH) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:13)), + & %VAL(SCRATCH(UNIT_INDEX)+START-1)) + ELSE + CALL LIB$MOVC3(BLENGTH,%VAL(SCRATCH(UNIT_INDEX)), + & %REF(BMESSAGE(1:1))) + CALL LIB$MOVC3(4,%REF(BUFFER(13:13)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(17:17)),CLUSTER) + CALL LIB$FREE_VM(BRDCST_LIMIT,SCRATCH(UNIT_INDEX)) + IF (ILEN.GT.20) THEN + CALL LIB$MOVC3(4,%REF(BUFFER(21:21)),FOLDER_NUMBER) + FOLDER = BUFFER(25:) + GO TO 100 + ELSE IF (SETPRV_PRIV().OR.OPER_PRIV()) THEN + CALL BROADCAST(ALL,CLUSTER) + END IF + END IF + END IF + +1000 PROCPRIV(1) = BULLCP_PRIV(1) + PROCPRIV(2) = BULLCP_PRIV(2) + + RETURN + END + + + + SUBROUTINE UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) + COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDER_NAME(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,FOLDER_NAME*25,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' + + 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) THEN + PROCPRIV(1) = NEEDPRIV(1) + PROCPRIV(2) = NEEDPRIV(2) + END IF + 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') + REC_LOCK = 1 + 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) + + CHARACTER*80 MESSAGE + + 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 + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER LOCAL_NODE*32,NODE_TEMP*256,PASSWORD*31,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 diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin9.for b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin9.for new file mode 100644 index 0000000..874f5ea --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulletin9.for @@ -0,0 +1,1950 @@ +C +C BULLETIN9.FOR, Version 10/23/90 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, VMS +C Programmer: Mark R. London +C + SUBROUTINE DELETE_NODE +C +C SUBROUTINE DELETE_NODE +C +C FUNCTION: Deletes files sent via ADD/NODES at remote hosts. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER INLINE*80 + + CALL GET_NODE_INFO + + IF (NODE_ERROR) GO TO 940 + + IF (NODE_NUM.EQ.0.OR.LOCAL_NODE_FOUND) THEN + WRITE (6,'('' ERROR: Cannot specify local node.'')') + GO TO 999 + END IF + + IER = CLI$GET_VALUE('SUBJECT',DESCRIP) + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + NLEN = TRIM(NODES(POINT_NODE)) ! Length of node name + INLINE = 'DELETE/SUBJECT="'//DESCRIP(:TRIM(DESCRIP)) + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INLINE + IF (INLINE.EQ.'END') THEN + WRITE (6,'('' Message successfully deleted from node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while deleting message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INLINE + END IF + END DO + + GO TO 999 + +910 WRITE (6,1010) + GO TO 999 + +940 WRITE (6,1015) NODES(POINT_NODE) + +999 DO WHILE (NODE_NUM.GT.0) + CLOSE(UNIT=9+NODE_NUM) + NODE_NUM = NODE_NUM - 1 + END DO + + RETURN + +1010 FORMAT (' ERROR: Deletion aborted.') +1015 FORMAT (' ERROR: Unable to reach node ',A) + + END + + + + + SUBROUTINE SET_FOLDER_FLAG(SETTING,FLAG,FLAGNAME) +C +C SUBROUTINE SET_FOLDER_FLAG +C +C FUNCTION: Sets or clears specified flag for folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*(*) FLAGNAME + + IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (SETTING) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,FLAG) + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,FLAG) + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + WRITE (6,'(1X,A,'' has been modified for folder.'')') + & FLAGNAME + ELSE + WRITE (6,'(1X,'' You are not authorized to modify '',A)') + & FLAGNAME//'.' + END IF + + RETURN + END + + + + + SUBROUTINE SET_FOLDER_EXPIRE_LIMIT(LIMIT) +C +C SUBROUTINE SET_FOLDER_EXPIRE_LIMIT +C +C FUNCTION: Sets folder expiration limit. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (LIMIT.LT.0) THEN + WRITE (6,'('' ERROR: Invalid expiration length specified.'')') + ELSE IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + F_EXPIRE_LIMIT = LIMIT + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + WRITE (6,'('' Folder expiration date modified.'')') + ELSE + WRITE (6,'('' You are not allowed to modify folder.'')') + END IF + + RETURN + END + + + + + + SUBROUTINE MERGE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + ENTRY INITIALIZE_MERGE(IER1) + + DO WHILE (FILE_LOCK(IER1,IER2)) + OPEN (UNIT=13,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER1.NE.0) RETURN + + NBULL = 0 + + WRITE(13,IOSTAT=IER1) BULLDIR_HEADER + CALL CONVERT_HEADER_FROMBIN + + TO_POINTER = 1 + + RETURN + + ENTRY ADD_MERGE_TO(IER1) + + IER1 = 0 + + DO WHILE (IER1.EQ.0) + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + + CALL READDIR(TO_POINTER,IER) + + DIFF = COMPARE_BTIM(%REF(BULLDIR_ENTRY_SAVE),MSG_BTIM) + IF (DIFF.LT.0.OR.TO_POINTER+1.NE.IER) THEN + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + CALL CONVERT_ENTRY_FROMBIN + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + END DO + + CLOSE (UNIT=13) + + RETURN + + ENTRY ADD_MERGE_FROM(IER1) + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + BLOCK = NBLOCK - LENGTH + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + RETURN + + ENTRY ADD_MERGE_REST(IER1) + + CALL UPDATE_LOGIN(.TRUE.) + + DO WHILE (IER1.EQ.0) + + CALL READDIR(TO_POINTER,IER) + IF (TO_POINTER+1.NE.IER) THEN + READ (13,KEYID=0,KEY=0,IOSTAT=IER1) + CALL CONVERT_HEADER_TOBIN + REWRITE(13,IOSTAT=IER1) BULLDIR_HEADER + IF (IER1.EQ.0) THEN + CLOSE (UNIT=13,DISPOSE='KEEP') + CALL LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.TMPDIR',FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR') + ELSE + CLOSE (UNIT=13) + END IF + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + END DO + + CLOSE (UNIT=13) + + RETURN + END + + + + + SUBROUTINE SET_NOKEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /KEYPAD/ KEYPAD_MODE + + INCLUDE '($SMGDEF)' + + KEYPAD_MODE = 0 + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'SET KEYPAD',) + + RETURN + END + + + + + + SUBROUTINE SET_KEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /KEYPAD/ KEYPAD_MODE + + INCLUDE '($SMGDEF)' + + KEYPAD_MODE = 1 + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF1',,,,'GOLD') + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'HELP',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2','GOLD',TERM,'SET NOKEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3',,,'EXTRACT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3','GOLD',,'FILE ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4',,TERM,'SHOW KEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4','GOLD',TERM, + & 'SHOW KEYPAD/PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0',,TERM, + & 'SHOW FOLDER/FULL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0','GOLD',TERM,'SHOW FLAGS',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1',,TERM,'BACK',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1','GOLD',TERM,'NEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2',,TERM,'PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2','GOLD',TERM,'PRINT/NONOTIFY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3',,TERM,'DIR',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3','GOLD',TERM,'DIR/FOLDER',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4',,TERM,'CURRENT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4','GOLD',TERM,'CURRENT/EDIT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5',,TERM,'RESPOND',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5','GOLD',TERM,'RESP/EDIT/TEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP6',,TERM,'LAST',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7',,TERM,'ADD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7','GOLD',TERM,'ADD/EDIT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8',,TERM,'REPLY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8','GOLD',TERM,'REPL/EDIT/TEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9',,TERM,'MAIL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9','GOLD',TERM,'MAIL/NOHEAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS',,TERM,'READ/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS','GOLD',TERM,'SHOW NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA',,TERM,'DIR/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA','GOLD',TERM,'INDEX',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD',,TERM,'DELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD','GOLD',TERM,'UNDELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'ENTER','GOLD',,'SELECT ',) + + RETURN + END + + + + SUBROUTINE SHOW_KEYPAD(LIBRARY) + + IMPLICIT INTEGER (A-Z) + EXTERNAL LIB$PUT_OUTPUT,PRINT_OUTPUT + CHARACTER*(*) LIBRARY + + INCLUDE '($HLPDEF)' + + IF (CLI$PRESENT('PRINT')) THEN + OPEN (UNIT=8,STATUS='NEW',FILE='SYS$LOGIN:KEYPAD.DAT', + & IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR WHILE OPENING FILE TO PRINTER.'')') + ELSE + CALL LBR$OUTPUT_HELP(PRINT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + CLOSE (UNIT=8,DISP='PRINT/DELETE') + END IF + ELSE + CALL LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + END IF + + RETURN + END + + INTEGER FUNCTION PRINT_OUTPUT(INPUT) + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) INPUT + WRITE (8,'(1X,A)',IOSTAT=IER) INPUT(:TRIM(INPUT)) + IF (IER.EQ.0) PRINT_OUTPUT = 1 + RETURN + END + + + + SUBROUTINE OUTPUT_HELP(PARAMETER,LIBRARY) +C +C SUBROUTINE OUTPUT_HELP +C +C FUNCTION: +C To create interactive help session. Prompting is enabled. +C INPUTS: +C PARAMETER - Character string. Optional input parameter +C containing a list of help keys. +C LIBRARY - Character string. Name of help library. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LBRDEF)' + + COMMON /HELP/ HELP_PAGE,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID,OTHERINFO + CHARACTER*80 HELP_INPUT + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + EXTERNAL PUT_OUTPUT + + CHARACTER*(*) LIBRARY,PARAMETER + + CHARACTER*80 PROMPT + + DATA DISPLAY_ID/0/,KEYBOARD_ID/0/ + + IF (KEYBOARD_ID.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + END IF + + CALL STR$TRIM(HELP_INPUT,PARAMETER,HELP_INPUT_LEN) ! Trim input + + CALL LBR$INI_CONTROL(LINDEX,LBR$C_READ) ! Init library read + CALL LBR$OPEN(LINDEX,LIBRARY) ! Specify library name + + DO I=1,10 ! Initialize key lengths + KEYL(I) = 0 + END DO + + NKEY = 0 ! Number of help keys + + DO WHILE (1) ! Do until CTRL-Z entered or no more keys + + HELP_PAGE = 0 ! Init line counter + NEED_ERASE = .TRUE. ! Need to erase screen + + OLD_NKEY = NKEY ! Save old key count + EXACT = .TRUE. ! Exact key match + + DO WHILE (NKEY.LT.10.AND.HELP_INPUT_LEN.GT.0.AND. + & HELP_INPUT(:1).NE.'?') + ! Break input into keys + NKEY = NKEY + 1 ! Increment key counter + + DO WHILE (HELP_INPUT(1:1).EQ.' '.AND.HELP_INPUT_LEN.GT.0) + HELP_INPUT = HELP_INPUT(2:HELP_INPUT_LEN) ! Strip spaces + HELP_INPUT_LEN = HELP_INPUT_LEN - 1 ! at start of input + END DO + + NEXT_KEY = 2 + + DO WHILE (NEXT_KEY.LE.HELP_INPUT_LEN ! Search for + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.' ' ! space or + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.'/') ! backslash + NEXT_KEY = NEXT_KEY + 1 ! indicating start of next key + END DO + + IF (NEXT_KEY.GT.HELP_INPUT_LEN) THEN ! Found the last key + KEY(NKEY) = HELP_INPUT(:HELP_INPUT_LEN) ! Key string + KEYL(NKEY) = HELP_INPUT_LEN ! Key length + HELP_INPUT_LEN = 0 + ELSE ! Found the next key + KEY(NKEY) = HELP_INPUT(:NEXT_KEY-1) + HELP_INPUT = HELP_INPUT(NEXT_KEY:HELP_INPUT_LEN) + KEYL(NKEY) = NEXT_KEY - 1 + HELP_INPUT_LEN = HELP_INPUT_LEN - NEXT_KEY + 1 + END IF + END DO + HELP_INPUT_LEN = 0 + IER = LBR$GET_HELP(LINDEX,,PUT_OUTPUT,, ! Display help + & KEY(1)(:KEYL(1)),KEY(2)(:KEYL(2)), + & KEY(3)(:KEYL(3)),KEY(4)(:KEYL(4)),KEY(5)(:KEYL(5)), + & KEY(6)(:KEYL(6)),KEY(7)(:KEYL(7)),KEY(8)(:KEYL(8)), + & KEY(9)(:KEYL(9)),KEY(10)(:KEYL(10))) + + IF (IER.EQ.0.AND.HELP_INPUT_LEN.GT.0) IER = 1 + ! IER = 0 special case means input given to full screen prompt + + IF (KEY(NKEY).EQ.'*'.OR..NOT.EXACT) THEN ! If not exact match + DO I=OLD_NKEY+1,NKEY ! then don't update + KEYL(I) = 0 ! new keys + END DO + NKEY = OLD_NKEY + END IF + + IF (IER.AND.NKEY.GT.0.AND.OTHERINFO.EQ.0) THEN ! No subtopics? + KEYL(NKEY) = 0 ! Back up one key level + NKEY = NKEY - 1 + END IF + + DO WHILE (HELP_INPUT_LEN.EQ.0.AND.IER.AND.NKEY.GE.0) + IF (NKEY.EQ.0) THEN ! If top level, prompt for topic + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Topic? ',HELP_INPUT_LEN) + ELSE ! If not top level, prompt for subtopic + LPROMPT = 0 ! Create subtopic prompt line + DO I=1,NKEY ! Put spaces in between keys + PROMPT = PROMPT(:LPROMPT)//KEY(I)(:KEYL(I))//' ' + LPROMPT = LPROMPT + KEYL(I) + 1 + END DO + PROMPT = PROMPT(:LPROMPT)//'Subtopic? ' + LPROMPT = LPROMPT + 10 + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,PROMPT(:LPROMPT),HELP_INPUT_LEN) + END IF + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) + IF (IER.AND.HELP_INPUT_LEN.EQ.0) THEN ! If RETURN entered + KEYL(NKEY) = 0 ! Back up one key level + NKEY = NKEY - 1 + END IF + END DO + + IF (.NOT.IER.OR.NKEY.LT.0) THEN ! If CTRL-Z above top level, + CALL LIB$PUT_OUTPUT(' ') ! Skip line + CALL LBR$CLOSE(LINDEX) ! then close library, + RETURN ! and end help session. + END IF + + END DO + + END + + + + INTEGER FUNCTION PUT_OUTPUT(INPUT,INFO,DATA,LEVEL) +C +C FUNCTION PUT_OUTPUT +C +C FUNCTION: +C Output routine for input from LBR$GET_HELP. Displays +C help text on terminal with full screen prompting. +C INPUTS: +C INPUT - Character string. Line of input text. +C INFO - Longword. Contains help flag bits. +C DATA - Longword. Not presently used. +C LEVEL - Longword. Contains current key level. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($HLPDEF)' + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + COMMON /HELP/ HELP_PAGE,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID,OTHERINFO + CHARACTER*80 HELP_INPUT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + + CHARACTER INPUT*(*) + + CHARACTER SPACES*20 + DATA SPACES /' '/ + + OTHERINFO = INFO.AND.HLP$M_OTHERINFO + + IF ((INFO.AND.HLP$M_NOHLPTXT).NE.0) THEN ! Key cannot be found + NEED_ERASE = .FALSE. ! Don't erase screen + IF (HELP_PAGE.EQ.0) THEN ! If first line of help text + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were inputted, as they are + END DO ! not valid, as no match + NKEY = OLD_NKEY ! could be found. + END IF + ELSE IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0.AND.NKEY.GT.0.AND. + & LEVEL.GT.OLD_NKEY.AND.KEY(NKEY)(:KEYL(NKEY)).NE.'*'.AND. + & %LOC(INPUT).NE.0) THEN ! If text contains key names + ! Update if not wildcard search and they are new keys + IF (KEYL(LEVEL).GT.0) THEN ! If key already updated + EXACT = .FALSE. ! Must be more than one match possible + END IF ! so indicate not exact match. + START_KEY = 1 ! String preceeding spaces. + DO WHILE (INPUT(START_KEY:START_KEY).EQ.' ') + START_KEY = START_KEY + 1 + END DO + KEY(LEVEL) = INPUT(START_KEY:) ! Store new key + CALL STR$TRIM(KEY(LEVEL),KEY(LEVEL),KEYL(LEVEL)) ! & key length + ELSE IF (HELP_PAGE.EQ.0) THEN ! If first line of text, + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were just inputted, allowing + END DO ! this routine to fill them. + END IF + + IF (NEED_ERASE) THEN ! Need to erase screen? + IER = LIB$ERASE_PAGE(1,1) ! i.e. start of new topic. + NEED_ERASE = .FALSE. + END IF + + HELP_PAGE = HELP_PAGE + 1 ! Increment screen counter + IF (PAGING.AND.HELP_PAGE.GT.PAGE_LENGTH-2) THEN ! End of page? + HELP_PAGE = 0 ! Reinitialize screen counter + CALL LIB$PUT_OUTPUT(' ') ! Skip line and prompt for next screen + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Press RETURN to continue ... ',HELP_INPUT_LEN) + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) ! Trim input + IF (.NOT.IER.OR.HELP_INPUT_LEN.GT.0) THEN ! CTRL-Z or Text input? + EXACT = .TRUE. ! If more than one match was found and being + ! displayed, text input specifies that the + ! current displayed match is desired. + PUT_OUTPUT = 0 ! Stop any more of current help display. + ELSE ! Else if RETURN entered + IER = LIB$ERASE_PAGE(1,1) ! Erase display + NSPACES = LEVEL*2 ! Number of spaces to indent output + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + ! Key name lines are indented 2 less than help description. + IF (NSPACES.GT.0) THEN ! Add spaces if present to output + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE ! Else just output text. + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + HELP_PAGE = 1 ! Increment page counter. + END IF + ELSE ! Else if not end of page + NSPACES = LEVEL*2 ! Just output text line + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + IF (NSPACES.GT.0) THEN + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_VERSION + + IMPLICIT INTEGER (A-Z) + + CHARACTER VERSION*10,DATE*23 + + CALL READ_HEADER(VERSION,DATE) + + WRITE (6,'(A)') ' BULLETIN Version '//VERSION(:TRIM(VERSION)) + + WRITE (6,'(A)') ' Linked on '//DATE(:TRIM(DATE)) + + RETURN + END + + + + + + + SUBROUTINE TAG(ADD_OR_DEL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + DATA BULL_TAG /.FALSE./,READ_TAG /.FALSE./ + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + IF (.NOT.BULL_TAG) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + IF (.NOT.CLI$PRESENT('NUMBER')) THEN + IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER) + ELSE + CALL DEL_TAG(IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Message was not marked.'')') + END IF + END IF + RETURN + END IF + + CALL OPEN_BULLDIR_SHARED + + IER1 = 0 + DO WHILE (CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + & .NE.%LOC(CLI$_ABSENT).AND.IER1.EQ.0) ! Get the specified messages + + DECODE(LEN_P,'(I)',BULL_PARAMETER) MESSAGE_NUMBER + + CALL READDIR(MESSAGE_NUMBER,IER) ! Get info for bulletin + + IF (IER.NE.MESSAGE_NUMBER+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER1) + ELSE + CALL DEL_TAG(IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Message '',I, + & '' was not marked.'')') MESSAGE_NUMBER + END IF + END IF + END DO + + CALL CLOSE_BULLDIR + + RETURN + +1010 FORMAT(' ERROR: You have not read any message.') +1030 FORMAT(' ERROR: Message was not found.') + + END + + + + SUBROUTINE ADD_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER*12 TAG_KEY + + WRITE (13,IOSTAT=IER) TAG_KEY(FOLDER_NUMBER,MSG_KEY) + + IF (IER.EQ.FOR$IOS_INCKEYCHG) THEN + WRITE (6,'('' Message was already marked.'')') + ELSE IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Unable to add mark.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + END IF + + RETURN + END + + + + + SUBROUTINE DEL_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER*12 TAG_KEY + + DO WHILE (REC_LOCK(IER)) + READ (13,KEYEQ=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) + END DO + IF (IER.NE.0) RETURN + + DELETE (UNIT=13,IOSTAT=IER) + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Unable to delete mark.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + END IF + + RETURN + END + + + + + + SUBROUTINE OPEN_OLD_TAG + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + IF (.NOT.IER) RETURN + + NTRIES = 0 + + DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) + OPEN (UNIT=13,FILE='BULL_MARK:'// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + NTRIES = NTRIES + 1 + END DO + + IF (IER.NE.0.AND.IER.NE.FOR$IOS_FILNOTFOU) THEN + WRITE (6,'('' Unable to open mark file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + RETURN + END IF + + IF (IER.EQ.0) BULL_TAG = .TRUE. + + RETURN + END + + + + + SUBROUTINE OPEN_NEW_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*64 BULL_MARK + + IER = SYS_TRNLNM('BULL_MARK',BULL_MARK) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: BULL_MARK must be defined.'', + & '' See HELP MARK.'')') + RETURN + ELSE + IER1 = SYS_TRNLNM_SYSTEM('BULL_MARK',BULL_PARAMETER) + IF (.NOT.IER1.OR.BULL_MARK.NE.BULL_PARAMETER) THEN + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + CALL DISABLE_PRIVS + IER1 = 0 + END IF + OPEN (UNIT=13,FILE='BULL_MARK:'// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & RECORDSIZE=3, + & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + IF (.NOT.IER1) CALL ENABLE_PRIVS + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot create mark file.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + IER = 0 + ELSE + CALL SYS_GETMSG(IER1) + IER = IER1 + END IF + ELSE + BULL_TAG = .TRUE. + IER = 1 + END IF + END IF + + RETURN + END + + + + CHARACTER*12 FUNCTION TAG_KEY(FOLDER_NUMBER,MSG_KEY) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) MSG_KEY + + CALL LIB$MOVC3(4,FOLDER_NUMBER,%REF(TAG_KEY)) + + CALL GET_MSGKEY(%REF(MSG_KEY),TAG_KEY(5:)) + + RETURN + END + + + + + SUBROUTINE GET_FIRST_TAG(FOLDER_NUMBER,IER,MESSAGE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG + + CHARACTER*12 TAG_KEY,INPUT_KEY + + IF (.NOT.BULL_TAG) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + MSG_KEY = BULLDIR_HEADER + + HEADER = .TRUE. + GO TO 10 + + ENTRY GET_THIS_TAG(FOLDER_NUMBER,IER,MESSAGE) + + DO WHILE (REC_LOCK(IER)) + READ (13,KEY=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) + & INPUT_KEY + END DO + + IF (IER.EQ.0) THEN + UNLOCK 13 + MESSAGE = MSG_NUM + END IF + + RETURN + + ENTRY GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) + + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + + ENTRY GET_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) + + HEADER = .FALSE. + +10 DO WHILE (REC_LOCK(IER)) + READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) + & INPUT_KEY + END DO + + DO WHILE (1) + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),MSG_KEY) + CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER) + END IF + + IF (FOLDER1_NUMBER.NE.FOLDER_NUMBER.OR.IER.NE.0) THEN + IER = 1 + UNLOCK 13 + RETURN + ELSE + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + INQUIRE (UNIT=2,OPENED=IER) + IF (.NOT.IER) THEN + CALL OPEN_BULLDIR + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + ELSE + CALL READDIR_KEYGE(IER) + END IF + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),INPUT_KEY(5:)) + IF (IER.NE.0.AND.MSG_KEY.EQ.INPUT_KEY(5:)) THEN + UNLOCK 13 + MESSAGE = MSG_NUM + IF (HEADER) THEN + MESSAGE = MESSAGE - 1 + MSG_KEY = BULLDIR_HEADER + END IF + IER = 0 + RETURN + ELSE + DELETE (UNIT=13) + DO WHILE (REC_LOCK(IER)) + READ (13,IOSTAT=IER) INPUT_KEY + END DO + END IF + END IF + + END DO + + END + + + + + + + SUBROUTINE FULL_DIR(INDEX_COUNT) +C +C Add INDEX command to BULLETIN, display directories of ALL +C folders. Added per request of a faculty member for his private +C board. Changes to BULLETIN.FOR should be fairly obvious. +C +C Brian Nelson, Brian@uoft02.bitnet (or .ccnet, node 8.2) +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + INCLUDE 'BULLFILES.INC' + INCLUDE 'BULLFOLDER.INC' + INCLUDE 'BULLUSER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /TAGS/ BULL_TAG,READ_TAG + + DATA FOLDER_Q1/0/ + + BULL_POINT = 0 + + IF (NUM_FOLDERS.GT.0.AND..NOT.CLI$PRESENT('RESTART') + & .AND.INDEX_COUNT.EQ.1) THEN + INDEX_COUNT = 2 + DIR_COUNT = 0 + END IF + + IF (INDEX_COUNT.EQ.1) THEN + CALL INIT_QUEUE(FOLDER_Q1,FOLDER1_COM) + + FOLDER_Q = FOLDER_Q1 + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0) THEN + IF (BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + WRITE (6,1000) + WRITE (6,1020) + DO J = 1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + WRITE (6,1030) FOLDER1(:15),F1_NBULL, + & FOLDER1_DESCRIP(:MIN(TRIM(FOLDER1_DESCRIP),59)) + END DO + WRITE (6,1060) + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + INDEX_COUNT = 2 + DIR_COUNT = 0 + READ_TAG = .FALSE. + IF (CLI$PRESENT('MARKED')) READ_TAG = .TRUE. + RETURN + ELSE IF (INDEX_COUNT.EQ.2) THEN + IF (DIR_COUNT.LE.0) THEN + F1_NBULL = 0 + DO WHILE (NUM_FOLDERS.GT.0.AND.F1_NBULL.EQ.0) + NUM_FOLDERS = NUM_FOLDERS - 1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + IF (F1_NBULL.GT.0) THEN + FOLDER_NUMBER = -1 + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) F1_NBULL = 0 + END IF + END DO + + IF (F1_NBULL.EQ.0) THEN + WRITE (6,1050) + INDEX_COUNT = 0 + RETURN + END IF + END IF + + IF (READ_TAG) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + END IF + + CALL DIRECTORY(DIR_COUNT) + IF (DIR_COUNT.GT.0) RETURN + + IF (NUM_FOLDERS.GT.0) THEN + WRITE (6,1040) + ELSE + INDEX_COUNT = 0 + END IF + END IF + + RETURN + +1000 FORMAT (' The following folders are present'/) +1020 FORMAT (' Name Count Description'/) +1030 FORMAT (1X,A15,I5,1X,A) +1040 FORMAT (' Type Return to continue to the next folder...') +1050 FORMAT (' End of folder search.') +1060 FORMAT (' Type Return to continue...') + + END + + + + + SUBROUTINE SHOW_USER +C +C SUBROUTINE SHOW_USER +C +C FUNCTION: Shows information for specified users. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + DIMENSION NOLOGIN_BTIM(2) + + CHARACTER*17 DATETIME + + ALL = CLI$PRESENT('NOLOGIN').OR.CLI$PRESENT('ALL') + & .OR.CLI$PRESENT('LOGIN') + IF (.NOT.ALL) THEN + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + IF (.NOT.IER) TEMP_USER = USERNAME + END IF + + IF (.NOT.SETPRV_PRIV().AND.(ALL.OR.USERNAME.NE.TEMP_USER)) THEN + WRITE (6,'('' ERROR: No privs to user command.'')') + RETURN + END IF + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + + CALL OPEN_BULLUSER_SHARED + + IF (.NOT.ALL) THEN + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + IF (IER.EQ.0) THEN + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + WRITE (6,'('' NOLOGIN set for specified user.'')') + ELSE + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'('' User last logged in at '',A,''.'')') + & DATETIME + END IF + ELSE + WRITE (6,'('' Entry for specified user not found.'')') + END IF + ELSE + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + CALL READ_USER_FILE(IER) + IF (IER.EQ.0.AND.TEMP_USER(:1).NE.':'.AND. + & TEMP_USER(:1).NE.'*') THEN + IER1 = COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM) + IF (.NOT.CLI$PRESENT('LOGIN').AND.IER1.GE.0) THEN + WRITE (6,'('' NOLOGIN set for '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)) + ELSE IF (.NOT.CLI$PRESENT('NOLOGIN').AND.IER1.LT.0) THEN + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'(1X,A,'' last logged in at '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)),DATETIME + END IF + END IF + END DO + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + SUBROUTINE INIT_MESSAGE_ADD(IN_FOLDER,IN_FROM,IN_DESCRIP,IER) +C +C SUBROUTINE INIT_MESSAGE_ADD +C +C FUNCTION: Opens specified folder in order to add message. +C +C INPUTS: +C IN_FOLDER - Character string containing folder name +C IN_FROM - Character string containing name of owner of message. +C If empty, the message is searched for either a +C Reply-to: field or a From: field. If none, then +C the owner of the process is used. If IN_FROM +C ends with a %, it is assumed that it is simply +C the prefix that should be when responding to the +C address via MAIL. I.e. the PMDF interface sends +C IN%, so when the From: field is found, the message +C owner becomes IN%"from-address". +C IN_DESCRIP - Character string containing subject of message. +C If empty, the message is searched for a line +C which starts with "Subj:" or "Subject:". +C OUTPUTS: +C IER - Error status. True if properly connected to folder. +C False if folder not found. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + DATA LPRO/0/ + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + CHARACTER*(*) IN_FOLDER,IN_FROM,IN_DESCRIP + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + COMMON /MAIN_HEADER_INFO/ INEXDATE + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + COMMON /LAST_BUFFER/ OLD_BUFFER + CHARACTER*(LINE_LENGTH) OLD_BUFFER + + COMMON /OLD_BUFFER_FROM/ OLD_BUFFER_FROM + DATA OLD_BUFFER_FROM /.FALSE./ + + BULLCP = 1 ! Inhibit folder cleanup subprocess + + CALL OPEN_BULLFOLDER ! Get folder file + + CALL READ_FOLDER_FILE_KEYNAME(IN_FOLDER(:TRIM(IN_FOLDER)),IER) + + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + RETURN + ELSE + IER = 1 + END IF + + ENTRY INIT_MESSAGE_ADD_BBOARD(IN_FROM,IN_DESCRIP,IER) + + TEXT = .FALSE. ! No text written, as of yet + + FIRST_BREAK = .TRUE. + + IF (FOLDER_NUMBER.EQ.0) THEN ! If GENERAL folder + FOLDER_SET = .FALSE. ! indicate it + ELSE ! Else it's another folder + FOLDER_SET = .TRUE. ! indicate it + END IF + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER ! set folder file names + + ENTRY INIT_MESSAGE_ADD_DIGEST(IN_FROM,IN_DESCRIP,IER) + + CALL OPEN_BULLDIR ! Open directory file + + CALL OPEN_BULLFIL ! Open data file + + CALL READDIR(0,IER1) ! Get NBLOCK + IF (IER1.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + NBLOCK = NBLOCK + 1 + LENGTH = NBLOCK ! Initialize line count + + LEN_FROM = TRIM(IN_FROM) + + IF (IN_FROM(LEN_FROM:LEN_FROM).EQ.'%') THEN ! Just protocol + PROTOCOL = IN_FROM(:LEN_FROM)//'"' + LPRO = LEN_FROM + 1 + LEN_FROM = 0 + END IF + + IF (LEN_FROM.GT.0) THEN + INFROM = IN_FROM + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_FROM(INFROM,LEN_FROM) + ELSE IF (INDEX(INFROM,'%"').GT.0) THEN ! Store any protocol + LPRO = INDEX(INFROM,'%"') + 1 + PROTOCOL = INFROM(:LPRO) + END IF + LEN_DESCRP = TRIM(IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + ELSE + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH,IOSTAT=IER1) + IF (IER1.NE.0) THEN + OPEN (UNIT=3,STATUS='SCRATCH',FILE='BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) + END IF + SAVE_IN_DESCRIP = IN_DESCRIP + SAVE_IN_FROM = ' ' + END IF + + CALL STRIP_HEADER(INPUT,0,IER1) + + OLD_BUFFER = ' ' + + OLD_BUFFER_FROM = .FALSE. + + INEXDATE = .FALSE. + + RETURN + END + + + + SUBROUTINE WRITEOUT_STORED + + CHARACTER*255 BUFFER + + REWIND (UNIT=3) + + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(A)',IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + CALL WRITE_MESSAGE_LINE(BUFFER) + END IF + END DO + + CLOSE (UNIT=3) + + RETURN + END + + + + SUBROUTINE WRITE_MESSAGE_LINE(BUFFER) +C +C SUBROUTINE WRITE_MESSAGE_LINE +C +C FUNCTION: Writes one line of message into folder. +C +C INPUTS: +C BUFFER - Character string containing line to be put into message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + COMMON /MAIN_HEADER_INFO/ INEXDATE + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + DATA FIRST_BREAK/.TRUE./ + + COMMON /STRIP_HEADER/ STRIP + DATA STRIP/.TRUE./ + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + CHARACTER*(*) BUFFER + + COMMON /LAST_BUFFER/ OLD_BUFFER + CHARACTER*(LINE_LENGTH) OLD_BUFFER + + COMMON /OLD_BUFFER_FROM/ OLD_BUFFER_FROM + DATA OLD_BUFFER_FROM /.FALSE./ + + COMMON /DATE/ DATE_LINE + CHARACTER*(LINE_LENGTH) DATE_LINE + + CHARACTER*23 TODAY + + LEN_BUFFER = TRIM(BUFFER) + + IF (LEN_FROM.EQ.0) THEN + WRITE (3,'(A)') BUFFER(:LEN_BUFFER) + IF (OLD_BUFFER_FROM.AND.BUFFER(:1).EQ.' ') THEN + SAVE_IN_FROM = + & SAVE_IN_FROM(:TRIM(SAVE_IN_FROM))//BUFFER + OLD_BUFFER_FROM = .FALSE. + ELSE IF (BUFFER(:5).EQ.'From:'.AND.SAVE_IN_FROM.EQ.' ') THEN + IF (LEN_BUFFER.GE.7) SAVE_IN_FROM = BUFFER(7:) + OLD_BUFFER_FROM = .TRUE. + RETURN + ELSE IF (BUFFER(:9).EQ.'Subject: ') THEN + LDESCR = LEN_BUFFER - 9 + INDESCRIP = BUFFER(10:) + ELSE IF (BUFFER(:9).EQ.'Reply-to:'.OR.LEN_BUFFER.EQ.0) THEN + IF (BUFFER(:9).EQ.'Reply-to:') THEN + IF (LEN_BUFFER.GE.11) SAVE_IN_FROM = BUFFER(11:) + OLD_BUFFER_FROM = .TRUE. + RETURN + ELSE IF (LEN_BUFFER.EQ.0.AND.SAVE_IN_FROM.EQ.' ') THEN + CALL GETUSER(SAVE_IN_FROM) + END IF + LEN_FROM = TRIM(SAVE_IN_FROM) + IF (LEN_FROM.GT.0) THEN + OLD_BUFFER_FROM = .FALSE. + INFROM = SAVE_IN_FROM + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_FROM(INFROM,LEN_FROM) + ELSE IF (INDEX(INFROM,'%"').GT.0) THEN + LPRO = INDEX(INFROM,'%"') + 1 + PROTOCOL = INFROM(:LPRO) + END IF + IF (LDESCR.GT.0) THEN + LEN_DESCRP = LDESCR + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + ELSE + LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = SAVE_IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + END IF + CALL WRITEOUT_STORED + END IF + END IF + OLD_BUFFER_FROM = .FALSE. + RETURN + END IF + IF (BTEST(FOLDER_FLAG,5)) THEN + IF (INDEX(BUFFER,'-------------').EQ.1) THEN + BREAK = .TRUE. + DO I=1,LEN_BUFFER + IF (BUFFER(I:I).NE.'-') BREAK = .FALSE. + END DO + ELSE + BREAK = .FALSE. + END IF + IF (BREAK) THEN + IF (.NOT.FIRST_BREAK) THEN + CALL FINISH_MESSAGE_ADD + CALL INIT_MESSAGE_ADD_DIGEST(INFROM,INDESCRIP,IER) + ELSE + FIRST_BREAK = .FALSE. + END IF + LFROM = 0 + LDESCR = 0 + RETURN + ELSE IF (.NOT.FIRST_BREAK) THEN + IF (LDESCR.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + LDESCR = LEN_BUFFER - 9 + CALL STORE_DESCRP(BUFFER(10:),LDESCR) + IF (LFROM.EQ.0) THEN + LFROM = LEN_FROM + CALL STORE_FROM(INFROM,LFROM) + END IF + ELSE IF (BUFFER(:6).EQ.'From: ') THEN + LFROM = LEN_BUFFER - 6 + IF (LFROM.LE.0) THEN + LFROM = TRIM(SAVE_IN_FROM) + IF (LPRO.GT.0) THEN + LFROM = LFROM + LPRO + 1 + CALL STORE_FROM(PROTOCOL(:LPRO)// + & SAVE_IN_FROM//'"',LFROM) + ELSE + CALL STORE_FROM(SAVE_IN_FROM,LFROM) + END IF + ELSE IF (LPRO.GT.0) THEN + LFROM = LFROM + LPRO + 1 + CALL STORE_FROM(PROTOCOL(:LPRO)// + & BUFFER(7:LEN_BUFFER)//'"',LFROM) + ELSE + CALL STORE_FROM(BUFFER(7:),LFROM) + END IF + END IF + RETURN + END IF + ELSE + RETURN + END IF + END IF + + IF (LEN_BUFFER.EQ.0) THEN ! If empty line + IF (.NOT.STRIP) THEN + CALL STORE_BULL(1,' ',NBLOCK) ! just store one space + ELSE + CALL STRIP_HEADER(BUFFER,LEN_BUFFER,IER) + OLD_BUFFER = ' ' + END IF + ELSE + IF (LEN_DESCRP.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + DESCRIP = BUFFER(INDEX(BUFFER,' ')+1:) + LEN_DESCRP = LEN_BUFFER + END IF + END IF + IF (.NOT.INEXDATE) THEN + IF (BUFFER(:9).EQ.'Expires: '.OR. + & BUFFER(:11).EQ.'X-Expires: ') THEN + I = INDEX(BUFFER,' ')+1 + NODATE = .FALSE. + DO J=I,LEN_BUFFER + IF (BUFFER(J:J).EQ.','.OR.BUFFER(J:J).EQ.'-') THEN + BUFFER(J:J) = ' ' + END IF + END DO + CALL STR$UPCASE(BUFFER(I:),BUFFER(I:)) + NODATE = .TRUE. + I = INDEX(BUFFER,' ')+1 + EXDATE(3:3) = '-' + EXDATE(7:7) = '-' + DO WHILE (I.LE.LEN_BUFFER) + IF (BUFFER(I:I).GE.'0'.AND.BUFFER(I:I).LE.'9') THEN + IF (NODATE) THEN + IF (INDEX(BUFFER(I:),' ').EQ.2) THEN + EXDATE(1:2) = '0'//BUFFER(I:I) + I = I + 1 + ELSE + EXDATE(1:2) = BUFFER(I:I+1) + I = I + 2 + END IF + NODATE = .FALSE. + ELSE + IF (LEN_BUFFER-I.EQ.1.OR. + & INDEX(BUFFER(I:),' ').EQ.3) THEN ! No century? + IER = SYS$ASCTIM(,TODAY,,) ! Get today's date + YEAR = INDEX(TODAY(6:),'-') + EXDATE(8:) = TODAY(6+YEAR:7+YEAR)//BUFFER(I:I+1) + I = I + 2 + ELSE + EXDATE(8:) = BUFFER(I:I+3) + I = I + 4 + END IF + END IF + ELSE IF (BUFFER(I:I).GE.'A'.AND.BUFFER(I:I).LE.'Z') THEN + EXDATE(4:6) = BUFFER(I:I+2) + I = I + 3 + ELSE + I = I + 1 + END IF + END DO + INEXDATE = .TRUE. + END IF + END IF + IF (STRIP) THEN + CALL STRIP_HEADER(BUFFER,LEN_BUFFER,IER) + IF (IER) THEN + OLD_BUFFER = BUFFER + RETURN + ELSE + IF (TRIM(DATE_LINE).GT.0) THEN + CALL STORE_BULL(TRIM(DATE_LINE),DATE_LINE,NBLOCK) + CALL STORE_BULL(1,' ',NBLOCK) + DATE_LINE = ' ' + END IF + IF (TRIM(OLD_BUFFER).GT.0) THEN + CALL STORE_BULL(TRIM(OLD_BUFFER),OLD_BUFFER,NBLOCK) + END IF + STRIP = .FALSE. + END IF + END IF + CALL STORE_BULL(MIN(LEN_BUFFER,LINE_LENGTH),BUFFER,NBLOCK) + TEXT = .TRUE. + END IF + + RETURN + END + + + + + SUBROUTINE FINISH_MESSAGE_ADD +C +C SUBROUTINE FINISH_MESSAGE_ADD +C +C FUNCTION: Writes message entry into directory file and closes folder +C +C NOTE: Only should be run if INIT_MESSAGE_ADD was successful. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + COMMON /STRIP_HEADER/ STRIP + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + COMMON /MAIN_HEADER_INFO/ INEXDATE + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + CHARACTER*23 TODAY + + DIMENSION BIN_EXTIME(2) + + IF (LEN_FROM.EQ.0) THEN + CALL GETUSER(FROM) + INFROM = FROM + LEN_FROM = TRIM(INFROM) + LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = SAVE_IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + CALL WRITEOUT_STORED + END IF + + STRIP = .TRUE. ! Reset strip flag + + CALL FLUSH_BULL(NBLOCK) + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + IF ((BTEST(FOLDER_FLAG,5).AND.LDESCR.EQ.0).OR. ! End of digest msg + & .NOT.TEXT) THEN ! or no message text found + CALL CLOSE_BULLDIR ! then don't add message entry + RETURN + END IF + + EXTIME = '00:00:00.00' + IF (INEXDATE) THEN + IER = SYS_BINTIM(EXDATE//' '//EXTIME,BIN_EXTIME) + IF (IER) THEN ! If good date format + IER = SYS$ASCTIM(,TODAY,,) ! Get today's date + IER = COMPARE_DATE(EXDATE,TODAY(:11)) ! Compare date with today's + IF ((IER.GT.F_EXPIRE_LIMIT.AND.F_EXPIRE_LIMIT.GT.0) ! Too great? + & .OR.IER.LE.0) THEN ! or expiration date not future + INEXDATE = .FALSE. ! Don't use it + END IF + ELSE + INEXDATE = .FALSE. ! Don't use it + END IF + END IF + + IF (.NOT.INEXDATE) THEN + IF (FOLDER_BBEXPIRE.EQ.-1) THEN ! Folder has expiration time? + EXDATE = '5-NOV-2000' ! no, so set date far in future + SYSTEM = 2 ! indicate permanent message + ELSE ! Else set expiration date + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + SYSTEM = 0 + END IF + END IF + + LENGTH = NBLOCK - LENGTH + 1 ! Number of records + + CALL ADD_ENTRY ! Add the new directory entry + + CALL CLOSE_BULLDIR ! Totally finished with add + + CALL UPDATE_FOLDER + + RETURN + END + + + + + SUBROUTINE STORE_FROM(IFROM,LEN_INFROM) + + IMPLICIT INTEGER (A-Z) + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) IFROM + + CHARACTER*(LINE_LENGTH) INFROM + + INFROM = IFROM + + IF (LPRO.GT.0) THEN ! Protocol present? + I = INDEX(INFROM,'%"') + 2 ! Make usable for VMS MAIL + IF (I.EQ.2) THEN + INFROM = PROTOCOL(:LPRO)//INFROM(:LEN_INFROM)//'"' + I = LPRO + 1 + LEN_INFROM = LEN_INFROM + LPRO + 1 + END IF + DO WHILE (I.LT.LEN_INFROM) + IF (INFROM(I:I).EQ.'"') THEN + INFROM(I:I) = '''' + ELSE IF (INFROM(I:I).EQ.'\') THEN + INFROM(I+1:) = '\'//INFROM(I+1:) + LEN_INFROM = LEN_INFROM + 1 + I = I + 1 + ELSE IF (INFROM(I:I).EQ.'''') THEN + INFROM(I:) = '\s'//INFROM(I+1:) + LEN_INFROM = LEN_INFROM + 1 + I = I + 2 + END IF + I = I + 1 + END DO + END IF + + DO I=1,LEN_INFROM ! Remove control characters + IF (INFROM(I:I).LT.' ') INFROM(I:I) = ' ' + END DO + + DO WHILE (LEN_INFROM.GT.0.AND.INFROM(:1).EQ.' ') + INFROM = INFROM(2:) + LEN_INFROM = LEN_INFROM - 1 + END DO + + TWO_SPACE = INDEX(INFROM,' ') + DO WHILE (TWO_SPACE.GT.0.AND.TWO_SPACE.LT.LEN_INFROM) + INFROM = INFROM(:TWO_SPACE)//INFROM(TWO_SPACE+2:) + LEN_INFROM = LEN_INFROM - 1 + TWO_SPACE = INDEX(INFROM,' ') + END DO + + CALL STORE_BULL(6+LEN_INFROM,'From: '//INFROM(:LEN_INFROM), + & NBLOCK) + + IF (INDEX(INFROM,'%"').GT.0) ! Strip off protocol program + & INFROM = INFROM(INDEX(INFROM,'%"')+2:) + + IF (INDEX(INFROM,'::').GT.0) ! Strip off node name + & INFROM = INFROM(INDEX(INFROM,'::')+2:) ! I.e. HOST::USER + + DO WHILE (INDEX(INFROM,'!').GT.0.AND. ! Unix address go backwards. + & INDEX(INFROM,'!').LT.INDEX(INFROM,'@')) + INFROM = INFROM(INDEX(INFROM,'!')+1:) ! I.e. host!user + END DO + + IF (INDEX(INFROM,'<').GT.0) THEN ! Name may be of form + INFROM = INFROM(INDEX(INFROM,'<'):) ! personal-name + END IF + + IF (INDEX(INFROM,'(').GT.0.AND. ! personal-name (net-name) + & INDEX(INFROM,'@').GT.INDEX(INFROM,'(')) THEN + INFROM = INFROM(INDEX(INFROM,'(')+1:) + END IF + + I = 1 ! Trim username to start at first alpha character + DO WHILE (I.LE.LEN_INFROM.AND.(INFROM(I:I).EQ.' '.OR. + & INFROM(I:I).EQ.'%'.OR.INFROM(I:I).EQ.'.'.OR. + & INFROM(I:I).EQ.'@'.OR.INFROM(I:I).EQ.'<'.OR. + & INFROM(I:I).EQ.'"')) + I = I + 1 + END DO + INFROM = INFROM(I:) + + I = 1 ! Trim username to end at a alpha character + DO WHILE (I.LE.12.AND.INFROM(I:I).NE.' '.AND. + & INFROM(I:I).NE.'%'.AND.INFROM(I:I).NE.'.'.AND. + & INFROM(I:I).NE.'@'.AND.INFROM(I:I).NE.'<'.AND. + & INFROM(I:I).NE.'"') + I = I + 1 + END DO + FROM = INFROM(:I-1) + + DO J=2,I-1 + IF ((FROM(J:J).GE.'A'.AND.FROM(J:J).LE.'Z').AND. + & ((FROM(J-1:J-1).GE.'A'.AND.FROM(J-1:J-1).LE.'Z').OR. + & (FROM(J-1:J-1).GE.'a'.AND.FROM(J-1:J-1).LE.'z'))) THEN + FROM(J:J) = CHAR(ICHAR(FROM(J:J))-ICHAR('A')+ICHAR('a')) + END IF + END DO + + RETURN + END + + + + + SUBROUTINE STORE_DESCRP(INDESCRIP,LEN_DESCRP) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) INDESCRIP + + CALL CONVERT_TABS(INDESCRIP,LEN_DESCRP) + + DO I=1,LEN_DESCRP ! Remove control characters + IF (INDESCRIP(I:I).LT.' ') INDESCRIP(I:I) = ' ' + END DO + + DO WHILE (LEN_DESCRP.GT.0.AND.INDESCRIP(:1).EQ.' ') + INDESCRIP = INDESCRIP(2:) + LEN_DESCRP = LEN_DESCRP - 1 + END DO + + IF (LEN_DESCRP.GT.LEN(DESCRIP)) THEN + ! Is length > allowable subject length? + CALL STORE_BULL(6+LEN_DESCRP,'Subj: '// + & INDESCRIP(:LEN_DESCRP),NBLOCK) + END IF + + DESCRIP = INDESCRIP(:MIN(LEN_DESCRP,LEN(DESCRIP))) + + RETURN + END + + + + + + SUBROUTINE STRIP_HEADER(BUFFER,BLEN,IER) +C +C SUBROUTINE STRIP_HEADER +C +C FUNCTION: Indicates whether line is part of mail message header. +C +C INPUTS: +C BUFFER - Character string containing input line of message. +C BLEN - Length of character string. If = 0, initialize subroutine. +C +C OUTPUTS: +C IER - If true, line should be stripped. Else, end of header. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /DATE/ DATE_LINE + CHARACTER*(LINE_LENGTH) DATE_LINE + + CHARACTER*(*) BUFFER + + IF (.NOT.BTEST(FOLDER_FLAG,4).OR.TRIM(BUFFER).EQ.0) THEN + ! If STRIP not set for folder or empty line + IER = .FALSE. + CONT_LINE = .FALSE. + RETURN + END IF + + IF (BLEN.EQ.0) THEN + DATE_LINE = ' ' + CONT_LINE = .FALSE. + END IF + + IER = .TRUE. + + IF (CONT_LINE.AND.(BUFFER(:1).EQ.' '.OR. ! If line is continuation + & BUFFER(:1).EQ.CHAR(9))) RETURN ! of previous header line + + I = 1 + DO WHILE (I.LE.BLEN.AND.BUFFER(I:I).NE.' ') + IF (BUFFER(I:I).EQ.':') THEN ! Header line found + CONT_LINE = .TRUE. ! Next line might be continuation + IF (BUFFER(:5).EQ.'Date:') THEN + DATE_LINE = 'Message sent'//BUFFER(5:BLEN) + IF (DATE_LINE(TRIM(DATE_LINE):).NE.'.') THEN + DATE_LINE(TRIM(DATE_LINE)+1:) = '.' + END IF + END IF + RETURN + ELSE + I = I + 1 + END IF + END DO + + IER = .FALSE. + CONT_LINE = .FALSE. + + RETURN + END diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bullfiles.inc b/decus/vax90b1/bulletin/vlt90b/bulletin/bullfiles.inc new file mode 100644 index 0000000..33021bc --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bullfiles.inc @@ -0,0 +1,28 @@ +C +C FOLDER_DIRECTORY IS THE DIRECTORY THAT FILES FOR FOLDERS THAT +C ARE CREATED ARE KEPT IN. IF YOU WISH TO PREVENT FOLDER CREATION, +C YOU SHOULD MODIFY BULLCOM.CLD TO MAKE THE CREATE COMMAND A PRIVILEGED +C COMMAND (OR SIMPLY REMOVE THE LINES WHICH DEFINE THE CREATE COMMAND). +C +C BBOARD_DIRECTORY IS THE SCRATCH AREA USED BY BBOARD WHEN EXTRACTING +C MAIL. IF IT IS UNDEFINED, BBOARD WILL NOT BE ABLE TO BE USED. +C NOTE THAT EITHER THE BBOARD ACCOUNTS MUST HAVE ACCESS TO THIS DIRECTORY, +C OR THE BBOARD ACCOUNTS MUST BE GIVEN SYSPRV PRIVILEGES TO BE ABLE +C TO WRITE INTO THIS DIRECTORY. ALSO, FOR BBOARD TO WORK, MAKE SURE +C THAT THE SUBPROCESS LIMIT FOR USERS IS AT LEAST 2. YOU WILL ALSO HAVE +C TO INCREASE THE FOLLOWING SYSTEM PARAMETERS WHICH AFFECT DETACHED PROCESES: +C PQL_DPGFLQUOTA = 10000, PQL_DWSQUOTA = 500, & PQL_DFILLM = 30. +C (NOTE: ACCESS CAN BE GIVEN TO THE DIRECTORY FOR THE BBOARD ACCOUNTS USING +C ACLS, I.E. " SET ACL/ACL=(ID=bboard,ACCESS=R+W)/OBJ=FILE directory.DIR") +C + COMMON /FILES/ BULLFOLDER_FILE,FOLDER_DIRECTORY,BBOARD_DIRECTORY + COMMON /FILES/ BULLUSER_FILE,BULLINF_FILE + CHARACTER*80 FOLDER_DIRECTORY /'BULL_DIR:'/ + CHARACTER*80 BBOARD_DIRECTORY /'BULL_DIR:'/ +C +C NOTE: THE FOLLOWING DEFINITIONS ASSUME THAT BULL_DIR IS USED. IF IT +C IS NOT, THEN THEY SHOULD ALSO BE CHANGED. +C + CHARACTER*80 BULLUSER_FILE /'BULL_DIR:BULLUSER.DAT'/ + CHARACTER*80 BULLFOLDER_FILE /'BULL_DIR:BULLFOLDER.DAT'/ + CHARACTER*80 BULLINF_FILE /'BULL_DIR:BULLINF.DAT'/ diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bullfolder.inc b/decus/vax90b1/bulletin/vlt90b/bulletin/bullfolder.inc new file mode 100644 index 0000000..6e31f77 --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bullfolder.inc @@ -0,0 +1,46 @@ +! +! The following 2 parameters can be modified if desired before compilation. +! + PARAMETER BBEXPIRE_LIMIT = 30 ! Maxmimum time limit in days that + ! BBOARDS can be set to. + PARAMETER BBOARD_UPDATE = 15 ! Number of minutes between checks + ! for new BBOARD mail. (Note: Check + ! only occurs via BULLETIN/LOGIN. + ! Check is forced via BULLETIN/BBOARD). + ! NOT APPLICABLE IF BULLCP IS RUNNING. + PARAMETER ADDID = .TRUE. ! Allows users who are not in the + ! rights data base to be added + ! according to uic number. + + PARAMETER FOLDER_FMT = '(A25,A4,A12,A80,A12,3A4,A8,7A4)' + PARAMETER FOLDER_RECORD = 184 ! Must be multiple of 4 + + COMMON /BULL_FOLDER/ FOLDER,FOLDER_NUMBER,FOLDER_OWNER, + & FOLDER_DESCRIP,FOLDER_BBOARD,FOLDER_BBEXPIRE, + & USERB,GROUPB,ACCOUNTB, + & F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,F_EXPIRE_LIMIT, + & F_NEWEST_NOSYS_BTIM,FILLER, + & FOLDER_FILE,FOLDER_SET + INTEGER F_NEWEST_BTIM(2) + INTEGER F_NEWEST_NOSYS_BTIM(2) + LOGICAL FOLDER_SET + DATA FOLDER_SET /.FALSE./, FOLDER/'GENERAL'/ + CHARACTER FOLDER_OWNER*12,FOLDER*25,ACCOUNTB*8 + CHARACTER FOLDER_FILE*80,FOLDER_DESCRIP*80,FOLDER_BBOARD*12 + + CHARACTER*(FOLDER_RECORD) FOLDER_COM + EQUIVALENCE (FOLDER,FOLDER_COM) + + COMMON /BULL_FOLDER1/ FOLDER1,FOLDER1_NUMBER,FOLDER1_OWNER, + & FOLDER1_DESCRIP,FOLDER1_BBOARD,FOLDER1_BBEXPIRE, + & USERB1,GROUPB1,ACCOUNTB1, + & F1_NBULL,F1_NEWEST_BTIM,FOLDER1_FLAG,F1_EXPIRE_LIMIT, + & F1_NEWEST_NOSYS_BTIM,FILLER1, + & FOLDER1_FILE + CHARACTER FOLDER1_OWNER*12,FOLDER1*25,ACCOUNTB1*8 + CHARACTER FOLDER1_FILE*80,FOLDER1_DESCRIP*80,FOLDER1_BBOARD*12 + INTEGER F1_NEWEST_BTIM(2) + INTEGER F1_NEWEST_NOSYS_BTIM(2) + + CHARACTER*(FOLDER_RECORD) FOLDER1_COM + EQUIVALENCE (FOLDER1,FOLDER1_COM) diff --git a/decus/vax90b1/bulletin/vlt90b/bulletin/bulluser.inc b/decus/vax90b1/bulletin/vlt90b/bulletin/bulluser.inc new file mode 100644 index 0000000..2aa4fca --- /dev/null +++ b/decus/vax90b1/bulletin/vlt90b/bulletin/bulluser.inc @@ -0,0 +1,44 @@ +! +! The parameter FOLDER_MAX should be changed to increase the maximum number +! of folders available. Due to storage via longwords, the maximum number +! available is always a multiple of 32. Thus, it will probably make sense +! to specify a multiple of 32 for FOLDER_MAX, as that it what really will be +! the capacity. Note that the default general folder counts as a folder also, +! so that if you specify 64, you will be able to create 63 folders on your own. +! + PARAMETER FOLDER_MAX = 96 + PARAMETER FLONG = (FOLDER_MAX + 31)/ 32 + + PARAMETER USER_RECORD_LENGTH = 28 + FLONG*16 + PARAMETER USER_FMT = '(A12,<4+FLONG*4>A4)' + PARAMETER USER_HEADER_KEY = ' ' + + COMMON /HEADER_INFO/ TEMP_USER,BBOARD_BTIM,NEWEST_BTIM,USERPRIV + COMMON /HEADER_INFO/ SET_FLAG_DEF,BRIEF_FLAG_DEF + COMMON /HEADER_INFO/ NOTIFY_FLAG_DEF + CHARACTER TEMP_USER*12 + DIMENSION BBOARD_BTIM(2),NEWEST_BTIM(2),USERPRIV(FLONG) + DIMENSION SET_FLAG_DEF(FLONG),BRIEF_FLAG_DEF(FLONG) + DIMENSION NOTIFY_FLAG_DEF(FLONG) + + COMMON /BULL_USER/ USERNAME,LOGIN_BTIM,READ_BTIM, + & NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + CHARACTER*12 USERNAME + DIMENSION LOGIN_BTIM(2),READ_BTIM(2) + DIMENSION NEW_FLAG(FLONG) ! Used to indicate new message in folder + ! Now NEW_FLAG(2) contains SET GENERIC days + DIMENSION SET_FLAG(FLONG) ! Bit set indicates READNEW set for folder + DIMENSION BRIEF_FLAG(FLONG) ! Bit set indicates READNEW/BRIEF set + DIMENSION NOTIFY_FLAG(FLONG)! Bit set indicates to broadcast + ! notification when new bulletin is added. + + CHARACTER*(USER_RECORD_LENGTH) USER_ENTRY,USER_HEADER + EQUIVALENCE (USER_ENTRY,USERNAME) + EQUIVALENCE (USER_HEADER,TEMP_USER) + + COMMON /FOLDER_TIMES/ LAST_READ_BTIM(2,FOLDER_MAX) + COMMON /SYS_FOLDER_TIMES/ LAST_SYS_BTIM(2,FOLDER_MAX) + ! Last read times for each folder as stored in BULL_DIR:BULLINF.DAT + + COMMON /NEW_MESSAGES/ NEW_MSG + DIMENSION NEW_MSG(FLONG) ! Flag showing new messages detected diff --git a/decus/vax91b/gce91b/net91b/allmacs.mar b/decus/vax91b/gce91b/net91b/allmacs.mar new file mode 100644 index 0000000..7d32442 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/allmacs.mar @@ -0,0 +1,345 @@ +; +; Name: SETACC.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: Jan 26, 1983 +; +; Purpose: To set the account name of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETACC(account) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; account - Character string containing account name +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETACC + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF + $JIBDEF +; +; local variables: +; + + .PSECT DATA,NOEXE + +NEWACC: .BLKB 12 ; Contains new account name +; +; Executable: +; + .PSECT CODE,EXE,NOWRT ; Executable code + + .ENTRY SETACC,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R6 ; Get number of arguments + CMPL R6,#1 ; Correct number of arguments? + BNEQ 5$ ; If not, return + MOVZBL @4(AP),R6 ; Get size of string + MOVL 4(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#8,NEWACC ; Get new account name string + $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R6 ; Address of current process + MOVL PCB$L_JIB(R6),R6 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + MOVC3 #8,NEWACC,JIB$T_ACCOUNT(R6) ; change account JIB + MOVC3 #8,NEWACC,CTL$T_ACCOUNT ; change account in P1 + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +; +; Name: SETUIC.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: May 31, 1983 +; +; Purpose: To set the UIC of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETUIC(group number, user number) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; group number - longword containing UIC group number +; user number - longword containing UIC user number +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETUIC Set uic + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF +; +; Executable: +; + .PSECT SETUIC_CODE,EXE,NOWRT ; Executable code + + .ENTRY SETUIC,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R2 ; Get number of arguments + CMPL R2,#2 ; Are there 2 arguments + BNEQ 5$ ; If not, return + MOVL @4(AP),R3 ; Group number into R3 + ROTL #16,R3,R3 ; Move to upper half of R3 + ADDL2 @8(AP),R3 ; User number to top half of R3 + $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R2 ; Address of current process + MOVL R3,PCB$L_UIC(R2) ; Set UIC to specified + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +; +; Name: SETUSER.MAR +; +; Type: Integer*4 Function (MACRO) +; +; Author: M. R. London +; +; Date: Jan 26, 1983 +; +; Purpose: To set the Username of the current process (which turns out +; to be the process running this program.) +; +; Usage: +; status = SETUSER(username) +; +; status - $CMKRNL status return. 0 if arguments wrong. +; username - Character string containing username +; +; NOTES: +; Must link with SS:SYS.STB +; + + .Title SETUSER Set uic + .IDENT /830531/ +; +; Libraries: +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ +; +; Global variables: +; + $PCBDEF + $JIBDEF +; +; local variables: +; + + .PSECT SETUSER_DATA,NOEXE + +NEWUSE: .BLKB 12 ; Contains new username +OLDUSE: .BLKB 12 ; Contains old username +; +; Executable: +; + .PSECT SETUSER_CODE,EXE,NOWRT ; Executable code + + .ENTRY SETUSER,^M + CLRL R0 ; 0 is error code + MOVZBL (AP),R8 ; Get number of arguments + CMPL R8,#1 ; Correct number of arguments + BLSS 5$ ; If not, return + MOVZBL @4(AP),R6 ; Get size of string + MOVL 4(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#12,NEWUSE ; Get new username string + CMPL R8,#2 ; Old username given? + BLSS 2$ ; No + MOVZBL @8(AP),R6 ; Get size of string + MOVL 8(AP),R7 ; Get address of descriptor + MOVL 4(R7),R7 ; Get address of string + MOVC5 R6,(R7),#32,#12,OLDUSE ; Get old username string + $CMKRNL_S ROUTIN=20$ ; Must run in kernel mode + TSTL R0 ; If old username is checks with + BEQL 2$ ; present process name, change + MOVL #2,R0 ; to new username, else flag + RET ; error and return +2$: $CMKRNL_S ROUTIN=10$ ; Must run in kernel mode +5$: RET +10$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R7 ; Address of current process + MOVL PCB$L_JIB(R7),R7 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + MOVC3 #12,NEWUSE,JIB$T_USERNAME(R7) ; change username JIB + MOVC3 #12,NEWUSE,CTL$T_USERNAME ; change username in P1 + MOVZWL #SS$_NORMAL,R0 ; Normal ending + RET +20$: .WORD ^M<> ; Entry mask + MOVL @#CTL$GL_PCB,R7 ; Address of current process + MOVL PCB$L_JIB(R7),R7 ; Address of Job Info Block + ; NOTE: MOVC destroys r0-r5 + CMPC R6,OLDUSE,JIB$T_USERNAME(R7) ; change username JIB + RET + + + .TITLE READ_HEADER - Read Image Header + .IDENT /1-001/ + +; This subroutine returns the image identification and link time. +; +; Format: +; +; status.wlc.v = READ_HEADER( ident.wt.ds [,time.wt.ds] ) +; +; Parameters: +; +; ident The image identification text. +; +; time The image link time (text format). + + +; Date By Comments +; 4/10/87 D.E. Greenwood Originally written by John Miano, 24-June-1986 - +; obtained from April 87 DECUS L&T Sig Newsletter + .LIBRARY "SYS$LIBRARY:LIB" + + $DSCDEF + $IHDDEF + $IHIDEF + $SSDEF + +; Argument pointer offsets + + $OFFSET 4,POSITIVE, + + .PSECT READ_HEADER, RD, NOWRT, EXE, LONG + .ENTRY READ_HEADER, ^M< R2, R3, R4, R5, R6, R7, R8, R11 > + + CMPL (AP),#1 ; Make sure that there is at least + BGEQ ENOUGH_ARGUMENTS ; one argument to this routine + MOVL #SS$_INSFARG, R0 + RET + +ENOUGH_ARGUMENTS: + +; Get the identification of the image. + + MOVL @#CTL$GL_IMGHDRBF, R11 ; R11 - Address of image buffer + MOVL (R11), R6 ; R6 - Address of image header + + CVTWL IHD$W_IMGIDOFF(R6), R7 + MOVAB (R6)[R7], R7 ; R7 - Address of ID Block + + CVTBL IHI$T_IMGID(R7),R0 ; Length of the ID string + MOVL IDENT(AP), R8 + MOVC5 R0, (R7), #32, - + DSC$W_LENGTH(R8), @DSC$A_POINTER(R8) + + CMPL (AP), #2 + BGEQ RETURN_TIME + MOVZBL #1, R0 + RET + +RETURN_TIME: + +; Get the time the image was linked and convert it to ASCII + + $ASCTIM_S - + TIMBUF=@TIME(AP), - + TIMADR=IHI$Q_LINKTIME(R7) + + RET + + .MACRO M$$DEFERRED_CALL, IMAGE, NAME, NAME1 +; +; Defer image activation on this routine +; + .PSECT $LOCAL,PIC,CON,REL,LCL,NOSHR,NOEXE,RD,WRT,LONG + IMAGE_'NAME: .ASCID /IMAGE/ + SYMBOL_'NAME: .ASCID /NAME1/ + ADDRESS_'NAME: .BLKL 1 + FIND_'NAME: .LONG 3 + .ADDRESS IMAGE_'NAME + .ADDRESS SYMBOL_'NAME + .ADDRESS ADDRESS_'NAME + .PSECT $CODE,PIC,CON,REL,LCL,SHR,EXE,RD,NOWRT,LONG + .ENTRY 'NAME,^M + CALLG G^FIND_'NAME',G^LIB$FIND_IMAGE_SYMBOL + ADDL3 #2,G^ADDRESS_'NAME,R2 + JMP (R2) + .ENDM M$$DEFERRED_CALL + + M$$DEFERRED_CALL MULTINET_SOCKET_LIBRARY gethostbyname1 gethostbyname + M$$DEFERRED_CALL MULTINET_SOCKET_LIBRARY htons1 htons + M$$DEFERRED_CALL MULTINET_SOCKET_LIBRARY gethostname1 gethostname + + .END +.title Get_AP - Obtains the callers argument pointer +; +; Function: +; +; Returns the address of the argument list for the preceeding Stack Frame +; as a Function Value and loads its only Formal Argument with the value +; stored at that location, the number of argument pointers in the list. +; +; Example: +; +; program Test_AP +; C +; C The following is a FORTRAN example of use of the Get_AP subroutine. +; C +; call Test( 1, 2, 3, 4 ) +; end +; +; subroutine Test +; implicit integer (A-Z) +; Pointer = Get_AP( Count ) +; call List_AP( %val(Pointer) ) +; write(6,10)Count +; return +; 10 format(1X,I2,' arguments were passed to me.') +; end +; +; subroutine List_AP( Pointer ) +; integer Pointer(*) +; write(6,10)Pointer(1) +; return +; 10 format(1X,I2,' arguments were passed to my caller.') +; end +; +; Author: +; +; Chris Hume 7-Sep-1982 +; +$SFDEF ; Stack Frame definitions + +Arg_Pointer = 4 ; Pointer to get argument list adr + +.entry Get_AP,^m<> + + moval @SF$L_Save_AP(fp),r0 ; Get AP for previous Frame. + tstl (ap) ; Check for presence of Our Formal. + beqlu 10$ ; Exit if not present, + moval @Arg_Pointer(ap),r1 ; or if the Address is Null. + beqlu 10$ + movzbl (r0),(r1) ; Copy argument count. +10$: ret + +.end diff --git a/decus/vax91b/gce91b/net91b/bull_ann.txt b/decus/vax91b/gce91b/net91b/bull_ann.txt new file mode 100644 index 0000000..8fc445b --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bull_ann.txt @@ -0,0 +1,412 @@ +From: AITGW::"BULLETIN@ORYANA.PFC.MIT.EDU" 26-SEP-1991 16:10:22.31 +To: ARISIA::EVERHART +CC: +Subj: BULLETIN utility. + +Received: by AITGW.DECnet (utk-mail11 v1.5) ; Thu, 26 Sep 91 16:10:22 EDT +Received: from ORYANA.PFC.MIT.EDU by aitgw.ge.com (5.65/GE Gateway 1.4) + id AA03731; Thu, 26 Sep 91 16:09:04 -0400 +Message-Id: <0C62FFB72B2FC0142E@ORYANA.PFC.MIT.EDU> +Date: Thu, 26 Sep 91 15:20 EST +From: BULLETIN@ORYANA.PFC.MIT.EDU +Subject: BULLETIN utility. +To: ARISIA::EVERHART +X-Envelope-To: EVERHART@ARISIA.dnet.ge.com +X-Vms-To: IN%"EVERHART@ARISIA.dnet.ge.com" + +You are about to receive version 2.06 of the PFC BULLETIN. + +BULLETIN is public domain software. (I will gladly accept +recommendations for new features, not for changes that are due to +"personal" preference.) + +As of V2.0, BULLETIN is able to read USENET NEWS via TCP/IP using either +CMU, MULTINET, UCX, TWG, or via DECNET. It can also serve as a NEWS +gateway for DECNET nodes without direct access to the NEWS server, i.e. a +DECNET node without Internet access will be able to read NEWS. + +NOTE: The following commands can be sent to BULLETIN@ORYANA.PFC.MIT.EDU: + SEND ALL [SINCE time] Sends all bulletin files. + If SINCE time specified, only files created + since that time will be sent. + SEND filename Sends the specified file. + BUGS Sends a list of the latest bug fixes. + HELP or INFO Sends a brief description of BULLETIN. + SUBSCRIBE Subscribes to mailing list for upgrade + notifications. + UNSUBSCRIBE Unsubscribes from mailing list. + +There is also a documentation file written by Chris Tanner from Chalk +River Nuclear Labs which can be used as handout. To obtain this, +request the file BULLETIN.DOC. (This does not describe the NEWS reader +feature, however.) + +NOTE: An old bug might have changed the protection on the BULLETIN data +files. The protection on all data files (i.e. B*.DAT, *.BULLFIL, and +*.BULLDIR) should be (RWED,RWED,,). + +This version includes all necessary modifications to work under VMS +V5.0. However, it will still be necessary to reassemble the ALLMACS.MAR +source under V5 and relink. The V4 version will not be installable +under V5 due to a change in a shared library which BULLETIN uses. +However, relinking by itself will not be enough. You MUST also +reassemble ALLMACS.MAR. If you only relink, BULLETIN can cause your +system to crash (the BULLCP process will do this because it uses the +routines in ALLMACS.MAR). + +If you are running a version of BULLETIN older than 1.52, this version +will modify the format of some of the data files. (This will be done +automatically when the new version is run). After successful +installation, the older versions of these files can be removed. This +format change can take a significant amount of time if the folder is +large. If your site has large folders, it is suggested that the new +version be installed during off peak hours. NOTE: Problems can occur +if the old version of BULLETIN is run after the data files have been +modified. Such a situation is possible on a cluster where each node has +installed the executable separately. To help installation, a new +command procedure INSTALL_REMOTE.COM has been included. This can be +used to install BULLETIN on several nodes from a single node. Read the +comments in the file for information on how to use it. + +NOTE: The BULLCP process should be stopped using the BULLETIN/STOP +command before the new version of BULLETIN is installed. It can then be +restarted using the BULLETIN/STARTUP command. (The INSTALL_REMOTE.COM +command procedure does this automatically for remote nodes.) + +You will be receiving 20 files (NOT NECESSARILY IN THIS ORDER!): + 1) BULLETIN.FOR + 2) BULLETIN0.FOR + 3) BULLETIN1.FOR + 4) BULLETIN2.FOR + 5) BULLETIN3.FOR + 6) BULLETIN4.FOR + 7) BULLETIN5.FOR + 8) BULLETIN6.FOR + 9) BULLETIN7.FOR + 10) BULLETIN8.FOR + 11) BULLETIN9.FOR + 12) BULLETIN10.FOR + 13) BULLETIN11.FOR + 14) ALLMACS.MAR + 15) BULLCOMS1.HLP + 16) BULLCOMS2.HLP + 17) BULLET1.COM + 18) BULLET2.COM + 19) PMDF.COM + 20) MX.COM + +(They will be identified in the SUBJECT header.) BULLET1.COM and +BULLET2.COM are command procedures which when run, will create several +small files. After you run them, you can delete them. If you have PMDF +at your site, you should also run PMDF.COM. Otherwise, you can delete +it. The same applies to MX. Then, read AAAREADME.TXT for BULLETN +installation instructions. + +NOTE: When creating these files (using the EXTRACT command) from the VMS +MAIL utility, you will have to strip off any mail headers that are +present, including blank lines. + MRL@NERUS.PFC.MIT.EDU +-------------------------------------------------------------------------- +Add REPLY option to READNEW feature when reading messages. Also, really fix +the REPLY command, as mentioned in V2.06. 8/11/91 + +V 2.06 + +Added code to keep track of which messages have been read a per message basis. +Added SEEN & UNSEEN commands. Added /SEEN, /UNSEEN, and /UNMARKED to +DIRECTORY, INDEX, READ, and SELECT commands. Modified directory listing to +indicate which messages have been SEEN. 7/31/91 + +Added /NOW to PRINT command. Messages no longer have to be printed one message +at a time. It now works identical to VMS MAIL. 7/31/91 + +Added code to NEWS users when new groups have been created. User will be +alerted when selecting a news group that new groups are present, and will be +instructed to type NEWS/NEWGROUP in order to see them. 7/31/91 + +Added /PRINT to DIRECTORY command to allow printing of messages which are found +by using the DIRECTORY command. 7/31/91 + +Modified directory listing display so that the first and last message in the +folder are now displayed at the top. Fixed bug which truncated very large news +group names. 7/31/91 + +Added FIRST command to read first message found in folder. 7/31/91 + +Modified REPLY command for folders associated with mailing lists, so that the +reply message to the mailing list rather than adding a local message. 7/31/91 + +Modified code to correctly store subject headers from BBOARD mail which are +more than one line long. Previously, the subject would be truncated. 6/18/91 + +V 2.05 + +The MARK code was modified to work with NEWS folders. 6/3/91 + +Added /FOLDER=(folder,[...]) to the SEARCH command to allow searching more than +one folder at a time. 6/13/91 + +NEWS/SUBSCRIBED listing was fixed. If the list could not fit on a single page, +a folder was skipped when the next page was shown. 6/3/91 + +INDEX was fixed. If it was used with the qualifiers /NEW or /MARK, and the +directory listing of a folder was displayed, and then RETURN is entered to +skip to the next folder, the directory display of the next folder would be +incorrect. 6/3/91 + +Fixed broadcast bug. If a message was added with /BROADCAST to a remote folder +from a node in a cluster which was not the node that BULLCP was running on. +The broadcast would appear twice on the cluster. 5/24/91 + +Added code to alert user if message too large to be fully broadcasted. 5/24/91 + +Added code to avoid erroneous notifications of new messages for an empty NEWS +group. Unlike a similar fix in V2.03 which was due to a bug, this fix may not +affect all sites, as it depends on the behavior of the server. 5/22/91 + +Fixed NEWS to FOLDER feed. A recent change broke it. 5/22/91 + +Added /EDIT qualifier for MAIL. 5/20/91 + +Added /HEADER qualifier for LAST, BACK, and CURRENT commands. 5/19/91 + +Added TWG (Wollongong) interface for NEWS. 5/18/91 + +Fixed bug which truncated subject headers of messages created when using REPLY +and RESPOND to messages which have long subject lines. 5/12/91 + +V2.04 + +Added ALWAYS attribute for folders. Any SYSTEM messages in a folder in which +ALWAYS has been set will be displayed every time a user logs in, rather than +just once. Also, non-SYSTEM messages will be displayed continuously (via +whatever mode is set, i.e. READNEW, SHOWNEW, or BRIEF) until it is actually +read. 4/29/91 + +Added capability of controlling the time between updates for BBOARD and NEWS in +BULLCP by defining the logical names BULL_BBOARD_UPDATE or BULL_NEWS_UPDATE to +the number of minutes of desired time in minutes. 4/27/91 + +Added /GROUPS= qualifier to all commands which post to NEWS groups. 4/26/91 + +Fixed bug which prevented SET SHOWNEW or READNEW from working with subscribed +news group folders. 4/25/91 + +V2.03 + +Added /FOLDER to SHOW USER in order to show the latest message that a user +has read in the specified folder. Also added /SINCE and /START (the former +for real folders, the latter for news groups). 4/11/91 + +Fixed logic so that defining BULL_NEWS_ORGANIZATION will override the +definition defined in BULLNEWS.INC. 4/10/91 + +Fixed SEARCH command, as it broke in V2.02 when /EDIT was added to read +message commands. There is a missing QUALIFIER EDIT in BULLCOM.CLD for the +SEARCH verb. /EDIT now works with SEARCH. 4/9/91 + +Fixed bug in BULLCP which prevented the DECNET/INTERNET NEWS gateway software +from working with UCX. 4/9/91 + +Fixed bug caused by V2.00 which caused incorrect listing of message during +BULL/LOGIN for remote folders. 4/3/91 + +Fixed bugs which caused erroneous new message notifications for subscribed +NEWS groups that were empty. 3/27/91 + +V 2.02 + +Include BBOARD support for MX (courtesy of goathunter@wkuvx1.bitnet). + +Changed BBOARD algorithm so that it is now possible to have only one real +BBOARD account, and have all the others be VMS MAIL forwarding entries. +See HELP SET BBOARD MORE_INFO for more info (it's been updated). + +Added hook to allow postings from BULLETIN to a LISTSERV mailing list to use +the BBOARD account from it was subscribed to. See HELP SET BBOARD LISTSERV. + +Fixed many bugs in POST, REPLY, and RESPOND. + +Fixed /ALL for COPY, PRINT, and EXTRACT when using NEWS groups. + +Included RMS optimizer procedure for indexed files to optimize BULLNEWS.DAT +to speed up NEWS updates. Can be used on other files (in particular +BULLINF.DAT) in order to save space. + +Add /EDIT to BACK, NEXT, LAST, and when entering message number. + +Modify ADD/REPLY command to local (non-NEWS) folders so if there are new +messages present, it doesn't reset the newest message count. Previously, +adding a message would reset the user's last read message date to that message +in order to avoid notifying the user of new messages due to the user's own +message. + +Fixed code so that when reading new messages, and if READ/EDIT or DELETE/IMMED- +IATE IS entered, a carriage return will read the next new message. Previously +the wrong message would be displayed. + +V 2.01 + +Fixed many bugs associated with USENET NEWS reading feature. + +Added UCX interface for NEWS. + +Added signature file for POST and RESPOND messages. + +Added capability to specify file name for POST, REPLY, and RESPOND. + +Added the line "In a previous message, wrote:" to the +beginning of a message when /EXTRACT is specified + +Added hook for network mail to run command procedure rather then using +VMS MAIL. BULL_MAILER can be defined to point to the procedure, and it +is called with the username and subject as the parameters. + +V 2.00 + +Added USENET NEWS reading feature. + +V 1.93 + +Fixed bug which wouldn't allow a permanent message to be added by a +non-privileged user in a remote folder (the folder had been setup to allow +permanent messages from non-privileged users, of course). + +Fixed bug which causes the DELETE command not to delete a SHUTDOWN message +without the use of /IMMEDIATE. + +Fixed the algorithm which prevented duplicate notification of messages in +remote folders on different nodes, as duplication was still possible. + +V 1.92 + +Fixed bug which causes BULLCP to loop when trying to cleanup a folder which +has more than 127 identifiers granted access to a folder. Also correct +SHOW FOLDER/FULL, which had a similar problem when trying to display the +identifiers. + +Fix PMDF interface to recognize to recognize PMDF_PROTOCOL. + +V 1.91 + +Disallow SPAWN command for CAPTIVE account. + +Fix MAIL command to correctly allow passing addresses with quotes, i.e. +IN%"""MRL@NERUS.PFC.MIT.EDU""". + +V 1.90 + +SET NOTIFY now works for remote folders. + +Avoid generating notification message due to SET NOTIFY flag if the message +was broadcasted when added using ADD/BROADCAST. + +Bug in DIR/SINCE for remote folders fixed. If no new messages were present, +it would incorrectly show messages. + +Added /FF to EXTRACT command to seperate messages in the file with form feeds. + +Allow specifying CURRENT and LAST when specifying a range of messages for +commands that accept a range, i.e. EXTRACT 1-CURRENT, CURRENT-LAST, etc. + +Open folder files with READONLY when not writing to them in order to avoid +changing modification date, which results in unnecessary backups. + +Modify HELP so that it won't prompt for Subtopic is there is none. + +Prevent screen from being erased after exiting HELP. + +Fix bug which causes CREATE/NOTIFY to crash. + +SET NOTIFY/CLUSTER has been removed. As of VMS V5.2, it is possible to obtain +the list of users logged in to all nodes of a cluster, so this qualifier is no +long necessary. NOTE: You can delete all the BULL_DIR:*.NOTIFY files, as they +are no longer used. + +BULLETIN now will use the editor specified by the SET EDITOR command within +MAIL for editing messages. + +Typing BACK after typing a DIRECTORY command will now show the previous +DIRECTORY display entries rather than reading the previous message. + +Several bugs related to the MARK command were fixed. Also the software has been +optimized so that scanning for MARKed messages should take less time. + +/EXPIRATION added to DIRECTORY command to show expiration rather than creation +date of messages. + +Any BULLETIN interactive command can be executed at DCL level by typing +BULLETIN "command" or BULLETIN "command1;command2;etc.". + +The CHANGE command has been modified so a range of message can be specified, +i.e. /NUMBER=1-10. Also, the code incorrectly misinterpreted /TEXT as meaning +to extract the old text message, whereas it should have meant that only the +text was to be changed. This prevented a user from specifying that only the +text should be changed if that user didn't have editing enabled. This has been +fixed. To eliminate confusing, the /TEXT qualifier on the ADD command has been +removed (previously it was a synonym for /EXTRACT). + +SHOW FOLDER/FULL display of access IDs was fixed to correctly display UICs. + +Removed security hole which occurs if you are using the old method of accessing +a remote node via /NODES (it would have required looking a the sources to find, +which one installer did and was worried about). Because of this, if you use +this old method (i.e. via BULLETIN.COM), the object BULLETIN must be installed +in the NCP database pointing to the file BULLETIN.COM, i.e. the command +"MCR NCP SET BULLETIN FILE directory:BULLETIN.COM NUMBER 0" must be executed +during the system startup. + +Fixed bug in /LOGIN display when erasing page if terminal is hardcopy. No +page would be erased (of course), and the next line outputted would start where +the previous line left off, rather than starting on a new line. + +Added BULLETIN/WIDTH=page_width for users who have BULLETIN/LOGIN in their +login procedure before the terminal is known, and whose default page width is +larger (i.e. 132) than what the terminals are (i.e. 80). + +Added BULLETIN/PGFLQUOTA and /WSEXTENT in order to set those quotas for the +BULLCP process. + +Added ATTACH command. + +Modify SET STRIP so that it saves the date that the message was sent and +leaves it at the to of the message. + +BULLETIN will search BBOARD message headers for a line that starts with +"Expires:" or "X-Expires:", followed by a date (DD MMM YYYY or similar). It if +finds that line, it will use that date as the expiration date of the message. + +Added /REPLY to SEARCH command. Modified so that it's possible to abort out of +a /SUBJECT or /REPLY search using CTRL-C (previous possible only if searching +the text for a string. Also, if you hit CTRL-C at the wrong time, BULLETIN +would abort totally rather than just aborting the search). + +Added /SEARCH= /SUBJ= and /REPLY to the DIRECTORY command. Basically this is +combining the DIRECTORY and SEARCH commands. + +Fixed design flaw which allowed the following to occur: If a folder is a +remote system folder, when BULLETIN/LOGIN was executed, the same messages might +be displayed on both the local and remote nodes. BULLETIN now will know that +the user has seen the message on one node and will not display it if that user +logs in on the other node. + +Optimized code which caused slow display of new messages when executing +BULLETIN/LOGIN without /REVERSE for a remote folder. + +Added /PERMANENT to SET NOTIFY, SHOWNEW, BRIEF, and READNEW. The affect is +that users will not be allowed to change the setting. The main intent here +was to allow the removal ofthe permanent setting of SHOWNEW from the GENERAL +folder. + +Fixed bug which would cause a SYSTEM message not to be shown if SET BRIEF was +selected for that folder, and a non-SYSTEM message was also present. + +Added SET CONTINUOUS_BRIEF. This causes the SET BRIEF setting to show that +there are unread new messages every time BULLETIN/LOGIN is executed, rather +than just the one time. The BRIEF notification code has also been optimized +so that it'll take less time to notify you of new messages. + +A major bug was fixed which was introduced in previous mods to speed up +BULLETIN/LOGIN. The effect is that no notifications will appear for certain +folders via BULLETIN/LOGIN. This would only happen if a folder was removed at +some time. diff --git a/decus/vax91b/gce91b/net91b/bullcoms1.hlp b/decus/vax91b/gce91b/net91b/bullcoms1.hlp new file mode 100644 index 0000000..8b8bd34 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bullcoms1.hlp @@ -0,0 +1,906 @@ +1 ADD +Adds a message to the specified folder. A file can be specified which +contains the message. Otherwise, BULLETIN will prompt for the text. +BULLETIN will ask for an expiration date and a header to contain the +topic of the message. + + Format: + ADD [file-name] +2 /ALL +This option is restricted to privileged users. It is used in conjunction +with the /BROADCAST qualifier. If specified, all terminals are sent the +message. Otherwise, only users are sent the message. +2 /BELL +This option is restricted to privileged users. It is used in conjunction +with the /BROADCAST qualifier. If specified, the bell is rung on the +terminals when the message is broadcasted. +2 /BROADCAST +This option is restricted to privileged users and SYSTEM folders. If +specified, a message is both stored and broadcasted to all users logged +in at the time. If the folder is remote, a message will be broadcast on +all nodes which are connected to that folder, unless /LOCAL is specified. +A node which does not have BULLCP running cannot have a message +broadcasted to it, (even though it is able to create a remote folder). + +See also /ALL and /BELL. +2 /CLUSTER + /[NO]CLUSTER + +This option specifies that broadcasted messages should be sent to all +nodes in the cluster. /CLUSTER is the default. +2 /EDIT + /[NO]EDIT +Determines whether or not the editor is invoked to edit the message +you are adding. /EDIT is the default if you have added /EDIT to your +BULLETIN command line. +2 /EXPIRATION + /EXPIRATION=time + +Specifies the time at which the message is to expire. Either absolute +time: [dd-mmm-yyyy] hh:mm:ss, or delta time: dddd [hh:mm:ss] can be +used. +2 /EXTRACT +Specifies that the text of the previously read message should be included +at the beginning of the new message. The previous message must be in the +same folder. This qualifier is valid only when used with /EDIT. The +text is indented with > at the beginning of each line. This can be +suppressed with /NOINDENT. +2 /FOLDER + /FOLDER=(foldername,[...]) + +Specifies the foldername into which the message is to be added. Does +not change the current selected folder. Folders can be either local or +remote folders. Thus, a nodename can precede the foldername (this +assumes that the remote node is capable of supporting this feature, i.e. +the BULLCP process is running on that node. If it is not, you will +receive an error message). If the the foldername is specified with only +a nodename, i.e. FOO::, the foldername is assumed to be GENERAL. NOTE: +Specifying remote nodes is only possible if that remote node is running +a special BULLCP process. If it isn't, the only way to add messages to +that remote node is via the /NODE command. However, /FOLDER is a much +quicker method, and much more versatile. + +You can specify logical names which translate to one or more folder +names. I.e. $ DEFINE ALL_FOLDERS "VAX1,VAX2,VAX3", and then specify +ALL_FOLDERS after /FOLDER=. Note that the quotation marks are required. + +When using /FOLDER for remote nodes, proxy logins are used to determine +if privileged options are allowed. If they are not allowed, the message +will still be added, but without the privileged settings. +2 /LOCAL +Specifies that when /BROADCAST is specified for a remote folder, the +message is broadcasted ONLY on the local node. +2 /NODES + /NODES=(nodes[,...]) + +Specifies to send the message to the listed DECNET nodes. The BULLETIN +utility must be installed properly on the other nodes. (See +installation notes). You can specify a different username to use at the +other nodes by either using the USERNAME qualifier, or by specifying the +nodename with 2 semi-colons followed by the username, i.e. +nodename::username. If you specify a username, you will be prompted for +the password of the account on the other nodes. + +Additionally, you can specify logical names which translate to one or +more node names. I.e. $ DEFINE ALL_NODES "VAX1,VAX2,VAX3", and then +specify /NODES=ALL_NODES. Note that the quotation marks are required. + +NOTE: It is preferable to use /FOLDER instead of /NODE if possible, +since adding messages via /FOLDER is much quicker. +2 /NOINDENT +See /EXTRACT for information on this qualifier. +2 /PERMANENT +If specified, message will be a permanent message and will never expire. +If an expiration limit is set, then permament is not allowed unless +user has privileges. +2 /SUBJECT + /SUBJECT=description + +Specifies the subject of the message to be added. +2 /SHUTDOWN + /SHUTDOWN[=nodename] +This option is restricted to privileged users. If specified, message +will be automatically deleted after a computer shutdown has occurred. +This option is restricted to SYSTEM folders. + +If the bulletin files are shared between cluster nodes, the message +will be deleted after the node on which the message was submitted from +is rebooted. If you wish the message to be deleted after a different +node reboots, you have the option of specifying that node name. + +NOTE: If the folder is a remote folder, the message will be deleted +after the remote node reboots, not the node from which the message was +added. The nodename cannot be specified with a remote folder. +2 /SYSTEM +This option is restricted to privileged users. If specified, message +is both saved in the folder and displayed in full as a system message +when a user logs in. System messages should be as brief as possible to +avoid the possibility that system messages could scroll off the screen. +This option is restricted to SYSTEM folders. +2 /USERNAME +Specifies username to be used at remote DECNET nodes when adding messages +to DECNET nodes via the /NODE qualifier. +1 ATTACH +Permits you to switch control of your terminal from your current +process to another process in your job. + +The ATTACH command allows you to move quickly between processes that +you have created with the SPAWN command. For example, while you are +editing a file, you can SPAWN a subprocess to read a new message. +Enter the ATTACH command to get back to back to the editing session. +If you want to read another new message, you can use the ATTACH command +to get back to the BULLETN subprocess you already created. + + Format: + + ATTACH [/PARENT] [process-name] +2 Parameters + + process-name + + Indicates the name of the subprocess to which the connection is to + be made. Only the /PARENT qualifier or a process-name may be specified. + +2 Qualifiers + +/PARENT + + Allows you to attach to your process' parent process. + If there is no parent process an error message is printed. + + +2 Examples + + 1. + $ SPAWN BULLETIN + %DCL-S-SPAWNED, process MAGNANI_3 spawned + %DCL-S-ATTACHED, terminal now attached to process MAGNANI_3 + BULLETIN> ATTACH MAGNANI_2 + %DCL-S-RETURNED, control returned to process MAGNANI_2 + $ ATTACH MAGNANI_3 + BULLETIN> + + + This example shows how to spawn subprocesses (MAGNANI_2 and + MAGNANI_3) to move from BULLETIN to DCL back to BULLETIN. The ATTACH + command allows you to transfer control between subprocesses. + + + NOTE + + You always SPAWN a new process and ATTACH to a process that + already exists. +1 BACK +Displays the message preceding the current message. +2 /EDIT +Specifies that the editor is to be used to read the message. This is +useful for scanning a long message. +2 /HEADER + /[NO]HEADER + +Specifies that if a message header exists, the header will be shown. +If /HEADER or /NOHEADER is specified, the setting will apply for all +further reads in the selected folder. The default is /HEADER for non- +NEWS folders, /NOHEADER for NEWS folders. If the SET STRIP command +is set for the folder, it will change the default to be /HEADER. +1 BULLETIN +The BULLETIN utility permits a user to create a message for reading by +all users. Users are notified upon logging in that new messages have +been added, and what the topic of the messages are. Actual reading of +the messages is optional. (See the command SET READNEW for info on +automatic reading.) Messages are automatically deleted when their +expiration date has passed. +1 CHANGE +Replaces or modifies existing stored message. This is for changing part +or all of a message without causing users who have already seen the +message to be notified of it a second time. You can select qualifiers so +that either the message text, expiration date, or the header are to be +changed. If no qualifier is added, the default is that all these parameters +are to be changed. If the text of the message is to be changed, a file can +be specified which contains the text. If the editor is used for changing +the text, the old message text will be extracted. This can be suppressed +by the qualifier /NEW. + + Format: + CHANGE [file-name] +2 /ALL +Makes the changes to all the messages in the folder. Only the expiration +date and message headers can be changed if this qualifier is specified. +2 /EDIT + /[NO]EDIT +Determines whether or not the editor is invoked to edit the message +you are replacing. The old message text is read into the editor unless +a file-name or /NEW is specified. /EDIT is the default if you have +added /EDIT to your BULLETIN command line. +2 /EXPIRATION + /EXPIRATION[=time] + +Specifies the time at which the message is to expire. Either absolute +time: [dd-mmm-yyyy] hh:mm:ss, or delta time: dddd [hh:mm:ss] can be +used. If no time is specified, you will be prompted for the time. +2 /GENERAL +Specifies that the message is to be converted from a SYSTEM message to +a GENERAL message. This only applies to the GENERAL folder. +2 /HEADER +Specifies that the message header is to be replaced. You will be +prompted for the new message description. +2 /NEW +If the editor is to be used for replacing the text of the message, +NEW specifies not to read in the old message text, and that a totally +new text is to be read in. +2 /NUMBER + /NUMBER=message_number[-message_number1] + +Specifies the message or messages to be replaced. If this qualifier is +omitted, the message that is presently being read will be replaced. +A range of messages can be specified, i.e. /NUMBER=1-5. Only the expiration +date and message headers can be changed if a range is specified. + +The key words CURRENT and LAST can also be specified in the range, +in place of an actual number, i.e. CURRENT-LAST, 1-CURRENT, etc. +2 /PERMANENT +Specifies that the message is to be made permanent. +2 /SHUTDOWN[=nodename] +Specifies that the message is to expire after the next computer +shutdown. This option is restricted to SYSTEM folders. +2 /SUBJECT + /SUBJECT=description + +Specifies the subject of the message to be added. +2 /SYSTEM +Specifies that the message is to be made a SYSTEM message. This is a +privileged command and is restricted to SYSTEM folders. +2 /TEXT +Specifies that the message text is to be replaced. +1 COPY +Copies a message to another folder without deleting it from the +current folder. + + Format: + + COPY folder-name [message_number][-message_number1] + +The folder-name is the name of the folder to which the message is to be +copied to. Optionally, a range of messages which are to be copied can be +specified following the folder name, i.e. COPY NEWFOLDER 2-5. + +The key words CURRENT and LAST can also be specified in the range, +in place of an actual number, i.e. CURRENT-LAST, 1-CURRENT, etc. +2 /ALL +Specifies to copy all the messages in the old folder. +2 /GROUPS + /GROUPS=(newsgroup,[...]) + +Valid only if a NEWS group is selected. Specifies to send the message to +the specified NEWS group(s) in addition to the selected NEWS group. +2 /HEADER + /[NO]HEADER + +Valid only if destination folder is a news group. Specifies that header +of message is to be included with the text when the text is copied. +The default is /NOHEADER. +2 /MERGE +Specifies that the original date and time of the copied messages are +saved and that the messages are placed in correct chronological order +in the new folder. This operation is lengthy if the new folder is large. +2 /ORIGINAL +Specifies that the owner of the copied message will be the original owner +of the message. The default is that the copied message will be owned by +the person copying the message. +1 CREATE +Creates a folder of messages. This is similar to the folders in the VMS +MAIL utility. Folders are often created so that messages of a similar +topic are grouped separately, or to restrict reading of certain messages +to specified users. Once created, that message is automatically +selected (see information on SELECT command). The commands that can be +used to modify the folder's characteristics are: MODIFY, REMOVE, SET +ACCESS, SET BBOARD, SET NODE, and SET SYSTEM. + + Format: + CREATE folder-name + +The folder-name is limited to 25 letters and must not include spaces or +characters that are also invalid in filenames (this is because the +folder is stored in a file name created with the folder name). + +NOTE: Creation of folders may be a restricted command if the installer +has elected to install it as such. This is done by modifying +BULLCOM.CLD. +2 /ALWAYS +Specifies that the folder has the ALWAYS attribute. This causes +messages in the folder to be displayed differently when logging in. +SYSTEM messages will be displayed every time a user logs in, rather than +just once. Non-SYSTEM message will also be displayed every time (in +whatever mode is selected, i.e. BRIEF, SHOWNEW, or READNEW) until the +user actually reads that message (or a later one). This feature is +meant for messages which are very important, and thus you want to make +sure they are read. +2 /BRIEF +Specifies that all users automatically have BRIEF set for this folder. +Only a privileged user can use this qualifier. (See HELP SET BRIEF for +more information.) +2 /DESCRIPTION + /DESCRIPTION=description + +Specifies the description of the folder, which is displayed using the +SHOW FOLDER command. If omitted, you are prompted for a description. + +If this folder is to receive messages from a network mailing list +via the BBOARD feature, and you wish to use the POST and RESPOND/LIST +commands, the address of the mailing list should be included in the +description. This is done by enclosing the address using <> and +placing it at the end of the description, i.e. + + INFOVAX MAILING LIST + +If a mailer protocol is needs to be added to the network address in +order for it to be sent by VMS MAIL, i.e. protocol%"address", the +appropriate protocol can be specified by either hardcoding it into the +file BULLNEWS.INC before compiling BULLETIN, or by defining the system +logical name BULL_NEWS_MAILER (it is the same protocol used by the NEWS +feature in order to respond to NEWS messages). The default protocol is +IN%. If desired, you can specify the protocol with the address, i.e. + + INFOVAX MAILING LIST +2 /ID +Designates that the name specified as the owner name is a rights +identifier. The creator's process must have the identifier presently +assigned to it. Any process which has that identifier assigned to it +will be able to control the folder as if it were the folder's owner. +This is used to allow more than one use to control a folder. + +Note: This feature will not work during remote access to the folder. +2 /NODE + /NODE=node + +Specifies that the folder is a remote folder at the specified node. +A remote folder is a folder in which the messages are actually stored +on a folder at a remote DECNET node. The specified node is checked to +see if a folder of the same name is located on that node. If so, the +folder will then be modified to point to that folder. For example if +there was a folder on node A with name INFO, and you issued the command: + CREATE INFO/NODE=A +from node B, then if INFO is selected on node B, you will actually +obtain the folder INFO on node A. In this manner, a folder can be shared +between more than one node. This capability is only present if the BULLCP +process is running on the remote node via the BULL/STARTUP command. +If the remote folder name is different from the local folder name, the +remote folder name is specified using the /REMOTENAME qualifier. + +NOTE: If a message is added to a remote node, the message is stored +immediately. However, a user logging into another node might not be +immediately alerted that the message is present. That information is +only updated every 15 minutes (same algorithm for updating BBOARD +messages), or if a user accesses that folder. Thus, if the folder is +located on node A, and the message is added from node B, and a user logs +in to node C, the BULLETIN login notification might not notify the user +of the message. However, if the message is added with /BROADCAST, the +message will be broadcasted immediately to all nodes. +2 /NOTIFY +Specifies that all users automatically have NOTIFY set for this folder. +Only a privileged user can use this qualifier. (See HELP SET NOTIFY for +more information.) +2 /OWNER + /OWNER=username +Specifies the owner of the folder. This is a privileged command. +See also /ID. +2 /PRIVATE +Specifies that the folder can only be accessed by users who have been +granted access via the SET ACCESS command. Note: This option uses ACLs +and users who are granted access must be entered into the Rights Data Base. +If the RDB does not exist on your system, a privileged user will have to +create it. If a user is not in the RDB, this program will automatically +enter the user into it (unless this feature was disabled during the +compilation of this program). NOTE: See HELP SET ACCESS for more info. +2 /READNEW +Specifies that all users automatically have READNEW set for this folder. +Only a privileged user can use this qualifier. (See HELP SET READNEW for +more information.) +2 /REMOTENAME + /REMOTENAME=foldername +Valid only if /NODE is present, i.e. that the folder is a remote folder. +Specifies the name of the remote folder name. If not specified, it is +assumed that the remote name is the same as the local name. +2 /SHOWNEW +Specifies that all users automatically have SHOWNEW set for this folder. +Only a privileged user can use this qualifier. (See HELP SET SHOWNEW for +more information.) +2 /SEMIPRIVATE +Similar to /PRIVATE, except that the folder is restricted only with +respect to adding or modifying messages. All users can read the folder. +2 /SYSTEM +Specifies that the folder is a SYSTEM folder. A SYSTEM folder is +allowed to have SYSTEM and SHUTDOWN messages added to it. By default, +the GENERAL folder is a SYSTEM folder. This is a privileged command. + +If this is a remote folder, /SYSTEM cannot be specified unless the +folder at the other node is also a SYSTEM folder. +1 Ctrl-C +Except for when BULLETIN is awaiting input from the terminal, a +CTRL-C will cause BULLETIN to abort the execution of any command. If +BULLETIN is waiting for terminal input, a CTRL-C will cause BULLETIN +to return to the BULLETIN> prompt. If for some reason the user wishes +to suspend BULLETIN, CTRL-Y will usually do so. However, this is not +always true, as BULLETIN will ignore the CTRL-Y if it has a data file +opened at the time. (Otherwise it would be possible to put the files +in a state such that they would be inaccessible by other users.) +1 CURRENT +Displays the beginning of the message you are currently reading. If +you are reading a long message and want to display the first part +of the message again, you can enter the CURRENT command. + + Format: + + CURRENT +2 /EDIT +Specifies that the editor is to be used to read the message. This is +useful for scanning a long message. +2 /HEADER + /[NO]HEADER + +Specifies that if a message header exists, the header will be shown. +If /HEADER or /NOHEADER is specified, the setting will apply for all +further reads in the selected folder. The default is /HEADER for non- +NEWS folders, /NOHEADER for NEWS folders. If the SET STRIP command +is set for the folder, it will change the default to be /HEADER. +1 DELETE +Deletes the specified message. If no message is specified, the current +message is deleted. Only the original owner or a privileged user can +delete a message. Note that the message is not deleted immediately, but +its expiration is set 15 minutes in the future. This is to allow a user +to recover the message using the UNDELETE command. If you want the +message deleted immediately, use the /IMMEDIATE qualifier. + + Format: + DELETE [message_number][-message_number1] + +The message's relative number is found by the DIRECTORY command. It is +possible to delete a range of messages by specifying two numbers +separated by a dash, i.e. DELETE 1-5. However, a range cannot be +specified if the folder is remote. + +The key words CURRENT and LAST can also be specified in the range, +in place of an actual number, i.e. CURRENT-LAST, 1-CURRENT, etc. +2 /ALL +Specifies to delete all the messages in the folder. Note: This will +not work for remote folders. Only one message can be deleted from a +remote folder at a time. +2 /IMMEDIATE +Specifies that the message is to be deleted immediately. +2 /NODES + /NODES=(nodes[,...]) + +Specifies to delete the message at the listed DECNET nodes. The BULLETIN +utility must be installed properly on the other nodes. You can specify +a different username to use at the other nodes by either using the +USERNAME qualifier, or by specifying the nodename with 2 semi-colons +followed by the username, i.e. nodename::username. If you specify a +username, you will be prompted for the password of the account on the +other nodes. The /SUBJECT must be specified to identify the specific +message that is to be deleted. + +Additionally, you can specify logical names which translate to one or +more node names. I.e. $ DEFINE ALL_NODES "VAX1,VAX2,VAX3", and then +specify /NODES=ALL_NODES. Note that the quotation marks are required. +2 /SUBJECT + /SUBJECT=subject + +Specifies the subject of the bulletin to be deleted at a remote DECNET +node. The DECNET node must be specified with the /NODE qualifier. +The specified subject need not be the exact subject of the message. +It can be a substring of the subject. This is in case you have forgotten +the exact subject that was specified. Case is not critical either. +You will be notified if the deletion was successful. +2 /USERNAME +Specifies username to be used at remote DECNET nodes when deleting messages +on other DECNET nodes via the /NODE qualifier. +1 DIRECTORY +Lists a summary of the messages. The message number, submitter's name, +date, and subject of each message is displayed. + + Format: + + DIRECTORY [folder] + +If a folder is specified, that folder is selected before the directory +is listed. Unless otherwise specified, listing starts with the first +newest message. If there are no new messages, listing will start at the +first message, or if a message has already been read, it will start at +that message. +2 /ALL +Lists all messages. Used if the qualifiers /MARKED, /UNMARKED, /SEEN, +or /UNSEEN were previously specified. +2 /DESCRIBE +Valid when used with /FOLDERS. Specifies to include description of +folder. +2 /EXPIRATION +Shows the message's expiration date rather than the creation date. +2 /END + /END=message_number + +Indicates the last message number you want to display. +2 /FOLDERS +Lists the available message folders. Shows last message date and number +of messages in folder. An asterisk (*) next to foldername indicates +that there are unread messages in that folder. This will not show +newsgroups. To see newsgroups, use the NEWS command or DIR/NEWS. +2 /MARKED +Lists messages that have been marked (indicated by an asterisk). +This is equivalent to selecting the folder with /MARKED, i.e. only +marked messages will be shown and be able to be read. To see all +messages, use either /ALL, or reselect the folder. +2 /UNMARKED +Lists messages that have not been marked (marked messages are indicated +by an asterisk). Using /UNMARKED is equivalent to selecting the folder +with /UNMARKED, i.e. only unmarked messages will be shown and be able +to be read. To see all messages, use either /ALL, or reselect the +folder. +2 /SEEN +Lists messages that have been seen (indicated by a greater than sign). +Using /SEEN is equivalent to selecting the folder with /SEEN, i.e. only +seen messages will be shown and be able to be read. To see all +messages, use either /ALL, or reselect the folder. +2 /UNSEEN +Lists messages that have not been seen (seen message are indicated by a +greater than sign). Using /UNSEEN is equivalent to selecting the folder +with /UNSEEN, i.e. only unseen messages will be shown and be able to be +read. To see all messages, use either /ALL, or reselect the folder. +2 /NEW +Specifies to start the listing of messages with the first unread +message. +2 /NEWS +Lists the available news groups. This does the same thing as the NEWS +command. See that command for qualifiers which apply. +2 /PRINT +Specifies that the text of the messages which are found by the +DIRECTORY command are to be printed. All qualifiers which are valid +for the PRINT command are valid in conjunction with /PRINT. The list +of messages to be printed will be displayed on the terminal (in +nopaging format). +2 /REPLY +Specifies that only messages which are replies to the current message +are to be displayed. This cannot be used in conjunction with /MARKED. +2 /SEARCH + /SEARCH=[string] + +Specifies that only messages which contain the specified string are +to be displayed. This cannot be used in conjunction with /MARKED. +If no string is specified, the previously specified string is used. +2 /SINCE + /SINCE=date + +Displays a listing of all the messages created on or after the +specified date. If no date is specified, the default is TODAY. +2 /START + /START=message_number + +Indicates the first message number you want to display. For example, +to display all the messages beginning with number three, enter the +command line DIRECTORY/START=3. Not valid with /FOLDER. +2 /SUBJECT + /SUBJECT=[string] + +Specifies that only messages which contain the specified string in it's +subject header are to be displayed. This cannot be used in conjunction +with /MARKED. If no string is specified, the previously specified string +is used. +1 EXIT +Exits the BULLETIN program. +1 EXTRACT +Synonym for FILE command. +1 FILE +Copies the current message to the named file. The file-name parameter +is required. If the file exists, the message is appended to the file, +unless the /NEW qualifier is specified. + + Format: + FILE filename [message_number][-message_number1] + +A range of messages to be copied can optionally be specified, i.e. +FILE 2-5. + +The key words CURRENT and LAST can also be specified in the range, +in place of an actual number, i.e. CURRENT-LAST, 1-CURRENT, etc. +2 /ALL +Copies all the messages in the current folder. +2 /FF +Specifies that a form feed is placed between messages in the file. +2 /HEADER + /[NO]HEADER + +Controls whether a header containing the owner, subject, and date of the +message is written in the file. The default is to write the header. +2 /NEW + +Specifies that a new file is to be created. Otherwise, if the specified +file exists, the file would be appended to that file. +1 FIRST +Specifies that the first message in the folder is to be read. +1 FORWARD +Synonym for MAIL command. +1 Folders +All messages are divided into separate folders. The default folder is +GENERAL. New folders can be created by any user. As an example, the +following creates a folder for GAMES related messages: + +BULLETIN> CREATE GAMES +Enter a one line description of folder. +GAMES + +To see the list of available folders, use DIRECTORY/FOLDERS. To select +a specific folder, use the SELECT command. + +If a user selects a folder and enters the SET READNEW command, that +user will be alerted of topics of new messages at login time, and will +then be given the option of reading them. Similar to READNEW is SHOWNEW, +which displays the topics but doesn't prompt to read them. Even less is +SET BRIEF, which will cause only a one line output indicating that there +are new messages in the folder. There also is the SET NOTIFY option, +which will cause a message to be broadcast to a user's terminal alerting +the user that a new message has been added. Any of these options can be +the default for the folder by using the /DEFAULT switch on the command. + +A folder can be restricted to only certain users, if desired. This is +done by specifying CREATE/PRIVATE. Afterwards, access to the folder is +controlled by the creator by the SET [NO]ACCESS command. If /SEMIPRIVATE +rather than /PRIVATE is specified, all users can read the messages in the +folder, but only those give access can add messages. + +A folder can be converted into a remote folder using CREATE/NODE or SET +NODE. A remote folder is one which points to a folder on a remote DECNET +node. Messages added to a remote node are actually stored on the folder +on the remote node. The BULLCP process (created by BULLETIN/STARTUP) +must be running on the remote node for this option to be used. + +A folder can be specified as a SYSTEM folder, i.e. one in which SYSTEM/ +SHUTDOWN/BROADCAST messages can be added. By default, the GENERAL folder +is a SYSTEM folder (and cannot be changed). One use for this is to create +a remote SYSTEM folder which is shared by all nodes, so that the GENERAL +folder is used for messages pertaining only to the local host, while the +remote folder is used for messages pertaining to all nodes. Another +use is to create a folder for posting SYSTEM messages only meant for a +certain UIC group. This is done by creating a PRIVATE SYSTEM folder, and +giving access to that UIC group. Only users in that UIC group will see +the messages in that folder when they log in. +1 HELP +To obtain help on any topic, type: + + HELP topic +1 INDEX +Gives directory listing of all folders in alphabetical order. If the +INDEX command is re-entered while the listing is in progress, the listing +will skip to the next folder. This is useful for skipping a particular +folder. It also can be used to continue the listing from where one left +off after one has read a message. + + Format: + INDEX +2 /MARKED +Lists messages that have been marked (marked messages are indicated by +an asterisk). This is equivalent to selecting the folder with /MARKED, +i.e. only marked messages will be shown and be able to be read. +2 /UNMARKED +Lists messages that have not been marked (marked messages are indicated +by an asterisk). Using /UNMARKED is equivalent to selecting the folder +with /UNMARKED, i.e. only unmarked messages will be shown and be able +to be read. +2 /SEEN +Lists messages that have been seen (indicated by a greater than sign). +Using /SEEN is equivalent to selecting the folder with /SEEN, i.e. only +seen messages will be shown and be able to be read. +2 /UNSEEN +Lists messages that have not been seen (seen message are indicated by a +greater than sign). Using /UNSEEN is equivalent to selecting the folder +with /UNSEEN, i.e. only unseen messages will be shown and be able to be +read. +2 /NEW +Specifies to start the listing of each folder with the first unread message. +Otherwise, the listing will start with the first message in the folder. +If the INDEX command is re-entered for continuing the listing, /NEW must +be respecified. +2 /RESTART +If specified, causes the listing to be reinitialized and start from the +first folder. +2 /SUBSCRIBE +If specified, lists only those news folders which have been subscribed to. +1 KEYPAD + +--------+--------+--------+--------+ + | PF1 | PF2 | PF3 | PF4 | + | GOLD | HELP | EXTRACT|SHOW KEY| + | |ST NOKEY| FILE |SH KY/PR| + |--------|--------|--------|--------| + | 7 | 8 | 9 | -- | + | ADD | REPLY | MAIL |READ/NEW| + | ADD/EDI|RP/ED/EX|M/NOHEAD|SHOW NEW| + |--------|--------|--------|--------| + | 4 | 5 | 6 | , | + | CURRENT| RESPOND| LAST | DIR/NEW| + |CURR/EDI|RS/ED/EX| | INDEX | + |--------|--------|--------|--------| + | 1 | 2 | 3 |ENTER | + | BACK | PRINT | DIR | | + | NEXT |P/NONOTI|DIR/FOLD| | + |--------+--------|--------| ENTER | + | 0 | . | SELECT | + | SHOW FOLDER/FULL| DELETE | | + | SHOW FLAGS | UNDELE | | + +-----------------+--------+--------+ +1 LAST + +Displays the last message in the current folder. + + Format: + LAST +2 /EDIT +Specifies that the editor is to be used to read the message. This is +useful for scanning a long message. +2 /HEADER + /[NO]HEADER + +Specifies that if a message header exists, the header will be shown. +If /HEADER or /NOHEADER is specified, the setting will apply for all +further reads in the selected folder. The default is /HEADER for non- +NEWS folders, /NOHEADER for NEWS folders. If the SET STRIP command +is set for the folder, it will change the default to be /HEADER. +1 MAIL +Invokes the VAX/VMS Personal Mail Utility (MAIL) to send the message +which you are reading to the specified recipients. + + Format: + + MAIL recipient-name[s] + +The input for the recipient name is exactly the same format as used by +the MAIL command at DCL level. Note that this means when specifying an +address that has quotes, in order to pass the quotes you must specify +triple quotes. I.e. a network address of the form xxx%"address" must +be specified as xxx%"""address""". +2 /EDIT +Specifies that the editor is to be used to edit the message before +mailing it. +2 /HEADER + /[NO]HEADER + +Controls whether a header containing the owner, subject, and date of the +message is written in the mail. The default is to write the header. +2 /SUBJECT + /SUBJECT=text + +Specifies the subject of the mail message. If the text consists of more +than one word, enclose the text in quotation marks ("). + +If you omit this qualifier, the description of the message will be used +as the subject. +1 MARK +Sets the current or message-id message as marked. Marked messages are +displayed with an asterisk in the left hand column of the directory +listing. A marked message can serve as a reminder of important +information. The UNMARK command sets the current or message-id message +as unmarked. + + Format: + + MARK [message-number or numbers] + UNMARK [message-number or numbers] + +NOTE: The list of marked messages for non-NEWS folders are stored in a +file username.BULLMARK, and NEWS folders are stored in +username.NEWSMARK. The files are created in the directory pointed to by +the logical name BULL_MARK. If BULL_MARK is not defined, SYS$LOGIN +will be used. +1 MODIFY +Modifies the database information for the current folder. Only the +owner of the folder or a user with privileges can use this command. + + Format: + + MODIFY +2 /DESCRIPTION +Specifies a new description for the folder. You will be prompted for +the text of the description. + +NOTE: If this folder is to receive messages from a network mailing list +via the BBOARD feature, and you wish to use the POST and RESPOND/LIST +commands, the address of the mailing list should be included in the +description. This is done by enclosing the address using <> and +placing it at the end of the description, i.e. + + INFOVAX MAILING LIST +2 /ID +Designates that the name specified as the owner name is a rights +identifier. The creator's process must have the identifier presently +assigned to it. Any process which has that identifier assigned to it +will be able to control the folder as if it were the folder's owner. +This is used to allow more than one use to control a folder. + +Note: This feature will not work during remote access to the folder. +2 /NAME + /NAME=foldername + +Specifies a new name for the folder. +2 /OWNER + /OWNER=username + +Specifies a new owner for the folder. If the owner does not have +privileges, BULLETIN will prompt for the password of the new owner +account in order to okay the modification. See also /ID. +1 MOVE +Moves a message to another folder and deletes it from the current +folder. + + Format: + + MOVE folder-name [message_number][-message_number1] + +The folder-name is the name of the folder to which the message is to be +be moved to. Optionally, a range of messages which are to be moved can be +specified following the folder name, i.e. COPY NEWFOLDER 2-5. However, +if the old folder is remote, they will be copied but not deleted, as +only one message can be delted from a remote folder at a time. + +The key words CURRENT and LAST can also be specified in the range, +in place of an actual number, i.e. CURRENT-LAST, 1-CURRENT, etc. +2 /ALL +Specifies to move all the messages from the old folder. Note: If the +old folder is remote, they will be copied but not deleted, as only one +message can be deleted from a remote folder at a time. +2 /GROUPS + /GROUPS=(newsgroup,[...]) + +Valid only if a NEWS group is selected. Specifies to send the message to +the specified NEWS group(s) in addition to the selected NEWS group. +2 /HEADER + /[NO]HEADER + +Valid only if destination folder is a news group. Specifies that header +of message is to be included with the text when the text is copied. +The default is /NOHEADER. +2 /MERGE +Specifies that the original date and time of the moved messages are +saved and that the messages are placed in correct chronological order +in the new folder. This operation is lengthy if the new folder is large. +2 /ORIGINAL +Specifies that the owner of the moved message will be the original owner +of the message. The default is that the moved message will be owned by +the person moving the message. +1 NEWS +Displays the list of available news groups. + +Format: + + NEWS [string] + +If the string is specified, lists news groups whose name contains that +string. If the string contains an asterisk, a wild card match will be +applied. I.e. if ALT* is specified, all groups starting with ALT will +be displayed. +2 /NEWGROUP +If specified, will list new news groups that have been added since the +last time that a user has accessed a news group. If there are new +groups, a user will see a message indicating that there are new groups +when the user accesses a news group. +2 /START + /START=string + +If specified, the list will start with the first group which follows +alphabetically after that string. I.e. if /START=B is specified, the +list will start with groups whose name starts with a B. +2 /SUBSCRIBE +If specified, lists only those news folders which have been subscribed to. +An asterisk before the group indicates that new messages are present for +that folder. +1 NEXT +Skips to the next message and displays it. This is useful when paging +through the messages and you encounter a particularly long message +that you would like to skip over. +2 /EDIT +Specifies that the editor is to be used to read the message. This is +useful for scanning a long message. +2 /HEADER + /[NO]HEADER + +Specifies that if a message header exists, the header will be shown. +If /HEADER or /NOHEADER is specified, the setting will apply for all +further reads in the selected folder. The default is /HEADER for non- +NEWS folders, /NOHEADER for NEWS folders. If the SET STRIP command +is set for the folder, it will change the default to be /HEADER. diff --git a/decus/vax91b/gce91b/net91b/bullcoms2.hlp b/decus/vax91b/gce91b/net91b/bullcoms2.hlp new file mode 100644 index 0000000..bd53b60 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bullcoms2.hlp @@ -0,0 +1,1025 @@ +1 POST +If a NEWS group is selected, posts a message to that group. If a normal +folder is selected, sends a message via MAIL to the network mailing list +which is associated with the selected folder. The address of the +mailing list must be stored using either CREATE/DESCRIPTION or +MODIFY/DESCRIPTION. See help on those commands for more information. + + Format: + POST [file-name] +2 /CC + /CC=user[s] +Specifies additional users that should receive the mail message. +2 /EDIT +Specifies that the editor is to be used for creating the mail message. +2 /EXTRACT +Specifies that the text of the message that is being read should be +included in the mail message. This qualifier is valid only when used +with /EDIT. The text of the message is indented with > at the +beginning of each line. This can be suppressed with /NOINDENT. +2 /GROUPS + /GROUPS=(newsgroup,[...]) + +Valid only if a NEWS group is selected. Specifies to send the message to +the specified NEWS group(s) in addition to the selected NEWS group. +2 /NOINDENT +See /EXTRACT for information on this qualifier. +2 /SUBJECT + /SUBJECT=text + +Specifies the subject of the mail message. If the text consists of more +than one word, enclose the text in quotation marks ("). + +If you omit this qualifier, you will prompted for the subject. +2 Signature_file +It is possibly to have the contents of a file be automatically appended +to the end of a message added with the POST and/or the RESPOND command. +This file is known as a signature file, and it typically contains one's +name, address, or perhaps a favorite quote. The name of the file should +be SYS$LOGIN:BULL_SIGNATURE.TXT, and it should be a simple text file. In +order to specify a different file to use, define the logical name +BULL_SIGNATURE to point to the desired file. + +It is possible to specify that portions or all of the signature file are +to be included only for specific folders or news groups. Simply surround +the exclusive text starting with the line "START " and ending +with the line "END", i.e. + +START INFOVAX +This line will only appear in the INFOVAX folder. +END +START MISC.TEST +This line will only appear in the news folder MISC.TEST. +END +This line will appear in all postings. + +Note that an empty line is automatically created to separate the text of +the message and the contents of the signature file. +1 PRINT +Queues a copy of the message you are currently reading (or have +just read) for printing. The file(s) created by the PRINT command +are not released to the print queue until you exit from MAIL. +Multiple messages are concatenated into one print job. The PRINT +command can take optional qualifiers. + + Format: + + PRINT [message_number][-message_number1] + +A range of messages to be printed can optionally be specified, i.e. +FILE 2-5. + +The key words CURRENT and LAST can also be specified in the range, +in place of an actual number, i.e. CURRENT-LAST, 1-CURRENT, etc. + +NOTE: The qualifier /PRINT is present on the DIRECTORY command. This +provides more flexibility than is present with the PRINT command. For +example, if you want to print all messages with a particular string in +it's subject line, DIRECTORY/PRINT/SUBJ would allow you do it. +2 /ALL +Prints all the messages in the current folder. +2 /FORM +Specifies the name or number of the form that you want for the print +job. Codes for form types are installation-defined. You can use the +SHOW QUEUE/FORM command at DCL level to find out the form types +available for your system. Use the SHOW QUEUE/FULL command at DCL +level to find out the name of the mounted form and the default form for +a particular queue. If you specify a form whose stock is different +from the stock of the form mounted on the queue, your job is placed in +a pending state until the stock of the mounted form of the queue is +set equal to the stock of the form associated with the job. (In order +to have your job print, the system manager should stop the queue, +physically change the paper stock on the output device, and restart the +queue specifying the new form type as the mounted form.) +2 /HEADER + /[NO]HEADER + +Controls whether a header containing the owner, subject, and date of the +message is printed at the beginning. The default is to write the header. +2 /NOTIFY + /[NO]NOTIFY + +Indicates that you will be notified by a broadcast message when the +file or files have been printed. If /NONOTIFY is specified, there +is no notification. The default is /NOTIFY. +2 /NOW +Sends all messages that have been queued for printing with the PRINT +command during this session to the printer. +2 /QUEUE + /QUEUE=queue_name + +The name of the queue to which a message is to be sent. If the /QUEUE +qualifier is not specified, the message is queued to SYS$PRINT. +1 READ +Displays the specified message. If you do not specify a message, then +the first time you enter the command, the first message in the folder +will be displayed. However, if there are new messages, the first new +message will be displayed. Each time you enter the command, the next +page, or if there are no more pages, the next message will be displayed. + + Format: + READ [message-number] + +The message's relative number is found by the DIRECTORY command. +If you specify a number greater than the number of messages in the +folder, the last message in the folder will be displayed. + +NOTE: The READ command can be abbreviated by omitting the READ command, +i.e. typing the command "2" is equivalent to "READ 2", and simply +hitting the key is equivalent to "READ". + +BULLETIN normally stores only the latest message that has been read per +folder. It can optionally store and display which messages have been +read in a folder on a per message basis. For information on this, see +the help on the SEEN command. +2 /ALL +Specifies to read all messages. Used after /MARKED, /UNMARKED, /SEEN, +or /UNSEEN had been specified. +2 /EDIT +Specifies that the editor is to be used to read the message. This is +useful for scanning a long message. +2 /HEADER + /[NO]HEADER + +Specifies that if a message header exists, the header will be shown. +If /HEADER or /NOHEADER is specified, the setting will apply for all +further reads in the selected folder. The default is /HEADER for non- +NEWS folders, /NOHEADER for NEWS folders. If the SET STRIP command +is set for the folder, it will change the default to be /HEADER. +2 /MARKED +Specifies to read only messages that have been marked (marked messages +are indicated by an asterisk). Using /MARKED is equivalent to +selecting the folder with /MARKED, i.e. only marked messages will be +shown and be able to be read. To see all messages, use either /ALL, +or reselect the folder. +2 /UNMARKED +Specifies to read only messages that have not been marked (marked +messages are indicated by an asterisk). Using /UNMARKED is equivalent +to selecting the folder with /UNMARKED, i.e. only unmarked messages +will be shown and be able to be read. To see all messages, either +reselect the folder or specify /ALL. +2 /SEEN +Specifies to read only messages that have been seen (indicated by a +greater than sign). Using /SEEN is equivalent to selecting the folder +with /SEEN, i.e. only seen messages will be shown and be able to be +read. To see all messages, use either /ALL, or reselect the folder. +2 /UNSEEN +Specifies to read only messages that have not been seen (seen message +are indicated by a greater than sign). Using /UNSEEN is equivalent to +selecting the folder with /UNSEEN, i.e. only unseen messages will be +shown and be able to be read. To see all messages, use either /ALL, or +reselect the folder. +2 /NEW +Specifies to read the first unread message. +2 /PAGE + /[NO]PAGE + +Specifies that the display of the message will pause when it reaches the +end of the page. If /NOPAGE is specified, the whole message will be +displayed. This is useful for terminals that can store more than one +screenful at a time, and that have a remote printer that can then print +the contents of the terminal's memory. +2 /SINCE + /SINCE=date + +Specifies to read the first message created on or after the specified +date. If no date is specified, the default is TODAY. +1 REMOVE +Removes a folder. Only the owner of a folder or a privileged user can +remove the folder. + + Format: + REMOVE folder-name +1 REPLY +Adds message with subject of message being the subject of the currently +read message with "RE:" preceeding it. Format and qualifiers is exactly +the same as the ADD command except for /NOINDENT and /EXTRACT. + + Format: + REPLY [file-name] +2 /EXTRACT +Specifies that the text of the message should be included in the reply +mail message. This qualifier is valid only when used with /EDIT. The +text of the message is indented with > at the beginning of each line. +This can be suppressed with /NOINDENT. +2 /NOINDENT +See /EXTRACT for information on this qualifier. +1 RESPOND +Invokes the VAX/VMS Personal Mail Utility (MAIL) to send a reply mail +message to the owner of the currently read message. + + Format: + RESPOND [file-name] + +If you wish to use another method for sending the mail, define BULL_MAILER +to point to a command procedure. This procedure will then be executed in +place of MAIL, and the parameters passed to it are the username and subject +of the message. +2 /CC + /CC=user[s] +Specifies additional users that should receive the reply. +2 /EDIT +Specifies that the editor is to be used for creating the reply mail +message. +2 /EXTRACT +Specifies that the text of the message should be included in the reply +mail message. This qualifier is valid only when used with /EDIT. The +text of the message is indented with > at the beginning of each line. +This can be suppressed with /NOINDENT. +2 /GROUPS + /GROUPS=(newsgroup,[...]) + +Valid only if a NEWS group is selected and /LIST is present. Specifies +to send the message to the specified NEWS group(s) in addition to the +selected NEWS group. +2 /LIST +Specifies that the reply should also be sent to the network mailing list +associated with the folder. The mailing list address should be stored +in the folder description. See CREATE/DESCRIPTION or MODIFY/DESCRIPTION +for more informaton. +2 /NOINDENT +See /EXTRACT for information on this qualifier. +2 /SUBJECT + /SUBJECT=text + +Specifies the subject of the mail message. If the text consists of more +than one word, enclose the text in quotation marks ("). + +If you omit this qualifier, the description of the message will be used +as the subject preceeded by "RE: ". +1 QUIT +Exits the BULLETIN program. +1 SEARCH +Searches the currently selected folder for the message containing the +first occurrence of the specified text string. + + Format: + + SEARCH [search-string] + +The search starts from the first message in the current folder. The +search includes both the text of the message, and the description header. +If a "search-string" is not specified, a search is made using the +previously specified string, starting with the message following the +one you are currently reading (or have just read). Once started, a +search can be aborted by typing a CTRL-C. +2 /EDIT +Specifies that the editor is to be used for reading the message. +2 /FOLDER + /FOLDER=(folder,[...]) + +Specifies a list of folders to be searched. The search will start by +selecting the first folder in the list and searching the messages for +a match. If, during a search, no more matches or messages are found, +the next folder in the list is automatically selected. The presently +selected folder can be included in the search by specifying "" as the +first folder in the list. +2 /REPLY +Specifies that messages are to be searched for that are replies to the +currently read message, or the message specified by /START. Replies are +messages which have subject of the original message prefaced by "Re:". +2 /REVERSE +Specifies that the messages are to be searched in reverse order. If +no starting message is specified, the search is started from the last +message. +2 /START + /START=message_number + +Specifies the message number to start the search at. +2 /SUBJECT +Specifies that only the subject of the messages are to be searched. +1 SEEN +Sets the current or message-id message as seen. This allows you to keep +track of messages on a per message basis. Seen messages are displayed +with a greater than sign in the left hand column of the directory +listing. Once you have used the SEEN command once, messages will be +automatically be set as being SEEN when they are read. The UNSEEN +command sets the current or message-id message as unseen. + + Format: + + SEEN [message-number or numbers] + UNSEEN [message-number or numbers] + +Keeping track of seen messages requires very little overhead for NEWS +folders. However, there is a moderate overhead for regular non-NEWS +folders. If you have used the SEEN command and wish to disable the +automatic marking of messages in regular folders as SEEN when they are +read, type the command SEEN/NOREAD. To reenable, simply use the SEEN +command again. + +NOTE: The list of SEEN messages for non-NEWS folders are stored in a +file username.BULLMARK, and NEWS folders are stored in +username.NEWSMARK. The files are created in the directory pointed to by +the logical name BULL_MARK. If BULL_MARK is not defined, SYS$LOGIN +will be used. +1 SELECT +Selects a folder of messages. See HELP Folders for a description of a +folder. Once a folder has been selected, all commands, i.e. DIRECTORY, +READ, etc. will apply only to those messages. Use the CREATE command to +create a folder. Use the DIRECTORY/FOLDER command to see the list of +folders that have been created. + + Format: + + SELECT [node-name::][folder-name] + +The complete folder name need not be specified. BULLETIN will try to +find the closest matching name. I.e. INFOV can be used for INFOVAX. + +Omitting the folder name will select the default general messages. + +The node name can be specified only if the remote node has the special +BULLCP process running (invoked by BULLETIN/STARTUP command.) + +After selecting a folder, the user will notified of the number of unread +messages, and the message pointer will be placed at the first unread +message. + +BULLETIN automatically determines if the selcted name is a NEWS group by +detecting if a period is present in the name being specified, as most +NEWS groups contain a period, whereas a real folder cannot. A few +special NEWS groups, i.e. JUNK and CONTROL, do not contain a period. If +desired, you can select these groups by enclosing them in double quotes +("), and typing the name in lower case. +2 /MARKED +Selects only messages that have been marked (indicated by an asterisk). +After using /MARKED, in order to see all messages, the folder will have +to be reselected. +1 SET +The SET command is used with other commands to define or change +characteristics of the BULLETIN Utility. + + Format: + + SET option +2 ACCESS +Controls access to a private folder. A private folder can only be +selected by users who have been granted access. Only the owner of that +folder is allowed to grant access. + + Format: + + SET [NO]ACCESS id-name [folder-name] + +The id-name can be one or more ids from the system Rights Database for +which access is being modified. It can also be a file name which +contains a list of ids. For more information concerning usage of +private folders, see HELP CREATE /PRIVATE. NOTE: Access is created via +ACLs. If a user's process privileges are set to override ACLs, that +user will be able to access the folder even if access has not been +granted. + +It is suggested that if you plan on granting access to many users, that +you create an id using the AUTHORIZE utility and then use the SET ACCESS +command to grant access to that id. Then, you can use the GRANT/ID +command in AUTHORIZE to grant the id to users, and this will give those +users access to the folder. This is preferred because of problems with +running into system quota when checking for acls on a file with a large +amount of acls. It is also means that you don't have to remember to +remove the access for that user from a folder if that user is removed +from the system. + +A user with BULLETIN privileges (see HELP SET PRIV) will be able to +select a protected folder regardless of the access settings. However, a +user without explicit access will not receive login notifications of new +messages, and thus will not be able to set any login flags. (NOTE: If +such a user selects such a folder and then uses SET ACCESS to grant him +or herself access, the user must reselect the folder in order for the +new access to take affect in order to be able to set login flags.) +3 id +The id-name can be one or more ids contained in the system Rights +Database. This includes usernames and UICs. A UIC that contains a +comma must be enclosed in quotes. UICs can contain wildcards, i.e. +"[130,*]". Note that by default, a process is given the process rights +id SYS$NODE_nodename, where nodename is the decnet nodename. Thus, by +specifing this id, a folder can be restricted to a specific node, which +is useful when the folder is shared among nodes in a cluster. + +Alternatively, the id-name can be a filename which contains a list of +ids. The filename should be preceeded by a "@". If the suffix is not +specified, it will be assumed that the suffix is ".DIS" . +3 /ALL +Specifies that access to the folder is granted to all users. If /READ +is not specified, the folder will no longer be private. If /READ is +specified, all users will have read access, but only privileged users +will have write access (of course non-privileged users can gain access +via a later SET ACCESS command.) + +Format: + + SET ACCESS /ALL [folder-name] +3 /READ +Specifies that access to the folder will be limited to being able to +read the messages. +3 Warning +If a user logs in after a private folder has been created but before +being given access, and then is given access, any defaults that the +folder has, i.e. /BRIEF, /READNEW, & /NOTIFY, will not be set for that +user. This is because if the id is not a username, it becomes an +extremely lengthy operation to check each user to see if have that id +assigned to them. The alternative is to set the defaults for all users +after every SET ACCESS, but that might cause problems with users who +have manually reset those defaults. The correct solution requires a +large programming modification, which will be done in a later version. +2 ALWAYS +Specifies that the selected folder has the ALWAYS attribute. This +causes messages in the folder to be displayed differently when logging +in. SYSTEM messages will be displayed every time a user logs in, rather +than just once. Non-SYSTEM message will also be displayed every time +(in whatever mode is selected, i.e. BRIEF, SHOWNEW, or READNEW) until +the user actually reads that message (or a later one). This feature is +meant for messages which are very important, and thus you want to make +sure they are read. + + Format: + + SET [NO]ALWAYS +2 BBOARD +Specifies a username to be used as a BBOARD destination. Mail which is +sent to that user are converted into messages. This command will apply +to the selected folder, and each folder can have its own BBOARD. Only +privileged users or owners of the folders can set BBOARD. Note: The +specified account must have the DISUSER flag specified in the system +authorization file, and it either must be given SYSPRV privileges, or +the scratch bboard_directory (specified when compiling BULLETIN) must +have world rwed protection. Also, certain system parameters which +affect detached subprocesses are usually too low for the subprocess +which is spawned to read the mail. The parameters and the suggested +values are: PQL_DPGFLQUOTA = 10000, PQL_DWSQUOTA = 500, and PQL_DFILLM += 30. If you are not using the BULLCP process, the subprocess limit for +users must be at least 2. + + Format: + + SET BBOARD [username] + +BBOARD cannot be set for remote folders. See also the commands SET +STRIP and SET DIGEST for options on formatting BBOARD messages. + +If BULLCP is running, BBOARD is updated every 15 minutes. If you want +to length this period, define BULL_BBOARD_UPDATE to be the number of +minutes, between updates. I.e. DEFINE/SYSTEM BULL_BBOARD_UPDATE "30" +will cause the updates to be don every 30 minutes. + +NOTE: If you want to control the expiration date on a per message basis, +you can do so by adding a special header line to the message. The form +is Expires: or X-Expires: followed by the date in the form DD MMM YYYY. +The time will always be 00:00, even if the time is specified on the line. +3 /EXPIRATION + /EXPIRATION=days + /NOEXPIRATION + +Specifies the number of days the message created by the BBOARD is to be +retained. The default is 14 days. The highest limit that can be +specified is 30 days. This can be overridden by a user with privileges. +If /NOEXPIRATION is specified, messages will become permanent. + +NOTE: This value is the same value as specified by SET DEFAULT_EXPIRE. +If one is changed, the other will change also. +3 /SPECIAL +Specifies that the input should be processed using a special command +procedure, and not to use the simple VMS MAIL to message conversion. +Specifying a username is optional. To remove this feature, you must +either SET NOBBOARD, or SET BBOARD and specify a username. See +installation notes for exactly how to use this feature. +3 /VMSMAIL +Used in conjunction with /SPECIAL. If /SPECIAL and a username is +specified, and the conversion still takes its input from VMS MAIL, then +the VMS system mail file is checked to see if new mail exists for the +specified user before running the command procedure. This saves time +and avoids creating subprocesses. (Useful if input is digest format.) +3 Listserv +For a LISTSERV mailing list, only a subscribed user can post to it. If +the BBOARD account is subscribed to the list in order for BULLETIN to +receive the list, only the BBOARD account will be able to post to it. +This problem is solved by placing the word LISTSERV in the folder +description line. Then, messages sent to the mailing list by the POST +command will be sent from the BBOARD account rather than from the user's +account. For example, the folder description might be: + +FAKE MAILING LIST LISTSERV. + +If you have PMDF or MX installed, the corresponding logical name +PMDF_REPLY_TO or MX_REPLY_TO will be temporarily defined in order to add +a REPLY-TO: line to the message header to display the real user's +address. + +Users who use the method described in HELP SET BBOARD MORE_INFORMATION +should note the following: When using this LISTSERV feature, the BBOARD +account must be a real account, not simply a VMS MAIL forwarding entry. +Mail can only be sent from a real account. However, if mail forwarding +is set for that the account, the account does not need a real directory +or a unique uic, since it will not need space to store mail. + +In order to be able to send LISTSERV commands from the BBOARD account +without having to actually login to the BBOARD account, there is a +utility included with BULLETIN called SETUSER. This requires privileges +to use. After compiling it, use the link command: + + LINK SETUSER,SYS$SYSTEM:SYS.STB/SELECT + +When you run it, it will prompt for a username. After verifying that +the given username is a valid account, it will then change your +process's username. You can then send mail from that account. + +If you are using PMDF or MX, and wish to use this feature, you can still +do so by setting BBOARD. As long as the BBOARD account is not a real +account, it will work properly, even though the mail feed is not really +coming from the BBOARD account. + +In order to find out if the LISTSERV mailing list will accept posts only +from subscribed users, send the command 'REV listname'. This will +retrieve the file listname.LIST. It begins with a list of keywords. If +the keyword 'send' is set to 'public', you don't need to set the +LISTSERV switch. If it's set to 'private', you do. For a description +of the keywords and the meaning of their settings, send any LISTSERV the +command 'INFO KEY'. Note that the 'listname.LIST' files include a list +of owners and subscribers. If 'send' is set to 'owners', then neither +the public nor the subscribers can post to the list. + +3 More_information +If more than one folder is to have a BBOARD setting, only one of the +BBOARD names need be a real account. All other names could be names +whose mail is forwarded to the real account. BULLETIN will then +determine from the mail header which folder the mail is to be sent to. +Forwarding can be enabled for any name within MAIL by the command: + + MAIL> SET FORWARD/USER=from_name to_name + +Any mail sent to FROM_NAME will be forwarded to TO_NAME. Thus, only +TO_NAME need be a real account. For example, if you have INFOVAX and +LASER-LOVERS folders, you need create only a INFOVAX account, and then +forward LASER-LOVERS mail to INFOVAX within mail using the command SET +FORWARD/USER=LASER-LOVERS INFOVAX. You would then do a SET BBOARD +INFOVAX for the INFOVAX folder, and SET BBOARD LASER-LOVERS for the +LASER-LOVERS folder. This method will speed up the BBOARD conversion, +since mail need be read only from one account. NOTE: Folders that have +the /SPECIAL set on their BBOARD accounts cannot have their mail +forwarded to BBOARD accounts that don't have /SPECIAL set. Folders of +the same type, i.e. that use the same /SPECIAL command procedure, must +be grouped separately. + +The BBOARD account must match the mailing list name. If you prefer not +to have them match, then you must include the actual address of the +mailing list in the folder description in the format described under +HELP CREATE /DESCRIPTION. +2 BRIEF +Controls whether you will be alerted upon logging that there are new +messages in the currently selected folder. A new message is defined as +one that has been created since the last time you logged in or accessed +BULLETIN. Note the difference between BRIEF and READNEW. The latter +causes a listing of the description of the new messages to be displayed +and prompts the user to read the messages. Setting BRIEF will clear a +READNEW setting (and visa versa). + + Format: + + SET [NO]BRIEF +3 /ALL +Specifies that the SET [NO]BRIEF option is the default for all users for +the specified folder. This is a privileged qualifier. +3 /DEFAULT +Specifies that the [NO]BRIEF option is the default for the specified +folder. This is a privileged qualifier. It will only affect brand new +users (or those that have never logged in). Use /ALL to modify all users. +3 /FOLDER + /FOLDER=foldername + +Specifies the folder for which the option is to modified. If not +specified, the selected folder is modified. Valid only with NOBRIEF. +3 /PERMANENT + /[NO]PERMANENT + +Specifies that BRIEF is a permanent flag and cannot be changed by the +individual, except if changing to SHOWNEW or READNEW. This is a +privileged qualifier. +2 CONTINUOUS_BRIEF +Specifies that if BRIEF is set for a folder, and there are new messages, +the notification message "there are new messages" will be displayed every +time when logging in, until the new messages are read. Normally, the +BRIEF setting causes notification only at the first time that new messages +are detected. + + Format: + + SET [NO]CONTINUOUS_BRIEF + +NOTE: Both SET GENERIC and SET CONTINUOUS_BRIEF cannot be set for the +same user. +2 DEFAULT_EXPIRE +Specifies the number of days the message created by BBOARD (or direct +PMDF path) is to be retained. The default is 14 days. The highest +limit that can be specified is 30 days. This can be overridden by a +user with privileges. + +This also specifies the default expiration date when adding a message. +If no expiration date is entered when prompted for a date, or if +prompting has been disabled via SET NOPROMPT_EXPIRE, this value will be +used. + + Format: + + SET DEFAULT_EXPIRE days + +If -1 is specified, messages will become permanent. If 0 is specified, +no default expiration date will be present. The latter should never be +specified for a folder with a BBOARD, or else the messages will +disappear. + +NOTE: This value is the same value that SET BBOARD/EXPIRATION specifies. +If one is changed, the other will change also. +2 DIGEST +Affect only messages which are added via either the BBOARD option, or +written directly from a network mailing program (i.e. PMDF). Several +mailing lists use digest format to send their messages, i.e. the +messages are concatenated into one long message. If DIGEST is set, the +messages will be separated into individual BULLETIN messages. + + Format: + + SET [NO]DIGEST + +The command SHOW FOLDER/FULL will show if DIGEST has been set. + +2 DUMP +Specifies that messages deleted from the selected folder are written +into a dump (or log) file. The name of the log file is foldername.LOG, +and it is located in the folder directory. + + Format: + + SET [NO]DUMP + +The command SHOW FOLDER/FULL will show if dump has been set. (NOTE: +SHOW FOLDER/FULL is a privileged command.) +2 EXPIRE_LIMIT +Specifies expiration limit that is allowed for messages. Non-privileged +users cannot specify an expiration that exceeds the number of days +specified. Privileged users can exceed the limit. + + SET [NO]EXPIRE_LIMIT [days] + +The command SHOW FOLDER/FULL will show the expiration limit, if one +exists. (NOTE: SHOW FOLDER/FULL is a privileged command.) +2 FOLDER +Select a folder of messages. Identical to the SELECT command. See help +on that command for more information. + + Format: + + SET FOLDER [node-name::][folder-name] +3 /MARKED +Selects messages that have been marked (indicated by an asterisk). +After using /MARKED, in order to see all messages, the folder will have +to be reselected. +2 GENERIC +Specifies that the given account is a "generic" account, i.e used by +many different people. If an account is specified as GENERIC, new +messages placed in the GENERAL folder will be displayed upon logging in +for a specific number of days, rather than only once. The default +period is 7 days. This command is a privileged command. + + Format: + + SET [NO]GENERIC username + +NOTE: Both SET GENERIC and SET CONTINUOUS_BRIEF cannot be set for the +same user. +3 /DAYS + /DAYS=number_of_days + +Specifies the number days that new GENERAL messages will be displayed +for upon logging in. +2 KEYPAD +Controls whether the keypad has been enabled such that the keys on the +keypad correspond to command definitions. These definitions can be seen +via the SHOW KEYPAD command. The default is NOKEYPAD unless the /KEYPAD +qualifier has been added to the BULLETIN command line. + + Format: + + SET [NO]KEYPAD +2 LOGIN +Controls whether the specified user will be alerted of any messages, +whether system or non-system, upon logging in. If an account has the +DISMAIL flag set, SET NOLOGIN is automatically applied to that account +during the first time that the account logs in. However, this will not +occur if DISMAIL is set for an old account. Additionally, removing the +DISMAIL flag will not automatically enable LOGIN. (The reason for the +above was to avoid extra overhead for constant checking for the DISMAIL +flag.) This command is a privileged command. + + Format: + + SET [NO]LOGIN username +2 NODE +Modifies the selected folder from a local folder to a remote folder. A +remote folder is a folder in which the messages are actually stored on a +folder at a remote DECNET node. The SET NODE command specifies the name +of the remote node, and optionally the name of the remote folder. If +the remote folder name is not included, it is assumed to be the same as +the local folder. When the command is executed, the selected folder +will then point to the remote folder. If there were messages in the +local folder, they will be deleted. This feature is present only if the +BULLCP process is running on the remote node. + + Format: + SET NODE nodename [remotename] + SET NONODE + +NOTE: If one node adds a message to a remote node, other nodes connected +to the same folder will not immediately be aware of the new message. +This info is updated every 15 minutes, or if a user accesses that +folder. +3 /FOLDER + /FOLDER=foldername + +Specifies the folder for which the node information is to modified. +If not specified, the selected folder is modified. +2 NOTIFY +Specifies whether you will be notified via a broadcast message when a +message is added to the selected folder. + + Format: + + SET [NO]NOTIFY + +In a cluster, if the logical name MAIL$SYSTEM_FLAGS is defined so that +bit 1 is set, users will be notified no matter which node they are logged +in to. If you wish to disable this, you should define BULL_SYSTEM_FLAGS +so that bit 1 is cleared. +3 /ALL +Specifies that the SET [NO]NOTIFY option is the default for all users for +the specified folder. This is a privileged qualifier. +3 /DEFAULT +Specifies that the [NO]NOTIFY option is the default for the specified +folder. This is a privileged qualifier. It will only affect brand new +users (or those that have never logged in). Use /ALL to modify all users. +3 /FOLDER + /FOLDER=foldername + +Specifies the folder for which the option is to modified. If not +specified, the selected folder is modified. Valid only with NONOTIFY. +3 /PERMANENT + /[NO]PERMANENT + +Specifies that NOTIFY is a permanent flag and cannot be changed by the +individual. /DEFAULT must be specified. This is a privileged qualifier. +2 PAGE +Specifies whether any directory listing or message reading output will +pause when it reaches the end of the page or not. Setting NOPAGE is +useful for terminals that can store more than one screenful at a time, +and that have a remote printer that can then print the contents of the +terminal's memory. The default is PAGE, unless the default was changed +by specifying /NOPAGE on the command line to invoke BULLETIN. + + Format: + + SET [NO]PAGE +2 PRIVILEGES +Specifies either process privileges or rights identifiers that are +necessary to use privileged commands. Use the SHOW PRIVILEGES command +to see what is presently set. This is a privileged command. + + Format: + + SET PRIVILEGES parameters + +The parameters are one or more privileges separated by commas. To +remove a privilege, specify the privilege preceeded by "NO". If /ID is +specified, the parameters are rights identifiers. +3 /ID + /[NO]ID + +If specified, then the rights identifier which is specified as the +parameter will allow users holding that rights identifier to execute +privileged commands. If /NOID is specified, the identifier is removed. +2 PROMPT_EXPIRE +Specifies that a user will be prompted for an expiration date when +adding a message. If NOPROMPT_EXPIRE is specified, the user will not be +prompted, and the default expiration (which is set by SET DEFAULT_EXPIRE +or SET BBOARD/EXPIRATION) will be used. If the value specified is +greater than the expiration limit, and the user does not have +privileges, then the expiration limit will be used as the default +expiration. (If there is no expiration limit, and the user doesn't have +privileges, then an error will result.) PROMPT_EXPIRE is the default. + + Format: + + SET [NO]PROMPT_EXPIRE +2 READNEW +Controls whether you will be prompted upon logging in if you wish to +read new non-system or folder messages (if any exist). A new message is +defined as one that has been added since the last login, or since +accessing BULLETIN. The default setting for READNEW is dependent on how +the folder was created by the owner. + +In order to apply this to a specific folder, first select the folder +(using the SELECT command), and then enter the SET READNEW command. + + Format: + + SET [NO]READNEW + +NOTE: If you have several folders with READNEW enabled, each folder's +messages will be displayed separately. However, if you EXIT the READNEW +mode before all the folders have been displayed, you will not be alerted +of the new messages in the undisplayed folders the next time you login. +However, if you enter BULLETIN, you will be told that new messages are +present in those other folders. Also, it is not possible to EXIT the +READNEW mode if there are SYSTEM folders which have new messages. Typing +the EXIT command will cause you to skip to those folders. (See HELP SET +SYSTEM for a description of a SYSTEM folder). +3 /ALL +Specifies that the SET [NO]READNEW option is the default for all users for +the specified folder. This is a privileged qualifier. The difference +between this and /DEFAULT is that the latter will only apply to new users +(i.e. any users which have never executed BULLETIN). +3 /DEFAULT +Specifies that the [NO]READNEW option is the default for the specified +folder. This is a privileged qualifier. It will only affect brand new +users (or those that have never logged in). Use /ALL to modify all users. +3 /FOLDER + /FOLDER=foldername + +Specifies the folder for which the option is to modified. If not +specified, the selected folder is modified. Valid only with NOREADNEW. +3 /PERMANENT + /[NO]PERMANENT + +Specifies that READNEW is a permanent flag and cannot be changed by the +individual. This is a privileged qualifier. +2 SHOWNEW +Controls whether a directory listing of new messages for the current +folder will be displayed when logging in. This is similar to READNEW, +except you will not be prompted to read the messages. The default is +dependent on how the folder was created by the owner. A new message is +defined as one that has been added since the last login, or since +accessing BULLETIN. + +In order to apply this to a specific folder, first select the folder +(using the SELECT command), and then enter the SET SHOWNEW command. + + Format: + + SET [NO]SHOWNEW +3 /ALL +Specifies that the SET [NO]SHOWNEW option is the default for all users for +the specified folder. This is a privileged qualifier. The difference +between this and /DEFAULT is that the latter will only apply to new users +(i.e. any users which have never executed BULLETIN). +3 /DEFAULT +Specifies that the [NO]SHOWNEW option is the default for the specified +folder. This is a privileged qualifier. It will only affect brand new +users (or those that have never logged in). Use /ALL to modify all users. +3 /FOLDER + /FOLDER=foldername + +Specifies the folder for which the option is to modified. If not +specified, the selected folder is modified. Valid only with NOSHOWNEW. +3 /PERMANENT + /[NO]PERMANENT + +Specifies that SHOWNEW is a permanent flag and cannot be changed by the +individual, except if changing to READNEW. This is a privileged qualifier. +2 STRIP +Affect only messages which are added via either the BBOARD option, or +written directly from a network mailing program (i.e. PMDF). If +STRIP is set, the header of the mail message will be stripped off +before it is stored as a BULLETIN message. + + Format: + + SET [NO]STRIP + +The command SHOW FOLDER/FULL will show if STRIP has been set. +2 SYSTEM +Specifies that the selected folder is a SYSTEM folder. A SYSTEM folder +is allowed to have SYSTEM and SHUTDOWN messages added to it. This is a +privileged command. + + Format: + + SET [NO]SYSTEM + +By default, the GENERAL folder is a SYSTEM folder, and the setting for +that folder cannot be removed. + +If the selected folder is remote, /SYSTEM cannot be specified unless the +folder at the other node is also a SYSTEM folder. +1 SHOW +The SHOW command displays information about certain characteristics. +2 FLAGS +Shows whether BRIEF, NOTIFY, READNEW, or SHOWNEW has been set for the +currently selected folder. +2 FOLDER +Shows information about a folder of messages. Owner and description are +shown. If the folder name is omitted, and a folder has been selected via +the SELECT command, information about that folder is shown. + + Format: + + SHOW FOLDER [folder-name] +3 /FULL +Control whether all information of the folder is displayed. This +includes DUMP & SYSTEM settings, the access list if the folder is +private, and BBOARD information. This information is only those who +have access to that folder. +2 KEYPAD +Displays the keypad command definitions. If the keypad has been enabled +by either the SET KEYPAD COMMAND, or /KEYPAD is specified on the command +line, the keypad keys will be defined as commands. SHOW KEYPAD is the +equivalent of HELP KEYPAD. + +NOTE: If the keypad is not enabled, PF2 is defined to be SET KEYPAD. +3 /PRINT +Prints the keypad definitions on the default printer (SYS$PRINT). +2 NEW +Shows folders which have new unread messages for which BRIEF or READNEW +have been set. (Note: If you enter BULLETIN but do not read new unread +messages, you will not be notified about them the next time you enter +BULLETIN. This is a design "feature" and cannot easily be changed.) +2 PRIVILEGES +Shows the privileges necessary to use privileged commands. Also shows +any rights identifiers that would also give a user privileges. (The +latter are ACLs which are set on the BULLUSER.DAT file.) +2 USER +Shows the last time that a user logged in, or if /FOLDER is specified, +the latest message which a user has read in the folder. If NOLOGIN is +set for a user, this information will be displayed. This is a +privileged command. Non-privileged users will only be able to display +the information for their own account. + + Format: + SHOW USER [username] + +The username is optional. If omitted, the process's username is used. +The username should not be included if /ALL or /[NO]LOGIN is specified. + +NOTE: The last logged in time displayed is that which is stored when the +BULLETIN/LOGIN command is executed, not that which VMS stores. Some +sites make BULLETIN/LOGIN an optional command for users to store in +their own LOGIN.COM, so this command can be used to show which users +have done this. +3 /ALL +Specifies that information for all users is to be displayed. This is a +privileged command. +3 /LOGIN + /[NO]LOGIN + +Specifies that only those users which do not have NOLOGIN set are to be +displayed. If negated, only those users with NOLOGIN set are displayed. +This is a privileged command. The qualifier /ALL need not be specified. +3 /FOLDER + /FOLDER=[foldername] + +Specifies to display the latest message that was read by the user(s) for +the specified foldername. A newsgroup can be specified, but the info +can only be shown if the user has subscribed to the newsgroup. If the +foldername is not specified, the selected folder will be used. +3 /SINCE + /SINCE=[date] + +Specifies to display only those users whose latest read message date is +the same date or later than the specified date. If no date is +specified, the date of the current message is used. Only valid for +folders or with /LOGIN. Use /START for newsgroups. +3 /START + /START=[number] + +Specifies to display only those users whose latest read message number +is equal to or greather than the specified number. If no number is +specified, the message number of the current message is used. Only +valid for newsgroups. Use /SINCE for folders and with /LOGIN. +2 VERSION +Shows the version of BULLETIN and the date that the executable was +linked. +1 SPAWN +Creates a subprocess of the current process. To return to BULLETIN, +type LOGOUT. + + Format: + SPAWN [command-string] + +NOTE: BULLETIN disables the use of CONTROL-C, so that you must use +CONTROL-Y if you wish to break out of a spawned command. +1 SUBSCRIBE +Used only for NEWS folders. Specifies that BULLETIN will keep track of +the newest message that has been read for that NEWS folder. When the +NEWS folder is selected, the message pointer will automatically point to +the next newest message that has not been read. +1 UNDELETE +Undeletes he specified message if the message was deleted using the +DELETE command. Deleted messages are not actually deleted but have +their expiration date set to 15 minutes in the future and are deleted +then. Undeleting the message will reset the expiration date back to its +original value. Deleted messages will be indicated as such by the +string (DELETED) when either reading or doing a directory listing. + + Format: + UNDELETE [message-number] +1 UNSUBSCRIBE +Used only for NEWS folders. Specifies that BULLETIN will no longer keep +track of the newest message that has been read for that NEWS folder. See the +SUBSCRIBE command for further info. diff --git a/decus/vax91b/gce91b/net91b/bullet1.com b/decus/vax91b/gce91b/net91b/bullet1.com new file mode 100644 index 0000000..ac82c98 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bullet1.com @@ -0,0 +1,1452 @@ +$set nover +$copy/log sys$input AAAREADME.TXT +$deck +The following are instructions for creating and installing the BULLETIN +utility. None of the command procedures included here are sophisticated, so it +is likely that several modifications will have to be made by the installer. +The installer should enable all privileges before installation. + +Once installation is complete, it is suggested that the installer enter +BULLETIN and read HELP FOLDERS to see the options available when creating +or modifying folders. + +One of the main uses of BULLETIN, besides storage of messages that are manually +entered by users, is storage of messages from network mailing lists. This is +done by using the BBOARD feature, which is enabled using the SET BBOARD command +inside BULLETIN. The alternative method is for mail messages to be written +directly by a mailing program by calling internal BULLETIN routines. Such a +a program has been written for the popular mail utility PMDF. If you wish to +do so for another utility, read the text file WRITEMSG.TXT. I would be glad to +include any such programs with my distribution if you think such a program +would be of use to other users. + +Responding to mail which is either added via the BBOARD feature is done using +VMS MAIL. If for some reason this is inappropriate, you can define BULL_MAILER +to point to a command procedure, and which will be run instead of VMS MAIL. +The parameters passed to this procedure are P1 = username and P2 = subject. + +1) CREATE.COM + This will compile and link the BULLETIN sources. Also, there are several + INCLUDE files for the fortran sources (.INC files). BULLETIN will create it's + data files in the directory pointed to by the logical name BULL_DIR. If you + elect not to use this definition, BULLFILES.INC should be modified. + Note that after this procedure compiles the sources, it puts the objects + into an object library, and then deletes all the OBJ files in the directory. + + NOTE 1: If you plan on using the USENET NEWS reader capability of BULLETIN, + read NEWS.TXT for installation instructions before compiling. + + NOTE 2: The maximum number of folders for this distribution is 96 folders. + If you wish to increase this, modify BULLUSER.INC and recompile the sources. + When the new executable is run, it will create a new BULLUSER.DAT data file + and rename the old one to BULLUSER.OLD. You cannot reduce the number of + folders. + +2) INSTALL.COM + The following procedure copies the executable image to BULL_DIR and + installs it with certain privileges. It also installs the necessary + help files in SYS$HELP. (BULLETIN help file is installed into the + system help library HELPLIB.HLB. If you don't wish this done, delete + or modify the appropriate line in the procedure. Also, the help + library for the BULLETIN program, BULL.HLB, can be moved to a different + directory other than SYS$HELP. If this is done, the system logical name + BULL_HELP should be defined to be the directory where the library is + to be found.) + +3) LOGIN.COM + This contains the commands that should be executed at login time + by SYS$MANAGER:SYLOGIN.COM. It defines the BULLETIN commands. + It also executes the command BULLETIN/LOGIN in order to notify + the user of new messages. NOTE: If you wish the utility to be a + different name than BULLETIN, you should modify this procedure. + The prompt which the utility uses is named after image executable. + If you want messages displayed upon logging in starting from + oldest to newest (rather than newest to oldest), add /REVERSE to + the BULLETIN/LOGIN command. Note that users with the DISMAIL + flag setting in the authorization file will not be notified of + new messages. See help on the SET LOGIN command within the BULLETIN + utility for more information on this. Also, please note that when + a brand new user to the system logins, to avoid overwhelming the new + user with lots of messages, only PERMANENT SYSTEM messages are displayed. + + If you want SYSTEM messages, i.e. messages which are displayed in full + when logging in, to be continually displayed for a period of time rather + than just once, you should add the /SYSTEM= qualifier. This is documented + in BULLETIN.HLP, although there it is referred to only with respect to + a user wanting to review system messages. It can be added with /LOGIN. + + DECWINDOWS users should note the following: Both SYLOGIN and LOGIN are + executed twice, once before the terminal is actually created, while + SYS$OUTPUT is still a mailbox, the other time after the terminal is + created. To avoid this, place the following code in both procedure. + It causes them to execute only when the output is a terminal. This code + also helps to allow programs to be placed in LOGIN.COM that prompt for + terminal input. BULLETIN does this if you select READNEW mode for + displaying messages when logging in, as READNEW mode will ask you if + you want to display the messages text. Attempts to read terminal input + under DECWINDOWS when SYS$OUTPUT is still a mailbox will cause DECTERM + creation to fail. + + $ IF F$LOCATE("_TW",F$GETJPI("","PRCNAM")) .NE. 0 THEN GOTO START + $ IF "''F$MODE()'" .NES. "INTERACTIVE" THEN GOTO START + $ IF F$GETDVI("SYS$OUTPUT","TRM") THEN GOTO START + $ GOTO FINISH + $START: + . + . + body of SYLOGIN.COM (including BULLETIN command) + . + . + $FINISH: + $ EXIT + +4) BULLSTART.COM + This procedure contains the commands that should be executed after + a system startup. It should be executed by SYS$MANAGER:SYSTARTUP.COM. + It installs the BULLETIN utility with correct privileges. It also + includes the command BULLETIN/STARTUP. This starts up a detached process + with the name BULLCP. It periodically check for expire messages, cleanup + empty space in files, and converts BBOARD mail to messages. It also allows + other DECNET nodes to share it's folders. If you don't want this feature + and don't plan on having multiple folders or make use of BBOARD, you could + eliminate this command if you like. However, it is highly recommended that + you create this process to avoid extra overhead when users login. NOTE: + BULLCP normally is created so it is owned by the DECNET account. If that + account does not exist, BULLCP will be owned by the account that issues + the BULLETIN/START command. In that case, access via other DECNET nodes + will not be available. + + If you are installing BULLETIN on a cluster and plan to have the bulletin + files be shared between all of the cluster nodes, you only need to have + this process running on one node. On all other nodes, the system logical + name BULL_BULLCP should be defined (to anything you want) so as to notify + BULLETIN that BULLCP is running. (On the local node where BULLCP is running, + this logical name is automatically defined.) + + The use of the MARK command to mark messages require that a file be + created for each user which saves the marked info. That file file is + stored in the directory pointed to by the logical name BULL_MARK. You can + either let users who want to use this command define it themselves, or + you can define it for them, i.e. DEFINE/SYSTEM BULL_MARK SYS$LOGIN. + +5) INSTRUCT.COM + This procedure adds 2 permanent messages which give a very brief + description about the BULLETIN utility, and how to turn off optional + prompting of non-system messages (via SET NOREADNEW). + +6) BOARD_SPECIAL.COM + This command procedure describes and illustrates how to use the + SET BBOARD/SPECIAL feature. This feature allows the use of BBOARD + where the input does not come from VMS MAIL. For example, this could + be used in the case where mail from a non-DEC network is not stored + in the VMS MAIL. Another example is BOARD_DIGEST.COM. This file + takes mail messages from "digest" type mailing lists and splits them + into separate BULLETIN messages for easier reading. + + To use this feature, place the special command procedure into the + bulletin file directory using the name BOARD_SPECIAL.COM. If you want + to have several different special procedure, you should name the command + procedure after the username specified by the SET BBOARD command. + +7) INSTALL_REMOTE.COM + This procedure, in conjunction with REMOTE.COM and DCLREMOTE.COM allows + a user to install new versions of BULLETIN on several DECNET nodes from + a single node, rather than having to login to each node. This is + especially useful when a new version modifies the format of one of the + data file. Older versions of BULLETIN will not run with newer formats + and will either issue error statements when run, or may cause major + problems by attempting to change the files back to the old format. + (NOTE: Don't attempt to use this if different nodes are running + different versions of VMS, i.e. V4 and V5, as they require different + linked executables.) + +8) MASTER.COM + If you are using PMDF, and want to use the BBOARD option, a set of + routines are included which will allow PMDF to write message directly + into folders, which is a much more effecient way of doing it than + the normal BBOARD method of using VMS MAIL. Read PMDF.TXT for how + to do this. + +9) OPTIMIZE_RMS.COM + This routine optimizes index files. To run, type @OPTIMIZE_RMS.COM + followed by the filename. If you omit the filename, it will prompt + you to allow you to turn off or on several different types of RMS + compression. The default is to turn on all types of compression. + The optimization will cause the file to be compressed. + + If you use the NEWS feature, it is suggest that you run this procedure + on BULLNEWS.DAT after it is created. Compression that file greatly speeds + up the NEWS update process. If you are tight on space, and have been + running BULLETIN for a long time, it might also be useful to compress + BULLINF.DAT if that file is very large. However, compressing that (or + the other BULLETIN data files) don't appear to save any execution time, + unlike BULLNEWS.DAT. + +10) BULLETIN.COM + If one wants BULLETIN to be able to send messages to other DECNET + node's GENERAL folder, but wants to avoid running the process created + by BULLETIN/STARTUP on this node, another method exists. This is the + "older" (and slower) method. BULLETIN.COM must be put in each node's + DECNET default user's directory (usually [DECNET]). Once this is done, + the /NODE qualifier for the ADD & DELETE commands can be used. + The object BULLETIN pointing to BULLETIN.COM must be added to the NCP + database, i.e. the command + MCR NCP SET OBJ BULLETIN FILE directory:BULLETIN.COM number 0 + must be executed at startup time on the remote node. + NOTE: Privileged functions such as /SYSTEM will work on other nodes + if you have an account on the other node with appropriate privileges. +$eod +$copy/log sys$input BULLDIR.INC +$deck + PARAMETER DIR_RECORD_LENGTH = ((97+3)/4)*4 + + COMMON /BULL_DIR/ MSG_BTIM,MSG_NUM,DESCRIP,FROM,LENGTH,EX_BTIM + & ,SYSTEM,BLOCK,HEADER_BTIM,HEADER_NUM,NEWEST_EXBTIM,NEWEST_MSGBTIM + & ,NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_BTIM,NEMPTY + & ,DATE,TIME,EXDATE,EXTIME,NEWEST_EXDATE,NEWEST_EXTIME + & ,NEWEST_DATE,NEWEST_TIME,SHUTDOWN_DATE,SHUTDOWN_TIME + CHARACTER*53 DESCRIP + CHARACTER*12 FROM + LOGICAL SYSTEM + + CHARACTER*11 DATE,EXDATE,NEWEST_EXDATE,NEWEST_DATE,SHUTDOWN_DATE + CHARACTER*11 TIME,EXTIME,NEWEST_EXTIME,NEWEST_TIME,SHUTDOWN_TIME + + INTEGER MSG_BTIM(2),EX_BTIM(2),HEADER_BTIM(2) + INTEGER NEWEST_EXBTIM(2),NEWEST_MSGBTIM(2),SHUTDOWN_BTIM(2) + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY + EQUIVALENCE (MSG_BTIM,BULLDIR_ENTRY) + + CHARACTER*52 BULLDIR_HEADER + EQUIVALENCE (HEADER_BTIM,BULLDIR_HEADER) + + DATA HEADER_BTIM/0,0/,HEADER_NUM/0/ + + CHARACTER MSG_KEY*8 + + EQUIVALENCE (MSG_BTIM,MSG_KEY) + + PARAMETER LINE_LENGTH=255 + + COMMON /INPUT_BUFFER/ INPUT + CHARACTER INPUT*(LINE_LENGTH) +$eod +$copy/log sys$input BULLETIN.HLP +$deck +1 BULLETIN +Invokes the PFC BULLETIN Utility. This utility is used for reading, +adding and deleting message. Users are notified at login time that new +messages have been added and the topics of those messages are displayed. +Reading of those messages is optional. (Use the command SET READNEW +while in BULLETIN for setting automatic reading.) Privileged users can +add system bulletins that are displayed in full at login time. These +messages are also saved, and can be read by BULLETIN. Messages are +automatically deleted after a specified expiration date, or they can +manually be deleted by either the submitter of the message or a +privileged user. + + Format: + + BULLETIN [foldername or bulletin interactive command] + +BULLETIN has an interactive help available while using the utility. +Type HELP after invoking the BULLETIN command. +2 Description + +The BULLETIN utility is a utility to display messages to users when +logging in. Users are notified of messages only once. They're not +forced into reading them every time they log in. Submitting and reading +messages is easy to do via a utility similar to the VMS MAIL utility. +Privileged users can create messages which are displayed in full. (known +as SYSTEM messages). Non-privileged users may be able to create +non-SYSTEM messages (unless your system manager has disabled the +feature), but only topics are displayed at login. + +Folders can be created so that messages pertaining to a single topic can +be placed together. Folders can be made private so that reading and +writing is limited to only users or groups who are granted access. +Alternatively, folders can be made semi-private in that everyone is +allowed to read them but write access is limited. + +When new non-system messages are displayed, an optional feature which a +user may enable will cause BULLETIN to ask whether the user wishes to +read the new bulletins. The user can then read the messages (with the +ability to write any of the messages to a file). A user can enable the +notification and prompting of new messages feature on a folder per +folder basis. However, the exception is messages submitted to the +default GENERAL folder. Users are always notified at login of new +bulletins in this folder, but can disable the prompting. This is to +give non-privileged users some ability to force a notification of an +important message. + +Messages have expiration dates and times, and are deleted automatically. +Expiration dates and times can be specified in absolute or delta +notation. Privileged users can specify "SHUTDOWN" messages, i.e. +messages that get deleted after a system shutdown has occurred. +"PERMANENT" messages can also be created which never expire. + +Privileged users can broadcast their message (to either all users or all +terminals). + +A user can select, on a folder per folder basis, to have a message +broadcast to their terminal immediately notifying them when a new +message has been added. + +An optional "Bulletin Board" feature allows messages to be created by +users of other systems connected via networks. A username can be +assigned to a folder, and any mail sent to that user is converted to +messages and stored in that folder. This feature originally was +designed to duplicate the message board feature that exists on some +Arpanet sites. However, with the addition of folders, another possible +use is to assign an Arpanet mailing list to a folder. For example, one +could have an INFOVAX folder associated with an INFOVAX username, and +have INFO-VAX mail sent to INFOVAX. Users could then read the mailing +list in that folder, rather than having INFO-VAX sent to each user. +Optionally, the input for the bulletin board can be directed to be taken +from any source other than VMS MAIL. This might be useful if incoming +mail is stored in a different place other than VMS MAIL. + +Messages can be either sent to a file, to a print queue, or mailed to +another user. + +BULLETIN can also act a USENET NEWS reader if the appropriate network +software is available to interact with. See the installation notes for +more detail. +2 Parameters +The parameter following the BULLETIN command is interpreted as the +folder name which should be selected, rather than the default GENERAL +folder. If the parameter is specified with quotes ("parameter"), the +parameter is interpreted as an interactive BULLETIN command, i.e. +commands which are entered once BULLETIN is executed, i.e. "DIRECTORY", +"ADD", etc. BULLETIN will exit immediately after entering that command, +rather than prompting for another command. More than one command can be +specified by separating the commands with semi-colons, i.e. "SELECT +DATA;DIR". + +NOTE: Depending on how the BULLETIN command is defined, triple quotes +rather than single quotes may be required. +2 /EDIT +Specifies that all ADD or REPLACE commands within BULLETIN will select +the editor for inputting text. +2 /KEYPAD + /[NO]KEYPAD +Specifies that keypad mode is to be set on, such that the keypad keys +correspond to BULLETIN commands. The default is /KEYPAD. +2 /PAGE + /[NO]PAGE + +Specifies whether BULLETIN will stop outputting when it displays a full +screen or not. /PAGE is the default. If /NOPAGE is specified, any +output will continue until it finishes. This is useful if you have a +terminal which can store several screenfuls of display in its memory. +2 /PGFLQUOTA + /PGFLQUOTA=pages + +Used if you want to specify the page file quota for the BULLCP process. +2 /STARTUP +Starts up a detached process which will periodically check for expired +messages, cleanup empty space in files, and convert BBOARD mail to +messages. This is recommended to avoid delays when invoking BULLETIN. +It will create a process with the name BULLCP. For clusters, this +need be done only on one node. On all other nodes, the system logical +name BULL_BULLCP should be defined (to anything) in order that BULLETIN +is aware that it is running on another node. (On the local node where +BULLCP is running, this logical name is automatically defined.) +2 /STOP +Stops the BULLCP process without restarting a new one. (See /STARTUP +for information on the BULLCP process.) +2 /SYSTEM + /SYSTEM=[days] + +Displays system messages that have been recently added. The default is +to show the messages that were added during the last 7 days. This can +be modified by specifying the number of days as the parameter. +This command is useful for easily redisplaying system messages that +might have been missed upon logging in (or were broadcasted but were +erased from the screen.) +2 /WIDTH + /WIDTH=page_width + +Specifies the terminal width for display purposes. This is used if your +startup procedure is configured such that BULLETIN/LOGIN is executed before +the terminal type is known, and the default width is larger than what the +terminal type actually is. I.e. the default width might be 132, but the +real width is 80. In that case, you should add /WIDTH=80 to BULLETIN/LOGIN. +2 /WSEXTENT + /WSEXTENT=pages + +Used if you want to specify the working set limit for the BULLCP process. +$eod +$copy/log sys$input BULLETIN.LNK +$deck +$ ULIB = "NONE" +$ IF F$TRNLNM("TWG$TCP") .EQS. "" THEN GOTO LINK +$ ULIB = "PROCESS" +$ DEFINE/USER LNK$LIBRARY TWG$TCP:[NETDIST.LIB]LIBNET +$ DEFINE/USER LNK$LIBRARY_1 TWG$TCP:[NETDIST.LIB]LIBNETACC +$ DEFINE/USER LNK$LIBRARY_2 TWG$TCP:[NETDIST.LIB]LIBNET +$LINK: +$ LINK/NOTRACE BULL/LIB/INC=BULLETIN$MAIN,SYS$SYSTEM:SYS.STB/SEL- + /USERLIB='ULIB'/EXE=BULLETIN,SYS$INPUT/OPT +SYS$SHARE:VAXCRTL/SHARE +ID="V2.06" +$eod +$copy/log sys$input BULLFILES.INC +$deck +C +C FOLDER_DIRECTORY IS THE DIRECTORY THAT FILES FOR FOLDERS THAT +C ARE CREATED ARE KEPT IN. IF YOU WISH TO PREVENT FOLDER CREATION, +C YOU SHOULD MODIFY BULLCOM.CLD TO MAKE THE CREATE COMMAND A PRIVILEGED +C COMMAND (OR SIMPLY REMOVE THE LINES WHICH DEFINE THE CREATE COMMAND). +C +C BBOARD_DIRECTORY IS THE SCRATCH AREA USED BY BBOARD WHEN EXTRACTING +C MAIL. IF IT IS UNDEFINED, BBOARD WILL NOT BE ABLE TO BE USED. +C NOTE THAT EITHER THE BBOARD ACCOUNTS MUST HAVE ACCESS TO THIS DIRECTORY, +C OR THE BBOARD ACCOUNTS MUST BE GIVEN SYSPRV PRIVILEGES TO BE ABLE +C TO WRITE INTO THIS DIRECTORY. ALSO, FOR BBOARD TO WORK, MAKE SURE +C THAT THE SUBPROCESS LIMIT FOR USERS IS AT LEAST 2. YOU WILL ALSO HAVE +C TO INCREASE THE FOLLOWING SYSTEM PARAMETERS WHICH AFFECT DETACHED PROCESES: +C PQL_DPGFLQUOTA = 10000, PQL_DWSQUOTA = 500, & PQL_DFILLM = 30. +C (NOTE: ACCESS CAN BE GIVEN TO THE DIRECTORY FOR THE BBOARD ACCOUNTS USING +C ACLS, I.E. " SET ACL/ACL=(ID=bboard,ACCESS=R+W)/OBJ=FILE directory.DIR") +C + COMMON /FILES/ BULLFOLDER_FILE,FOLDER_DIRECTORY,BBOARD_DIRECTORY + COMMON /FILES/ BULLUSER_FILE,BULLINF_FILE + CHARACTER*80 FOLDER_DIRECTORY /'BULL_DIR:'/ + CHARACTER*80 BBOARD_DIRECTORY /'BULL_DIR:'/ +C +C NOTE: THE FOLLOWING DEFINITIONS ASSUME THAT BULL_DIR IS USED. IF IT +C IS NOT, THEN THEY SHOULD ALSO BE CHANGED. +C + CHARACTER*80 BULLUSER_FILE /'BULL_DIR:BULLUSER.DAT'/ + CHARACTER*80 BULLFOLDER_FILE /'BULL_DIR:BULLFOLDER.DAT'/ + CHARACTER*80 BULLINF_FILE /'BULL_DIR:BULLINF.DAT'/ + CHARACTER*80 BULLNEWS_FILE /'BULL_DIR:BULLNEWS.DAT'/ +$eod +$copy/log sys$input BULLFOLDER.INC +$deck +! +! The following 2 parameters can be modified if desired before compilation. +! + PARAMETER BBEXPIRE_LIMIT = 30 ! Maxmimum time limit in days that + ! BBOARDS can be set to. + PARAMETER BBOARD_UPDATE = 15 ! Number of minutes between checks + ! for new BBOARD mail. (Note: Check + ! only occurs via BULLETIN/LOGIN. + ! Check is forced via BULLETIN/BBOARD). + ! NOT APPLICABLE IF BULLCP IS RUNNING. + PARAMETER ADDID = .TRUE. ! Allows users who are not in the + ! rights data base to be added + ! according to uic number. + + PARAMETER FOLDER_FMT = '(A25,A4,A12,A80,A12,3A4,A8,7A4)' + PARAMETER FOLDER_RECORD = 184 ! Must be multiple of 4 + + COMMON /BULL_FOLDER/ FOLDER,FOLDER_NUMBER,FOLDER_OWNER, + & FOLDER_DESCRIP,FOLDER_BBOARD,FOLDER_BBEXPIRE, + & USERB,GROUPB,ACCOUNTB, + & F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,F_EXPIRE_LIMIT, + & F_NEWEST_NOSYS_BTIM,FILLER, + & FOLDER_FILE,FOLDER_SET,FOLDER_NAME + INTEGER F_NEWEST_BTIM(2) + INTEGER F_NEWEST_NOSYS_BTIM(2) + LOGICAL FOLDER_SET + DATA FOLDER_SET /.FALSE./, FOLDER/'GENERAL'/ + CHARACTER FOLDER_OWNER*12,FOLDER*25,ACCOUNTB*8,FOLDER_NAME*80 + CHARACTER FOLDER_FILE*80,FOLDER_DESCRIP*80,FOLDER_BBOARD*12 + + EQUIVALENCE (FOLDER_BBOARD(3:),F_START) + EQUIVALENCE (FOLDER_BBOARD(7:),F_END) + + CHARACTER*(FOLDER_RECORD) FOLDER_COM + EQUIVALENCE (FOLDER,FOLDER_COM) + + COMMON /BULL_FOLDER1/ FOLDER1,FOLDER1_NUMBER,FOLDER1_OWNER, + & FOLDER1_DESCRIP,FOLDER1_BBOARD,FOLDER1_BBEXPIRE, + & USERB1,GROUPB1,ACCOUNTB1, + & F1_NBULL,F1_NEWEST_BTIM,FOLDER1_FLAG,F1_EXPIRE_LIMIT, + & F1_NEWEST_NOSYS_BTIM,FILLER1, + & FOLDER1_FILE,FOLDER1_NAME + CHARACTER FOLDER1_OWNER*12,FOLDER1*25,ACCOUNTB1*8,FOLDER1_NAME*80 + CHARACTER FOLDER1_FILE*80,FOLDER1_DESCRIP*80,FOLDER1_BBOARD*12 + INTEGER F1_NEWEST_BTIM(2) + INTEGER F1_NEWEST_NOSYS_BTIM(2) + + EQUIVALENCE (FOLDER1_BBOARD(3:),F1_START) + EQUIVALENCE (FOLDER1_BBOARD(7:),F1_END) + + CHARACTER*(FOLDER_RECORD) FOLDER1_COM + EQUIVALENCE (FOLDER1,FOLDER1_COM) + + PARAMETER NEWS_FOLDER_FMT = '(A25,A4,A55,A12,3A4)' + PARAMETER NEWS_FOLDER_RECORD = 108 ! Must be multiple of 4 + + COMMON /NEWS_FOLDER/ NEWS_FOLDER,NEWS_FOLDER_NUMBER, + & NEWS_FOLDER_DESCRIP,NEWS_FOLDER_BBOARD, + & NEWS_F_NBULL,NEWS_F_NEWEST_BTIM + INTEGER NEWS_F_NEWEST_BTIM(2) + CHARACTER NEWS_FOLDER*25 + CHARACTER NEWS_FOLDER_DESCRIP*55,NEWS_FOLDER_BBOARD*12 + + EQUIVALENCE (NEWS_FOLDER_BBOARD(3:),NEWS_F_START) + EQUIVALENCE (NEWS_FOLDER_BBOARD(7:),NEWS_F_END) + + CHARACTER*(NEWS_FOLDER_RECORD) NEWS_FOLDER_COM + EQUIVALENCE (NEWS_FOLDER,NEWS_FOLDER_COM) + + COMMON /NEWS_FOLDER1/ NEWS_FOLDER1,NEWS_FOLDER1_NUMBER, + & NEWS_FOLDER1_DESCRIP,NEWS_FOLDER1_BBOARD, + & NEWS_F1_NBULL,NEWS_F1_NEWEST_BTIM + INTEGER NEWS_F1_NEWEST_BTIM(2) + CHARACTER NEWS_FOLDER1*25 + CHARACTER NEWS_FOLDER1_DESCRIP*55,NEWS_FOLDER1_BBOARD*12 + + EQUIVALENCE (NEWS_FOLDER1_BBOARD(3:),NEWS_F1_START) + EQUIVALENCE (NEWS_FOLDER1_BBOARD(7:),NEWS_F1_END) + + CHARACTER*(NEWS_FOLDER_RECORD) NEWS_FOLDER1_COM + EQUIVALENCE (NEWS_FOLDER1,NEWS_FOLDER1_COM) +$eod +$copy/log sys$input BULLNEWS.INC +$deck + COMMON /NEWS_DEFAULTS/ ORGANIZATION,MAILER + + CHARACTER*132 ORGANIZATION + DATA ORGANIZATION /'MIT PLASMA FUSION CENTER'/ + + CHARACTER*10 MAILER + DATA MAILER /'IN%'/ +$eod +$copy/log sys$input BULLUSER.INC +$deck +! +! The parameter FOLDER_MAX should be changed to increase the maximum number +! of folders available. Due to storage via longwords, the maximum number +! available is always a multiple of 32. Thus, it will probably make sense +! to specify a multiple of 32 for FOLDER_MAX, as that it what really will be +! the capacity. Note that the default general folder counts as a folder also, +! so that if you specify 64, you will be able to create 63 folders on your own. +! + PARAMETER FOLDER_MAX = 96 + PARAMETER FLONG = (FOLDER_MAX + 31)/ 32 + + PARAMETER USER_RECORD_LENGTH = 28 + FLONG*16 + PARAMETER USER_FMT = '(A12,<4+FLONG*4>A4)' + PARAMETER USER_HEADER_KEY = ' ' + + COMMON /HEADER_INFO/ TEMP_USER,BBOARD_BTIM,NEWEST_BTIM,USERPRIV + COMMON /HEADER_INFO/ SET_FLAG_DEF,BRIEF_FLAG_DEF + COMMON /HEADER_INFO/ NOTIFY_FLAG_DEF + CHARACTER TEMP_USER*12 + DIMENSION BBOARD_BTIM(2),NEWEST_BTIM(2),USERPRIV(FLONG) + DIMENSION SET_FLAG_DEF(FLONG),BRIEF_FLAG_DEF(FLONG) + DIMENSION NOTIFY_FLAG_DEF(FLONG) + + COMMON /BULL_USER/ USERNAME,LOGIN_BTIM,READ_BTIM, + & NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + CHARACTER*12 USERNAME + DIMENSION LOGIN_BTIM(2),READ_BTIM(2) + DIMENSION NEW_FLAG(FLONG) ! Used to indicate new message in folder + ! Now NEW_FLAG(2) contains SET GENERIC days + DIMENSION SET_FLAG(FLONG) ! Bit set indicates READNEW set for folder + DIMENSION BRIEF_FLAG(FLONG) ! Bit set indicates READNEW/BRIEF set + DIMENSION NOTIFY_FLAG(FLONG)! Bit set indicates to broadcast + ! notification when new bulletin is added. + + CHARACTER*(USER_RECORD_LENGTH) USER_ENTRY,USER_HEADER + EQUIVALENCE (USER_ENTRY,USERNAME) + EQUIVALENCE (USER_HEADER,TEMP_USER) + + COMMON /FOLDER_TIMES/ LAST_READ_BTIM(2,0:FOLDER_MAX) + ! Must start with 0 to store info for folder specified with :: + COMMON /SYS_FOLDER_TIMES/ LAST_SYS_BTIM(2,FOLDER_MAX) + ! Last read times for each folder as stored in BULL_DIR:BULLINF.DAT + COMMON /NEWS_TIMES/ LAST_NEWS_READ(2,FOLDER_MAX) + INTEGER*2 LAST_NEWS_READ2(4,FOLDER_MAX) + EQUIVALENCE (LAST_NEWS_READ2(1,1),LAST_NEWS_READ(1,1)) + ! Last read times for each folder as stored in BULL_DIR:BULLINF.DAT + + COMMON /NEW_MESSAGES/ NEW_MSG + DIMENSION NEW_MSG(FLONG) ! Flag showing new messages detected +$eod +$copy/log sys$input BULL_NEWS.C +$deck +#include +#include "sys$library:iodef.h" + +#if MULTINET + +#include "multinet_root:[multinet.include.sys]types.h" +#include "multinet_root:[multinet.include.sys]socket.h" +#include "multinet_root:[multinet.include.netinet]in.h" +#include "multinet_root:[multinet.include]netdb.h" +#include "multinet_root:[multinet.include]errno.h" +#include "multinet_root:[multinet.include.vms]inetiodef.h" + +static char inet[7] = "INET0:"; +$DESCRIPTOR(inet_d,inet); + +#else + +#if UCX + +#include + +struct sockaddr { + short inet_family; + short inet_port; + int inet_adrs; + char bklb[8]; + }; + +struct itlist { int lgth; struct sockaddr *hst; }; + +static short sck_parm[2]; +static struct sockaddr local_host, remote_host; +struct itlist lhst_adrs, rhst_adrs; + +static char ucxdev[11] = "UCX$DEVICE"; +$DESCRIPTOR(ucxdev_d,ucxdev); + +static int addr_buff; + +#define htons(x) ((unsigned short)((x<<8)|(x>>8))) + +#else + +#if TWG + +#include +#include +#include +#include +#include + +static char inet[6] = "INET:"; +$DESCRIPTOR(inet_d,inet); + +#else + +#define CMU 1 +static char ip[4] = "IP:"; +$DESCRIPTOR(ip_d,ip); + +#endif + +#endif + +#endif + +static char task[20]; +$DESCRIPTOR(task_d,task); + +static int s; + +static struct iosb { + short status; + short size; + int info; +} iosb; + +#define TCP 0 +#define DECNET 1 + +static int mode = TCP; + +news_get_chan() +{return(s);} + +news_set_chan(i) +int *i; +{s = *i;} + +news_disconnect() +{ +#if UCX + sys$cancel(s); + sys$qiow(0,s,IO$_DEACCESS,0,0,0,0,0,0,0,0,0); +#endif + sys$dassgn(s); +} + +#if MULTINET || TWG + +static struct hostent *hp; +static struct sockaddr_in sin; + +#endif + +int *node; + +news_assign() +{ + int n; +#if MULTINET + struct hostent *GETHOSTBYNAME1(); +#endif +#if TWG + struct hostent *gethostbyname(); +#endif + node = getenv("BULL_NEWS_SERVER"); + if (!node) return(0); + if (!strchr(node,'.')) { + strcpy(&task[0],node); + n = strlen(node); + strcpy(&task[n],"::\"TASK=NNTP\""); + task_d.dsc$w_length = 13 + n; + if (!(sys$assign(&task_d,&s,0,0) & 1)) return(0); + mode = DECNET; + return(1); + } +#if MULTINET || TWG + /* + * Get the IP address of the NEWS host. + */ + +#if TWG + hp = gethostbyname(node); +#else + hp = GETHOSTBYNAME1(node); +#endif + /* + * Create a "sockaddr_in" structure which describes the remote + * IP address we want to send to (from gethostbyname()) and + * the remote NNTP port number (from getservbyname()). + */ + + if (!hp) { + int h[4],i; + if (sscanf(node,"%d.%d.%d.%d",&h[0],&h[1],&h[2],&h[3]) == 4) { + for (i=0;i<4;i++) if (h[i] < 0 || h[i] > 255) return(0); + sin.sin_addr.s_addr = (h[3]<<24)+(h[2]<<16)+(h[1]<<8)+(h[0]); + } else + return(0); + sin.sin_family = AF_INET; + } + else { + sin.sin_family = hp->h_addrtype; + memcpy(&sin.sin_addr, hp->h_addr, hp->h_length); + } +#if TWG + sin.sin_port = htons(119); +#else + sin.sin_port = HTONS1(119); +#endif + + /* + * Create an IP-family socket on which to make the connection + */ + + if (!(sys$assign(&inet_d,&s,0,0) & 1)) return(0); +#else +#if UCX + if (!(sys$assign(&ucxdev_d,&s,0,0) & 1)) return(0); + { + short retlen; + struct dsc$descriptor host_name + = {strlen(node),DSC$K_CLASS_S,DSC$K_DTYPE_T,node}; + int comm = INETACP$C_TRANS * 256 + INETACP_FUNC$C_GETHOSTBYNAME; + struct dsc$descriptor command + = {4,DSC$K_CLASS_S, DSC$K_DTYPE_T,&comm}; + struct dsc$descriptor host_ad + = {4,DSC$K_CLASS_S, DSC$K_DTYPE_T,&addr_buff}; + struct iosb nam_iosb; + + if (!(sys$qiow(0,s,IO$_ACPCONTROL,&nam_iosb,0,0, + &command,&host_name,&retlen,&host_ad,0,0) & 1) + || !(nam_iosb.status & 1)) { + sys$dassgn(s); + return(0); + } + } +#else + if (!(sys$assign(&ip_d,&s,0,0) & 1)) return(0); +#endif +#endif + return(1); +} + +news_socket() +{ + if (mode == DECNET) return (1); + +#if MULTINET || TWG + if (!(sys$qiow(0,s,IO$_SOCKET,&iosb,0,0,sin.sin_family, + SOCK_STREAM,0,0,0,0) & 1) || !(iosb.status & 1)) { + sys$dassgn(s); + return(0); + } +#endif +#if UCX + sck_parm[0] = INET$C_TCP; + sck_parm[1] = INET_PROTYP$C_STREAM; + local_host.inet_family = INET$C_AF_INET; + local_host.inet_port = 0; + local_host.inet_adrs = INET$C_INADDR_ANY; + lhst_adrs.lgth = sizeof local_host; + lhst_adrs.hst = &local_host; + if (!(sys$qiow(0,s,IO$_SETMODE,&iosb,0,0,&sck_parm,0, + &lhst_adrs,0,0,0) & 1) || !(iosb.status & 1)) { + sys$qiow(0,s,IO$_DEACCESS|IO$M_SHUTDOWN,&iosb,0,0,0,0,0, + UCX$C_DSC_ALL,0,0); + sys$dassgn(s); + return(0); + } +#endif + + return(1); +} + +news_socket_bullcp(efn,biosb,astadr,astprm) +int *biosb,*astadr,*astprm,*efn; +{ + if (mode == DECNET) return (1); + +#if MULTINET || TWG + if (!(sys$qio(*efn,s,IO$_SOCKET,biosb,astadr,*astprm,sin.sin_family, + SOCK_STREAM,0,0,0,0) & 1) ) return(0); +#else +#if UCX + sck_parm[0] = INET$C_TCP; + sck_parm[1] = INET_PROTYP$C_STREAM; + local_host.inet_family = INET$C_AF_INET; + local_host.inet_port = 0; + local_host.inet_adrs = INET$C_INADDR_ANY; + lhst_adrs.lgth = sizeof local_host; + lhst_adrs.hst = &local_host; + if (!(sys$qio(0,s,IO$_SETMODE,biosb,astadr,*astprm,&sck_parm,0, + &lhst_adrs,0,0,0) & 1) ) return(0); +#else + return(-1); +#endif +#endif + + return(1); +} + +news_create() +{ + if (mode == DECNET) return (1); + +#if MULTINET || TWG + + /* + * Do a psuedo-connect to that address. This tells the kernel that + * anything written on this socket gets sent to this destination. It + * also binds us to a local port number (random, but that is ok). + */ + + if (!(sys$qiow(0,s,IO$_CONNECT,&iosb,0,0,&sin,sizeof(sin),0,0,0,0) & 1) + || !(iosb.status & 1)) { + sys$dassgn(s); + return(0); + } +#else +#if UCX + remote_host.inet_family = INET$C_AF_INET; + remote_host.inet_port = htons(119); + remote_host.inet_adrs = addr_buff; + rhst_adrs.lgth = sizeof remote_host; + rhst_adrs.hst = &remote_host; + if (!(sys$qiow(0,s,IO$_ACCESS,&iosb,0,0,0,0,&rhst_adrs,0,0,0) & 1) + || !(iosb.status & 1)) { + sys$qiow(0,s,IO$_DEACCESS|IO$M_SHUTDOWN,&iosb,0,0,0,0,0, + UCX$C_DSC_ALL,0,0); + sys$dassgn(s); + return(0); + } +#else + if (!(sys$qiow(0,s,IO$_CREATE,&iosb,0,0,node,119,0,1,0,300) & 1) + || !(iosb.status & 1)) { + sys$dassgn(s); + return(0); + } +#endif +#endif + + return(1); +} + +news_create_bullcp(efn,biosb,astadr,astprm) +int *biosb,*astadr,*astprm,*efn; +{ + if (mode == DECNET) return (1); + +#if MULTINET || TWG + + /* + * Do a psuedo-connect to that address. This tells the kernel that + * anything written on this socket gets sent to this destination. It + * also binds us to a local port number (random, but that is ok). + */ + + if (!(sys$qio(*efn,s,IO$_CONNECT,biosb,astadr + ,*astprm,&sin,sizeof(sin),0,0,0,0) & 1)) return(0); +#else +#if UCX + remote_host.inet_family = INET$C_AF_INET; + remote_host.inet_port = htons(119); + remote_host.inet_adrs = addr_buff; + rhst_adrs.lgth = sizeof remote_host; + rhst_adrs.hst = &remote_host; + if (!(sys$qio(*efn,s,IO$_ACCESS,biosb,astadr,*astprm,0, + 0,&rhst_adrs,0,0,0) & 1)) return(0); +#else + if (!(sys$qio(*efn,s,IO$_CREATE,biosb,astadr,*astprm,node, + 119,0,1,0,300) & 1)) + return(0); +#endif +#endif + + return(1); +} + +news_connect() +{ + if (!news_assign()) return(0); + if (!news_socket()) return(0); + return(news_create()); +} + +news_write_packet(buf) + +struct dsc$descriptor_s *buf; +{ + static int n,len; + + len = buf->dsc$w_length; +#if CMU + if (!(sys$qiow(0,s,IO$_WRITEVBLK,&iosb,0,0,buf->dsc$a_pointer, + len,0,!mode,0,0) & 1) + || !(iosb.status & 1)) return(0); +#else + if (!(sys$qiow(0,s,IO$_WRITEVBLK,&iosb,0,0,buf->dsc$a_pointer, + len,0,0,0,0) & 1) + || !(iosb.status & 1)) return(0); +#endif + + return(1); +} + +news_write_packet_bullcp(efn,biosb,astadr,astprm,buf,len) +int *biosb,*astadr,*astprm,*efn,*buf,*len; +{ +#if CMU + if (!(sys$qio(*efn,s,IO$_WRITEVBLK,biosb,astadr,*astprm,buf, + *len,0,!mode,0,0) & 1)) return(0); +#else + if (!(sys$qio(*efn,s,IO$_WRITEVBLK,biosb,astadr,*astprm,buf, + *len,0,0,0,0) & 1)) return(0); +#endif + + return(1); +} + +news_read_packet(buf) +struct dsc$descriptor_s *buf; +{ + static int n,len; + + len = buf->dsc$w_length; + if (!(sys$qiow(0,s,IO$_READVBLK,&iosb,0,0,buf->dsc$a_pointer, + len,0,0,0,0) & 1) + || !(iosb.status & 1)) return(0); + n = iosb.size; + + return(n); +} + +news_gethostname(buf) + +struct dsc$descriptor_s *buf; +{ + if (mode == DECNET) return (-1); +#if MULTINET + return(GETHOSTNAME1(buf->dsc$a_pointer, buf->dsc$w_length)); +#else +#if TWG + return(gethostname(buf->dsc$a_pointer, buf->dsc$w_length)); +#else + return(-1); +#endif +#endif +} +$eod +$copy/log sys$input HANDOUT.TXT +$deck + Introduction to BULLETIN on the Vax + 2/88 AW + +PUBLISHED BY THE DREW UNIVERSITY ACADEMIC COMPUTER CENTER. MAY BE +COPIED WITH WRITING CREDIT GIVEN TO DREW UNIVERSITY. + +BULLETIN was written for the Public Domain by Mark London at MIT. + + The BULLETIN utility permits a user to create messages for +reading by other users. Users may be notified upon logging on +that new messages have been added, and what the topic of the +messages are. Actual reading of the messages is optional. (See +the command SET READNEW for info on automatic reading.) Messages +are automatically deleted when their expiration data has passed. + The program runs like VAX mail. The different interest +groups or BULLETIN boards are implemented in the form of +'Folders', just like a filing cabinet. A Folder contain various +messages on the same general topic. A message is a piece of text +written by a user or staff person and added to a particular +folder. All users are not permitted to submit messages to all +folders. + + A message consists of an expiration date, a subject line +and the text of the message. BULLETIN will prompt the user for +these things when a message is being added. + + Several different folders are currently defined to +BULLETIN. The General Folders will be used by Computer Center +Staff to post messages of general interest concerning the VAX to +the user community. If something is of an important nature, it +will be posted in the General folder as a 'System' message. +This is a special message type. It will be displayed to each +user as they log in the first time after that message was +posted. This will be done automatically by BULLETIN on login. +Once a particular system message has been displayed, it will not +be displayed for that user on subsequent logins. + +Folders + + Different folders have been created to contain messages on +different topics. Folders may be public, semi-private, or +private. The majority of the folders will be public. However a +few will be semi-private, which will mean that all users may +read messages in the folder but not all will be able to post to +it. Currently, there are several folders defined: + +GENERAL -- system messages + +PUBLIC_ANNOUNCEMENTS -- Can be used by anyone to post messages +of interest to the public + +On Beta: +AIDE STATION -- Private folder for Computer Center Employees + +In addition on Alpha there are folders that receive electronic +magazines, such as: +NETMONTH -- The monthly magazine of BITNET information. +RISKS -- Identifying the risks involved in using computers. +INFOIBMPC -- Information about the IBM personal computers. +INFOVAX -- Information on the Digital VAX. +PROGRAMMING_JOURNALS-Includes MINIX, UNIX and C, Modula-2 and +Prolog journals +watch for new ones being added. + +Using BULLETIN + + BULLETIN is invoked by type the command 'BULLETIN' (or BULL, +for short) at the '$' prompt. BULLETIN will display its prompt +'BULLETIN>'. Help is available from DCL command level ($) or from +within the BULLETIN program itself by typing the word 'HELP'. To +leave the BULLETIN program, type 'EXIT'. + +To see what is there + + In order to see message and folders, on can use the +'Directory' command. Upon entering BULLETIN, the user is place +in the General folder. If the user wishes to see which folders +exist, the directory/folders command is used. for example: +typing: + + BULLETIN> directory/folders + +will make a display like: + + Folder Owner + *GENERAL SYSTEM + *PUBLIC_ANNOUNCEMENTS BBEYER + NETMONTH BITNET + *VAX_SIG BBEYER + +An asterisk (*) next to the folder name indicates you have unread +messages in that folder. + +The command 'DIRECTORY/FOLDERS/DESCRIBE' would list all available +folders, along with a brief description of each. + + To switch from one folder to another folder, the user may +execute the 'SELECT' command. For example, the following +command would show what a user would do to switch to the folder +called PUBLIC_ANNOUNCEMENTS: + +BULLETIN> SELECT PUBLIC_ANNOUNCEMENTS + +and BULLETIN would respond: + Folder has been set to PUBLIC_ANNOUNCEMENTS + + Now the user may get a list of the messages in this folder +by issuing the directory command with no qualifiers. +This command, for example: +BULLETIN> DIRECTORY +would have bulletin respond: + + # Description From Date + 1 CHRISTMAS PARTY oleksiak 26-JUN-88 + 2 Learning about BULLETIN oleksiak 26-JUN-87 + 3 VAX MAIL LLLOYD 01-Jan-87 + + The command 'DIR/NEW' will list just unread messages. + + +Reading messages + + In order to read messages in a folder, the user may type +the read command or he/she may simply type the number of the +message he wishes to read. The message numbers can be acquired +by doing the 'DIRECTORY' command. If the user hits a carriage +return with no input whatsoever, BULLETIN will type the first +message in the folder, or if there are new messages present, it +will type the first new message in the folder. + + If a folder contains the above messages (as seen by the +'Directory' command) then these messages can be read by: + +BULLETIN> READ +and BULLETIN would respond: + +Message number: 1 PUBLIC_ANNOUNCEMENTS +Description: CHRISTMAS PARTY +Date: 26-JUN-1988 8:08:40 Expires: 1-JAN-1989 08:08:40 + +...Body of message..... + + Should the user only wish to see message number 3, he can +enter the 'READ' command with the message number as a parameter. +for example: + +BULLETIN> READ 3 + + There are three other useful commands that can be used at +the 'BULLETIN>' prompt when reading messages. These are: + +BACK - Read the message preceding the message currently being +read. + +CURRENT - Start reading the current message at the top. This is +useful for someone who is reading a message and wishes to reread +it from the beginning. + +NEXT - Start reading from the beginning of the next message. +This is handy if the user is reading a very long message and +wants to skip to the next one. + +Saving the interesting stuff. + + If the user sees something which he/she wants a copy of, +the extract command can be use to write an ASCII copy of the +message into a file. This command works on the current message +being read. It requires the name of the file into which to save +the message. If the file name is not given, the user will be +prompted for it. For example: + +BULLETIN> Read 2 + +********** Message on Screen ******** + +A person could then type +BULLETIN> extract +file: FV.TXT +BULLETIN> + +BULLETIN has now saved the contents of message number 2 into the +file name 'FV.txt'. + If the file to which the user is writing already exists, +BULLETIN will append the message to the file. The user can +force BULLETIN to write a new file containing only the message +being saved by using the '/new' qualifier in the 'extract' +command. These messages can then be sent to other users, or +downloaded for use in Wordperfect. (See "Mail on the Vax", or +"Transferring a file between a PC and the VAX"). + +This command may be useful if you wish to transfer the message to +your PC, perhaps using a BITNET journal message as a reference in +a paper. Once the file is saved, you can transfer it to a PC by +following the instructions in the handout 'Transferring files +from the PC to the VAX of from the VAX to a PC". + +Adding messages + A user may add a message to a folder by selecting the +folder and then using the 'ADD' command. This is provided that +the user is adding the message to a public folder. The user has +the option of giving the 'ADD' command and typing a message using +the VAX editor or uploading a message from your PC (see +documentation), or add a message you have extracted from VAX +mail. BULLETIN will prompt for the expiration date and subject +line. It will then add the text of the file as the body of the +message. To add a message that is stored in a file (from MAIL or +from your PC, for example) type: + + ADD filename + +If the user does not specify a file name, he/she will be +prompted to enter the body of the message. The user may also +use the EDT text editor by issuing the command with the +'/EDIT'option. + +For example: +BULLETIN> sel PUBLIC_ANNOUNCEMENTS + folder has been set to PUBLIC_ANNOUNCEMENTS +BULLETIN> ADD MESS.TXT + +IT IS 10-JUL-1988 12:41:06.15. SPECIFY WHEN THE MESSAGE SHOULD +EXPIRE: ENTER ABsolute TIME: + +The above session adds the text in the file 'mess.txt' as the +next message in the PUBLIC_ANNOUNCEMENTS Folder. The message +will be deleted automatically on the 20th of July as requested +by the user adding the message. + +Asking BULLETIN to notify you of new messages upon logging in. + + If the user wishes to get notification on login when new +messages are in a folder, he should use the 'READNEW' option. +This command does not force the reader to reading new messages, +only gives notification. To do this, 'SELECT' each folder you +are interested in and do a 'SET READNEW' command while set to +that folder. + +Example: + +BULLETIN> Select PUBLIC_ANNOUNCEMENTS +folder has been set to PUBLIC_ANNOUNCEMENTS +BULLETIN> SET READNEW + +Alternately, you may type SET SHOWNEW. This will just display a +message notifying you that there are new messages. + +Mailing a BULLETIN message + + A user may directly mail another user a message found in the +BULLETIN. While reading the message that he/she desires to send, +at the 'BULLETIN>' type 'MAIL'. The Vax will then ask to whom +you wish to send the information too. + +Check the BULLETIN DISCUSSION folder on ALPHA for new additions. +If you have comments or questions about BULLETIN, leave them +there. +$eod +$copy/log sys$input INSTRUCT.TXT +$deck +This message is being displayed by the BULLETIN facility. This is a non-DEC +facility, so it is not described in the manuals. Messages can be submitted by +using the BULLETIN command. System messages, such as this one, are displayed +in full, but can only be entered by privileged users. Non-system messages can +be entered by anyone, but only their topics will be displayed at login time, +and will be prompted to optionally read them. (This prompting feature can be +disabled). All bulletins can be reread at any time unless they are deleted or +expire. For more information, see the on-line help (via HELP BULLETIN). +$eod +$copy/log sys$input NEWS.TXT +$deck +BULLETIN now has the capability to read and post messages to USENET NEWS in a +client mode. I realize that there are many NEWS readers, some with much more +elegant interfaces. However, I elected to modify BULLETIN for the following +reason: We have many decnet nodes, but only several are internet nodes. Our +only access to a news server was via internet. In order for those +non-internet nodes to read USENET, the only method that seemed available was to +run a NEWS server program on one of our own internet nodes so that it could +be accessible via decnet. I did not want to do that, as that requires storing +the news groups on disk, and I do not have the room for that. I thus added the +ability in BULLETIN (actually BULLCP) so that it acts as as a gateway between +decnet and tcp for NEWS. This method does not require spawning any processes, +since the detached process BULLCP is always present, so the access is very +fast. Also, since BULLETIN uses a shared database to store info on the NEWS +groups and periodically updates it, there is no need for that to be done when a +user accesses the NEWS groups. Several other NEWS readers do this when you run +them, which is why they take a long time to start up. It is also possible to +feed NEWS groups into a "real" BULLETIN folder, so that the messages are saved +on disk. + +Presently, BULLETIN can be used with either UCX, MULTINET, or CMU TCP/IP +packages (and of course DECNET) for reading NEWS. Support for other packages +can be added if I can find sites willing to beta test the interface for me. +The source for the TCP interface is in C rather than FORTRAN because the +MULTINET include files are in C. However, if you do not have C, I will be glad +to send the object for it (or to even possibly rewrite the code in FORTRAN). + +The instructions for installation are as follows. Define BULL_NEWS_SERVER +to be a system logical name pointing to either your internet or decnet NEWS +node. If it is decnet, simply specify the decnet node name, i.e. + + $ DEFINE/SYSTEM BULL_NEWS_SERVER NERUS + +BULLETIN decides to use DECNET rather than TCP access based on the node name. +If it does not have any periods in it, then it assumes it is a DECNET node. + +In our cluster, we usually have one node which is an internet node, and the +rest non-internet nodes. If you have a similar situation, you'll have to +create a startup procedure that defines BULL_NEWS_SERVER to be the internet +news server address only on the node (or nodes) on the cluster that have +actually internet access. The other nodes will have BULL_NEWS_SERVER defined +as the decnet node name that BULLCP is running on in the cluster. (Of course, +BULLCP will have to be running on a node with internet access.) + +NOTE: If you want to disable the gateway feature, then before starting BULLCP, +define the logical name: + + $ DEFINE/SYSTEM BULL_NO_NEWS_GATEWAY "TRUE" + +Defining this will only shut off the gateway. BULLETIN will still be allowed +to read NEWS from the local node as long as BULL_NEWS_SERVER is defined. + +You can also specify that BULLCP is only to act as a NEWS gateway. This is to +allow adding the news gateway to an INTERNET site that you have DECNET access +to, but which does not want to make use of any of the other BULLETIN features. +You would specify the following command before starting BULLCP: + + $ DEFINE/SYSTEM BULL_NEWS_GATEWAY_ONLY "TRUE" + +In order to post messages, BULLETIN needs to know the internet nodename of +the local host. This is done automatically for nodes running MULTINET. For +other nodes, BULLETIN attempts to translate the logical name ARPANET_HOST_NAME, +INTERNET_HOST_NAME, and MX_NODE_NAME. If you are on a DECNET node that is not +on INTERNET (and is not part of a cluster which has an INTERNET address), but +you are accessing NEWS via DECNET, you can specify the hostname as follows: + + $ DEFINE/SYSTEM INTERNET_HOST_NAME "%localhost@internet-address" + +Where "localhost" is your local decnet hostname, and "internet-address" is the +internet address of the gateway node. + +The local time zone is detected by looking at the following logical names: +LISP$TIME_ZONE, MULTINET_TIMEZONE, or PMDF_TIMEZONE. (LISP$TIME_ZONE is +defined if you have LISP installed.) + +The name of the organization is included in the header of the NEWS message. +This can be anything, but usually is the company or university name. This +can be hardcoded into the source by putting in BULLNEWS.INC, or by defining +the system logical name BULL_NEWS_ORGANIZATION. + +The name of the mail protocol to use for responding by mail to NEWS messages +can also be either hardcoded by putting in BULLNEWS.INC, or by defining the +system logical name BULL_NEWS_MAILER. + +After installing the new BULLETIN, execute the command NEWS, which asks for a +list of all the news groups. Because this is the first time it is executed, it +will cause a load of all the remote news groups into a local data base +(BULL_DIR:BULLNEWS.DAT). This will take several minutes to do. It is the only +time that this load will be done interactively. Afterwards, BULLCP will +periodically update the data base. For this reason, it is highly recommeded +that BULLCP be installed. BULLCP will update NEWS every hour. If you want to +change this frequency, define the logical name BULL_NEWS_UPDATE to the number +of minutes in between updates, i.e. DEFINE/SYSTEM BULL_NEWS_UPDATE "30" for 30 +minutes. NOTE: BULLCP will create a subprocess BULLCP NEWS which does the +update. You can watch how long it takes for this to run in order to determine +if you want to change the update period). After BULLNEWS.DAT is created, it is +suggested that you run OPTIMIZE_RMS.COM on it, as it will cause the file to be +compressed and will allow updates to run much faster (factor of 5 or more). + +WARNING: One user discovered that his server (using bnews?) had a bug which +caused the updates to cause bogus "new messages" notifications for subscribed +NEWS group when entering BULLETIN. If you experience this problem, try +defining the system logical name BULL_SPECIAL_NEWS_UPDATE. This will cause +the update to use a different algorithm which should eliminate the problem, +although it requires much more time to execute. + +It is possible to automatically have news messages to be fed into a real +folder. Place the name of the news group into the folder description surrounded +by <>, i.e. . It must be in lower case. (Other text is allowed in +the description, i.e. "THIS IS A TEST FOLDER ".) When the POST and +ADD commands are used with this folder, the messages will be posted to the news +group, rather than actually being added to the folder. If you want several +news groups to be fed to the same folder, create a file with each group on a +separate line in the file, and then specify the filename inside the <> preceded +by @, i.e. <@SYS$MANAGER:TEST.FIL>. However, with a multiple feed, POSTs will +not work. + +If you have any problems or questions, please let me know. + MRL +P.s. + If you do not know what USENET NEWS, it's basically news messages which +are passed between nodes. Originally it was limited to USENET, but that is no +longer the case. Unlike internet mailing lists which use MAIL to send the +messages to individuals, NEWS messages are not sent via MAIL. They are passed +between nodes using a special protocol, NNTP. Users must use a NEWS reader +package to read them. However, it is possible to read NEWS remotely over a +network, and therefore avoiding having to actually store the messages. +BULLETIN is setup to be used mainly in this client mode, i.e. it can read +messages on another node via TCP or DECNET. This is useful, since the number +of NEWS groups total over 1000, the disk space required for storage is very +high. If you are interested in finding a server node that would allow you to +read NEWS, and do not know of one (i.e. a USENET node), I know of no official +way of doing so. However, one suggestion was to try connecting to BBN.COM via +ANONYMOUS FTP and look through the directory uumap/comp.mail.maps to find a +USENET node near you to contact. +$eod +$copy/log sys$input NONSYSTEM.TXT +$deck +Non-system bulletins (such as this) can be submitted by any user. Users are +alerted at login time that new non-system bulletins have been added, but only +their topics are listed. Optionally, users can be prompted at login time to +see if they wish to read the bulletins. When reading the bulletins in this +manner, the bulletins can optionally be written to a file. If you have the +subdirectory [.BULL] created, BULLETIN will use that directory as the default +directory to write the file into. + +A user can disable this prompting featuring by using BULLETIN as follows: + +$ BULLETIN +BULLETIN> SET NOREADNEW +BULLETIN> EXIT + +Afterwords, the user will only be alerted of the bulletins, and will have to +use the BULLETIN utility in order to read the messages. +$eod +$copy/log sys$input WRITEMSG.TXT +$deck +BULLETIN contains subroutines for writing a message directly to a folder. This +would be useful for someone who is using the BBOARD feature, but wants to avoid +the extra overhead of having the message sent to an account as MAIL, and then +have BULLCP read the mail. It is better if the network mail could be written +directly to the folder bypassing VMS MAIL, as it reduces a lot of cpu overhead. + +Call INIT_MESSAGE_ADD to initiate a message addition. +Call WRITE_MESSAGE_LINE to write individual message lines. +Call FINISH_MESSAGE_ADD to complete a message addition. + +Calling formats: + + CALL INIT_MESSAGE_ADD(IN_FOLDER,IN_FROM,IN_DESCRIP,IER) +C +C INPUTS: +C IN_FOLDER - Character string containing folder name +C IN_FROM - Character string containing name of owner of message. +C If empty, the default is the owner of the process. +C IN_DESCRIP - Character string containing subject of message. +C If empty, the message is searched for a line +C which starts with "Subj:" or "Subject:". +C OUTPUTS: +C IER - Error status. True if properly connected to folder. +C False if folder not found. +C + + CALL WRITE_MESSAGE_LINE(BUFFER) +C +C INPUTS: +C BUFFER - Character string containing line to be put into message. +C + + CALL FINISH_MESSAGE_ADD +C +C NOTE: Only should be run if INIT_MESSAGE_ADD was successful. +C +$eod diff --git a/decus/vax91b/gce91b/net91b/bullet2.com b/decus/vax91b/gce91b/net91b/bullet2.com new file mode 100644 index 0000000..a08ced4 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bullet2.com @@ -0,0 +1,1599 @@ +$set nover +$copy/log sys$input BOARD_DIGEST.COM +$deck +$! +$! BOARD_DIGEST.COM +$! +$! Command file invoked by folder associated with a BBOARD which is +$! is specified with /SPECIAL. It will convert "digest" mail and +$! split it into separate messages. This type of mail is used in +$! certain Arpanet mailing lists, such as TEXHAX and INFO-MAC. +$! +$ FF[0,8] = 12 ! Define a form feed character +$ SET PROTECT=(W:RWED)/DEFAULT +$ SET PROC/PRIV=SYSPRV +$ USER := 'F$GETJPI("","USERNAME") +$ EXTRACT_FILE = "BULL_DIR:" + "''USER'" + ".TXT" +$ DEFINE/USER EXTRACT_FILE BULL_DIR:'USER' +$ MAIL +READ +EXTRACT EXTRACT_FILE +DELETE +$ OPEN/READ INPUT 'EXTRACT_FILE' +$ OPEN/WRITE OUTPUT 'EXTRACT_FILE' +$ READ INPUT FROM_USER +$AGAIN: +$ READ/END=ERROR INPUT BUFFER +$ IF F$EXTRACT(0,3,BUFFER) .NES. "To:" THEN GOTO SKIP +$ USER = F$EXTRACT(4,F$LEN(BUFFER),BUFFER) +$ GOTO AGAIN1 +$SKIP: +$ IF F$EXTRACT(0,15,BUFFER) .NES. "---------------" THEN GOTO AGAIN +$AGAIN1: +$ READ/END=ERROR INPUT BUFFER +$ IF F$EXTRACT(0,15,BUFFER) .NES. "---------------" THEN GOTO AGAIN1 +$ FROM = " " +$ SUBJ = " " +$NEXT: +$ READ/END=EXIT INPUT BUFFER +$FROM: +$ IF F$EXTRACT(0,5,BUFFER) .NES. "From:" THEN GOTO SUBJECT +$ FROM = BUFFER +$ GOTO NEXT +$SUBJECT: +$ IF F$EXTRACT(0,8,BUFFER) .NES. "Subject:" THEN GOTO NEXT +$ SUBJ = BUFFER - "Subject:" +$F2: +$ IF F$LENGTH(SUBJ) .EQ. 0 THEN GOTO WRITE +$ IF F$EXTRACT(0,1,SUBJ) .NES. " " THEN GOTO WRITE +$ SUBJ = F$EXTRACT(1,F$LENGTH(SUBJ),SUBJ) +$ GOTO F2 +$WRITE: +$ WRITE OUTPUT FROM_USER + ! Write From: + TAB + USERNAME +$ WRITE OUTPUT "To: " + USER + ! Write To: + TAB + BBOARDUSERNAME +$ WRITE OUTPUT "Subj: " + SUBJ + ! Write Subject: + TAB + mail subject +$ WRITE OUTPUT "" ! Write one blank line +$ IF FROM .NES. " " THEN WRITE OUTPUT FROM +$READ: +$ READ/END=EXIT/ERR=EXIT INPUT BUFFER +$ IF F$EXTRACT(0,15,BUFFER) .EQS. "---------------" THEN GOTO READ1 +$ WRITE OUTPUT BUFFER +$ GOTO READ +$READ1: +$ READ/END=EXIT/ERR=EXIT INPUT BUFFER +$ IF F$LOCATE(":",BUFFER) .EQ. F$LENGTH(BUFFER) THEN GOTO READ1 +$ WRITE OUTPUT FF +$ FROM = " " +$ SUBJ = " " +$ GOTO FROM +$EXIT: +$ CLOSE INPUT +$ CLOSE OUTPUT +$ PUR 'EXTRACT_FILE' +$ EXIT +$ERROR: +$ CLOSE INPUT +$ CLOSE OUTPUT +$ DELETE 'EXTRACT_FILE'; +$eod +$copy/log sys$input BOARD_SPECIAL.COM +$deck +$! +$! BOARD_SPECIAL.COM +$! +$! Command file invoked by folder associated with a BBOARD which is +$! is specified with /SPECIAL. This can be used to convert data to +$! a message via a different means than the VMS mail. This is done by +$! converting the data to look like output created by the MAIL utility, +$! which appears as follows: +$! +$! First line is 0 length line. +$! Second line is "From:" followed by TAB followed by incoming username +$! Third line is "To:" followed by TAB followed by BBOARD username +$! Fourth line is "Subj:" followed by TAB followed by subject +$! The message text then follows. +$! Message is ended by a line containing a FORM FEED. +$! +$! This command file should be put in the BBOARD_DIRECTORY as specified +$! in BULLFILES.INC. You can also have several different types of special +$! procedures. To accomplish this, rename the file to the BBOARD username. +$! i.e. if you specify SET BBOARD FOO/SPECIAL, you could name the file +$! FOO.COM and it will execute that rather than BOARD_SPECIAL.COM. +$! +$! The following routine is the one we use to convert mail from a non-DEC +$! mail network. The output from this mail is written into a file which +$! is slightly different from the type outputted by MAIL. +$! +$! (NOTE: A username in the SET BBOARD command need only be specified if +$! the process which reads the mail requires that the process be owned by +$! a specific user, which is the case for this sample, and for that matter +$! when reading VMS MAIL. If this is not required, you do not have to +$! specify a username.) +$! +$ USERNAME := 'F$GETJPI("","USERNAME")' ! This trims trailing spaces +$ IF F$SEARCH("MFE_TELL_FILES:"+USERNAME+".MAI") .EQS. "" THEN EXIT +$ SET DEFAULT BULL_DIR: ! BULLETIN looks for text in BBOARD directory +$ SET PROTECT=(W:RWED)/DEFAULT +$ IF F$SEARCH("MFEMSG.MAI") .NES. "" THEN - + DELETE MFEMSG.MAI;* ! Delete any leftover output files. +$ MSG := $MFE_TELL: MESSAGE +$ DEFINE/USER SYS$COMMAND SYS$INPUT +$ MSG ! Read MFENET mail +copy * MFEMSG +delete * +exit +$ FF[0,8] = 12 ! Define a form feed character +$ OPEN/READ/ERROR=EXIT INPUT MFEMSG.MAI +$ OUTNAME = USERNAME+".TXT" ! Output file will be 'USERNAME'.TXT +$ OPEN/WRITE OUTPUT 'OUTNAME' +$ READ/END=END INPUT DATA ! Skip first line in MSG output +$HEADER: +$ FROM = "" +$ SUBJ = "" +$ MFEMAIL = "T" +$NEXTHEADER: +$ IF (FROM.NES."") .AND. (SUBJ.NES."") THEN GOTO SKIPHEADER +$ READ/END=END INPUT DATA ! Read header line in MSG output +$ IF DATA .EQS. "" THEN GOTO SKIPHEADER ! Missing From or Subj ?? +$ IF FROM .NES. "" THEN GOTO SKIPFROM +$ IF F$LOCATE("From: ",DATA) .NES. 0 THEN GOTO 10$ +$ MFEMAIL = "F" +$ FROM= F$EXTRACT(6,F$LENGTH(DATA),DATA) +$ GOTO NEXTHEADER +$10$: +$ IF F$LOCATE("Reply-to: ",DATA) .NES. 0 THEN GOTO 20$ +$ MFEMAIL = "F" +$ FROM= F$EXTRACT(10,F$LENGTH(DATA),DATA) +$ GOTO NEXTHEADER +$20$: +$ IF F$LOCATE("From ",DATA) .NES. 0 THEN GOTO SKIPFROM +$ FROM= F$EXTRACT(5,F$LENGTH(DATA),DATA) +$ GOTO NEXTHEADER +$SKIPFROM: +$ IF SUBJ .NES. "" THEN GOTO SKIPSUBJ +$ IF F$LOCATE("Subject",DATA) .NES. 0 THEN GOTO SKIPSUBJ +$ SUBJ= F$EXTRACT(F$LOCATE(": ",DATA)+2,F$LENGTH(DATA),DATA) +$ GOTO NEXTHEADER +$SKIPSUBJ: +$ GOTO NEXTHEADER +$SKIPHEADER: +$ WRITE OUTPUT "From: " + FROM + ! Write From: + TAB + USERNAME +$ WRITE OUTPUT "To: " + USERNAME + ! Write To: + TAB + BBOARDUSERNAME +$ WRITE OUTPUT "Subj: " + SUBJ + ! Write Subject: + TAB + mail subject +$ WRITE OUTPUT "" ! Write one blank line +$ IF (DATA.EQS."") .OR. MFEMAIL THEN GOTO SKIPBLANKS +$50$: +$ READ/END=END INPUT DATA ! Skip rest of main header +$ IF DATA .NES. "" THEN GOTO 50$ +$60$: +$ READ/END=END INPUT DATA ! Skip all of secondary header +$ IF DATA .NES. "" THEN GOTO 60$ +$SKIPBLANKS: +$ READ/END=END INPUT DATA ! Skip all blanks +$ IF DATA .EQS. "" THEN GOTO SKIPBLANKS +$NEXT: ! Read and write message text +$ WRITE OUTPUT DATA +$ IF DATA .EQS. FF THEN GOTO HEADER + ! Multiple messages are seperated by form feeds +$ READ/END=END INPUT DATA +$ GOTO NEXT +$END: +$ CLOSE INPUT +$ CLOSE OUTPUT +$ DELETE MFEMSG.MAI; +$EXIT: +$ EXIT +$eod +$copy/log sys$input BULLCOM.CLD +$deck +! +! BULLCOM.CLD +! +! VERSION 8/20/91 +! + MODULE BULLETIN_SUBCOMMANDS + + DEFINE VERB ADD + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER ALL, NONNEGATABLE + QUALIFIER BELL, NONNEGATABLE + QUALIFIER BROADCAST, NONNEGATABLE + DISALLOW NOT BROADCAST AND ALL + DISALLOW NOT BROADCAST AND BELL + QUALIFIER CC, VALUE(LIST,REQUIRED) + QUALIFIER CLUSTER, DEFAULT + QUALIFIER EDIT, NEGATABLE + QUALIFIER EXPIRATION, NONNEGATABLE, VALUE + QUALIFIER EXTRACT, NONNEGATABLE + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER GROUPS, VALUE(LIST,REQUIRED) + QUALIFIER NODES, LABEL=NODES, VALUE(REQUIRED,LIST) + NONNEGATABLE + QUALIFIER LIST,DEFAULT + QUALIFIER LOCAL, NONNEGATABLE + DISALLOW LOCAL AND NOT BROADCAST + DISALLOW NODES AND SELECT_FOLDER + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT EXTRACT + QUALIFIER PERMANENT, NONNEGATABLE + QUALIFIER SHUTDOWN, NONNEGATABLE, VALUE + DISALLOW PERMANENT AND SHUTDOWN + QUALIFIER SUBJECT, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER SYSTEM, NONNEGATABLE + DEFINE VERB ATTACH + PARAMETER P1, LABEL=PROCESS, VALUE(TYPE=$FILE) + QUALIFIER PARENT + DISALLOW NOT PARENT AND NOT PROCESS + DISALLOW PARENT AND PROCESS + DEFINE VERB BACK + QUALIFIER EDIT, NEGATABLE + QUALIFIER HEADER + DEFINE VERB CHANGE + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER EDIT, NEGATABLE + QUALIFIER EXPIRATION, NONNEGATABLE, VALUE + QUALIFIER GENERAL, NONNEGATABLE + QUALIFIER HEADER, NONNEGATABLE + QUALIFIER SUBJECT, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER NEW,NONNEGATABLE + QUALIFIER NUMBER, VALUE(TYPE=$FILE,REQUIRED) + QUALIFIER PERMANENT, NONNEGATABLE + QUALIFIER SHUTDOWN, NONNEGATABLE, VALUE + QUALIFIER SYSTEM,NONNEGATABLE + QUALIFIER TEXT, NONNEGATABLE + DISALLOW ALL AND NUMBER + DISALLOW NEW AND NOT EDIT + DISALLOW SYSTEM AND GENERAL + DISALLOW PERMANENT AND SHUTDOWN + DISALLOW PERMANENT AND EXPIRATION + DISALLOW SHUTDOWN AND EXPIRATION + DISALLOW SUBJECT AND HEADER + DEFINE VERB COPY + PARAMETER P1, LABEL=FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER GROUPS, VALUE(LIST,REQUIRED) + QUALIFIER HEADER + QUALIFIER ALL + QUALIFIER MERGE + QUALIFIER ORIGINAL + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB CREATE + QUALIFIER ALWAYS, NONNEGATABLE + QUALIFIER BRIEF, NONNEGATABLE + QUALIFIER DESCRIPTION, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER ID, NONNEGATABLE +! +! Make the following qualifier DEFAULT if you want CREATE to be +! a privileged command. NOTE: Make sure that BULL_DIR:BULLUSER.DAT +! has the following protection: (RWED,RWED,,) +! + QUALIFIER NEEDPRIV, NONNEGATABLE + QUALIFIER NODE, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER NOTIFY, NONNEGATABLE + QUALIFIER OWNER, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER PRIVATE, NONNEGATABLE + QUALIFIER READNEW, NONNEGATABLE + QUALIFIER REMOTENAME, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER SEMIPRIVATE, NONNEGATABLE + QUALIFIER SHOWNEW, NONNEGATABLE + QUALIFIER SYSTEM, NONNEGATABLE + PARAMETER P1, LABEL=CREATE_FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + DISALLOW ID AND NOT OWNER + DISALLOW PRIVATE AND SEMIPRIVATE + DISALLOW BRIEF AND READNEW + DISALLOW SHOWNEW AND READNEW + DISALLOW BRIEF AND SHOWNEW + DISALLOW NODE AND (NOTIFY OR PRIVATE OR SEMIPRIVATE) + DISALLOW REMOTENAME AND NOT NODE + DEFINE VERB CURRENT + QUALIFIER EDIT + QUALIFIER HEADER + DEFINE VERB DELETE + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER IMMEDIATE,NONNEGATABLE + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER NODES, LABEL=NODES, VALUE(REQUIRED,LIST) + QUALIFIER SUBJECT, VALUE(REQUIRED) + DISALLOW NOT SUBJECT AND (NODES OR SELECT_FOLDER) + DISALLOW NODES AND SELECT_FOLDER + DEFINE VERB DIRECTORY + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER ALL + QUALIFIER NEWS, SYNTAX=DIRECTORY_NEWS, NONNEGATABLE + QUALIFIER END, VALUE(REQUIRED,TYPE=$NUMBER), NONNEGATABLE + QUALIFIER EXPIRATION + QUALIFIER FO, SYNTAX=DIRECTORY_FOLDER, NONNEGATABLE + QUALIFIER FOLDER, SYNTAX=DIRECTORY_FOLDER, NONNEGATABLE + QUALIFIER NEW + QUALIFIER PRINT + QUALIFIER HEADER, DEFAULT + QUALIFIER NOTIFY, DEFAULT + QUALIFIER QUEUE, VALUE(DEFAULT=SYS$PRINT), NONNEGATABLE + QUALIFIER FORM, VALUE, NONNEGATABLE + QUALIFIER NOW + QUALIFIER START, VALUE(REQUIRED,TYPE=$NUMBER), NONNEGATABLE + QUALIFIER SINCE,VALUE(DEFAULT="TODAY",TYPE=$DATETIME) + QUALIFIER MARKED, NONNEGATABLE + QUALIFIER UNMARKED, NONNEGATABLE + QUALIFIER REPLY, NONNEGATABLE + QUALIFIER SEARCH, VALUE(REQUIRED), NONNEGATABLE + QUALIFIER SEEN, NONNEGATABLE + QUALIFIER UNSEEN, NONNEGATABLE + QUALIFIER SUBJECT, VALUE(REQUIRED), NONNEGATABLE + DISALLOW (SUBJECT AND SEARCH) OR (SEARCH AND REPLY) + DISALLOW REPLY AND SUBJECT + DISALLOW (REPLY OR SUBJECT OR SEARCH) AND + (MARKED OR SEEN OR UNMARKED OR UNSEEN) + DISALLOW (MARKED AND SEEN) OR (MARKED AND UNSEEN) OR + (UNMARKED AND SEEN) OR (UNMARKED AND UNSEEN) + DISALLOW ALL AND (MARKED OR SEEN OR UNMARKED OR UNSEEN) + DISALLOW (NEW AND SINCE) OR (START AND NEW) OR (START AND SINCE) + DEFINE SYNTAX DIRECTORY_NEWS + PARAMETER P1, LABEL=MATCH_FOLDER + QUALIFIER START, VALUE(REQUIRED), NONNEGATABLE + QUALIFIER NEWS, DEFAULT, NONNEGATABLE + QUALIFIER SUBSCRIBE + QUALIFIER FOLDER + QUALIFIER NEWGROUPS + DISALLOW NEWGROUPS AND (SUBSCRIBE OR START) + DEFINE SYNTAX DIRECTORY_FOLDER + PARAMETER P1, LABEL=MATCH_FOLDER + QUALIFIER START, VALUE(REQUIRED), NONNEGATABLE + QUALIFIER DESCRIBE + QUALIFIER FOLDER, DEFAULT + QUALIFIER NEWS, NONNEGATABLE + DEFINE VERB E ! EXIT command. + DEFINE VERB EX ! EXIT command. + DEFINE VERB EXIT ! EXIT command. + DEFINE VERB EXTRACT + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE,REQUIRED), + PROMPT="File" + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER FF + QUALIFIER HEADER, DEFAULT + QUALIFIER NEW, NONNEGATABLE + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB FILE + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE,REQUIRED), + PROMPT="File" + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER FF + QUALIFIER HEADER, DEFAULT + QUALIFIER NEW, NONNEGATABLE + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB FIRST + QUALIFIER EDIT, NEGATABLE + QUALIFIER HEADER + DEFINE VERB FORWARD + PARAMETER P1, LABEL=RECIPIENTS, PROMPT="Recipients" + VALUE(REQUIRED,IMPCAT,LIST) + QUALIFIER EDIT, NONNEGATABLE + QUALIFIER HEADER, DEFAULT + QUALIFIER SUBJECT, VALUE(REQUIRED) + DEFINE VERB HELP + PARAMETER P1, LABEL=HELP_FOLDER, VALUE(TYPE=$REST_OF_LINE) + DEFINE VERB INDEX + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER EXPIRATION + QUALIFIER MARKED, NONNEGATABLE + QUALIFIER UNMARKED, NONNEGATABLE + QUALIFIER FOLDER, SYNTAX=DIRECTORY_FOLDER, NONNEGATABLE + QUALIFIER NEW + QUALIFIER REPLY, NONNEGATABLE + QUALIFIER RESTART + QUALIFIER SEARCH, VALUE(REQUIRED), NONNEGATABLE + QUALIFIER SEEN, NONNEGATABLE + QUALIFIER UNSEEN, NONNEGATABLE + QUALIFIER SUBSCRIBE + QUALIFIER SUBJECT, VALUE(REQUIRED), NONNEGATABLE + QUALIFIER START, VALUE(REQUIRED,TYPE=$NUMBER), NONNEGATABLE + QUALIFIER SINCE,VALUE(DEFAULT="TODAY",TYPE=$DATETIME) + DISALLOW (NEW AND SINCE) OR (START AND NEW) OR (START AND SINCE) + DISALLOW (MARKED AND SEEN) OR (MARKED AND UNSEEN) OR + (UNMARKED AND SEEN) OR (UNMARKED AND UNSEEN) + DEFINE VERB LAST + QUALIFIER EDIT, NEGATABLE + QUALIFIER HEADER + DEFINE VERB MAIL + PARAMETER P1, LABEL=RECIPIENTS, PROMPT="Recipients" + VALUE(REQUIRED,IMPCAT,LIST) + QUALIFIER EDIT, NONNEGATABLE + QUALIFIER HEADER, DEFAULT + QUALIFIER SUBJECT, VALUE(REQUIRED) + DEFINE VERB MARK + PARAMETER P1, LABEL=NUMBER, VALUE(TYPE=$FILE,LIST) + DEFINE VERB MODIFY + QUALIFIER DESCRIPTION + QUALIFIER ID, NONNEGATABLE + QUALIFIER NAME, VALUE(REQUIRED) + QUALIFIER OWNER, VALUE(REQUIRED) + DISALLOW ID AND NOT OWNER + DEFINE VERB MOVE + PARAMETER P1, LABEL=FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + PARAMETER P2, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER ALL + QUALIFIER GROUPS, VALUE(LIST,REQUIRED) + QUALIFIER HEADER + QUALIFIER MERGE + QUALIFIER NODES + QUALIFIER ORIGINAL + QUALIFIER IMMEDIATE,NONNEGATABLE,DEFAULT + DISALLOW ALL AND BULLETIN_NUMBER + DISALLOW FOLDER AND NODES + DEFINE VERB NEWS + PARAMETER P1, LABEL=MATCH_FOLDER + QUALIFIER NEWS, DEFAULT, NONNEGATABLE + QUALIFIER START, VALUE(REQUIRED), NONNEGATABLE + QUALIFIER SUBSCRIBE + QUALIFIER NEWGROUPS + DISALLOW NEWGROUPS AND (SUBSCRIBE OR START) + DEFINE VERB N + QUALIFIER EDIT, NEGATABLE + DEFINE VERB NEXT + QUALIFIER EDIT, NEGATABLE + DEFINE VERB POST + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER CC, VALUE(LIST,REQUIRED) + QUALIFIER EXTRACT + QUALIFIER GROUPS, VALUE(LIST,REQUIRED) + QUALIFIER LIST, DEFAULT + QUALIFIER SUBJECT, VALUE(REQUIRED) + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT EXTRACT + QUALIFIER EDIT + DEFINE VERB PRINT + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + QUALIFIER HEADER, DEFAULT + QUALIFIER NOTIFY, DEFAULT + QUALIFIER QUEUE, VALUE(DEFAULT=SYS$PRINT), NONNEGATABLE + QUALIFIER FORM, VALUE, NONNEGATABLE + QUALIFIER NOW + QUALIFIER ALL + DISALLOW ALL AND BULLETIN_NUMBER + DEFINE VERB QUIT + DEFINE VERB READ + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$NUMBER) + QUALIFIER ALL + QUALIFIER EDIT + QUALIFIER HEADER + QUALIFIER MARKED, NONNEGATABLE + QUALIFIER UNMARKED, NONNEGATABLE + QUALIFIER NEW + QUALIFIER PAGE, DEFAULT + QUALIFIER SEEN, NONNEGATABLE + QUALIFIER UNSEEN, NONNEGATABLE + QUALIFIER SINCE,VALUE(DEFAULT="TODAY",TYPE=$DATETIME) + DISALLOW NEW AND SINCE + DISALLOW BULLETIN_NUMBER AND (ALL OR NEW OR SINCE) + DISALLOW (MARKED AND SEEN) OR (MARKED AND UNSEEN) OR + (UNMARKED AND SEEN) OR (UNMARKED AND UNSEEN) + DEFINE VERB REPLY + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER ALL, NONNEGATABLE + QUALIFIER BELL, NONNEGATABLE + QUALIFIER BROADCAST, NONNEGATABLE + DISALLOW NOT BROADCAST AND ALL + DISALLOW NOT BROADCAST AND BELL + QUALIFIER CC, VALUE(LIST,REQUIRED) + QUALIFIER CLUSTER, DEFAULT + QUALIFIER EDIT, NEGATABLE + QUALIFIER EXPIRATION, NONNEGATABLE, VALUE + QUALIFIER EXTRACT, NONNEGATABLE + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER GROUPS, VALUE(LIST,REQUIRED) + QUALIFIER LIST,DEFAULT + QUALIFIER LOCAL + QUALIFIER NODES, LABEL=NODES, VALUE(REQUIRED,LIST) + NONNEGATABLE + DISALLOW LOCAL AND NOT BROADCAST + DISALLOW NODES AND SELECT_FOLDER + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT EXTRACT + QUALIFIER PERMANENT, NONNEGATABLE + QUALIFIER SHUTDOWN, NONNEGATABLE, VALUE + DISALLOW PERMANENT AND SHUTDOWN + QUALIFIER SUBJECT, NONNEGATABLE, VALUE(REQUIRED) + QUALIFIER SYSTEM, NONNEGATABLE + DEFINE VERB REMOVE + PARAMETER P1, LABEL=REMOVE_FOLDER, PROMPT="Folder" + VALUE(REQUIRED) + DEFINE VERB RESPOND + PARAMETER P1, LABEL=FILESPEC, VALUE(TYPE=$FILE) + QUALIFIER CC, VALUE(LIST,REQUIRED) + QUALIFIER EXTRACT + QUALIFIER GROUPS, VALUE(LIST,REQUIRED) + QUALIFIER LIST + QUALIFIER SUBJECT, VALUE(REQUIRED) + QUALIFIER NOINDENT, NONNEGATABLE + DISALLOW NOINDENT AND NOT EXTRACT + DISALLOW GROUPS AND NOT LIST + QUALIFIER EDIT + DEFINE VERB SEARCH + PARAMETER P1, LABEL=SEARCH_STRING + QUALIFIER EDIT + QUALIFIER FOLDER, LABEL=SELECT_FOLDER, VALUE(REQUIRED,LIST) + QUALIFIER START, VALUE(TYPE=$NUMBER,REQUIRED) + QUALIFIER REPLY, NONNEGATABLE + QUALIFIER REVERSE + QUALIFIER SUBJECT + DISALLOW SEARCH_STRING AND REPLY + DEFINE VERB SEEN + PARAMETER P1, LABEL=NUMBER, VALUE(TYPE=$FILE,LIST) + QUALIFIER READ + DISALLOW (NUMBER AND (NEG READ OR READ)) + DEFINE VERB SELECT + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER MARKED, NONNEGATABLE + QUALIFIER UNMARKED, NONNEGATABLE + QUALIFIER SEEN, NONNEGATABLE + QUALIFIER UNSEEN, NONNEGATABLE + DISALLOW (MARKED AND SEEN) OR (MARKED AND UNSEEN) OR + (UNMARKED AND SEEN) OR (UNMARKED AND UNSEEN) + DEFINE VERB SET + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + QUALIFIER ID + DEFINE TYPE SET_OPTIONS + KEYWORD NODE, SYNTAX=SET_NODE + KEYWORD NONODE, SYNTAX = SET_NONODE + KEYWORD EXPIRE_LIMIT, SYNTAX=SET_EXPIRE + KEYWORD NOEXPIRE_LIMIT + KEYWORD GENERIC, SYNTAX=SET_GENERIC + KEYWORD NOGENERIC, SYNTAX=SET_GENERIC + KEYWORD LOGIN, SYNTAX=SET_LOGIN + KEYWORD NOLOGIN, SYNTAX=SET_LOGIN + KEYWORD NOBBOARD + KEYWORD BBOARD, SYNTAX=SET_BBOARD + KEYWORD NOBRIEF, SYNTAX=SET_NOFLAGS + KEYWORD BRIEF, SYNTAX=SET_FLAGS + KEYWORD NOSHOWNEW, SYNTAX=SET_NOFLAGS + KEYWORD SHOWNEW, SYNTAX=SET_FLAGS + KEYWORD NOREADNEW, SYNTAX=SET_NOFLAGS + KEYWORD READNEW, SYNTAX=SET_FLAGS + KEYWORD ACCESS, SYNTAX=SET_ACCESS + KEYWORD NOACCESS, SYNTAX=SET_NOACCESS + KEYWORD FOLDER, SYNTAX=SET_FOLDER + KEYWORD NOTIFY, SYNTAX=SET_FLAGS + KEYWORD NONOTIFY, SYNTAX=SET_NOFLAGS + KEYWORD PRIVILEGES, SYNTAX=SET_PRIVILEGES + KEYWORD DUMP + KEYWORD NODUMP + KEYWORD PAGE + KEYWORD NOPAGE + KEYWORD SYSTEM + KEYWORD NOSYSTEM + KEYWORD KEYPAD + KEYWORD NOKEYPAD + KEYWORD PROMPT_EXPIRE + KEYWORD NOPROMPT_EXPIRE + KEYWORD DEFAULT_EXPIRE, SYNTAX=SET_DEFAULT_EXPIRE + KEYWORD STRIP + KEYWORD NOSTRIP + KEYWORD DIGEST + KEYWORD NODIGEST + KEYWORD CONTINUOUS_BRIEF + KEYWORD NOCONTINUOUS_BRIEF + KEYWORD ALWAYS + KEYWORD NOALWAYS + DEFINE SYNTAX SET_NODE + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=NODENAME, VALUE(REQUIRED) + PARAMETER P3, LABEL=REMOTENAME + QUALIFIER FOLDER, VALUE(REQUIRED) + DEFINE SYNTAX SET_NONODE + QUALIFIER FOLDER, VALUE(REQUIRED) + DEFINE SYNTAX SET_EXPIRE + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=EXPIRATION, VALUE(TYPE=$NUMBER,REQUIRED) + DEFINE SYNTAX SET_GENERIC + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=USERNAME, VALUE(REQUIRED) + QUALIFIER DAYS,VALUE(TYPE=$NUMBER,DEFAULT="7"),DEFAULT + DEFINE SYNTAX SET_LOGIN + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=USERNAME, VALUE(REQUIRED) + DEFINE SYNTAX SET_FLAGS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + QUALIFIER DEFAULT, NONNEGATABLE + QUALIFIER ALL, NONNEGATABLE + QUALIFIER PERMANENT + QUALIFIER NOPERMANENT + QUALIFIER FOLDER, VALUE(REQUIRED) + DEFINE SYNTAX SET_NOFLAGS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + QUALIFIER DEFAULT, NONNEGATABLE + QUALIFIER PERMANENT + QUALIFIER NOPERMANENT + QUALIFIER ALL, NONNEGATABLE + QUALIFIER FOLDER, VALUE(REQUIRED) + DEFINE SYNTAX SET_BBOARD + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=BB_USERNAME + QUALIFIER EXPIRATION, VALUE(TYPE=$NUMBER) + LABEL=EXPIRATION, DEFAULT + QUALIFIER SPECIAL, NONNEGATABLE + QUALIFIER VMSMAIL, NONNEGATABLE + DISALLOW VMSMAIL AND NOT SPECIAL + DISALLOW VMSMAIL AND NOT BB_USERNAME + DEFINE SYNTAX SET_FOLDER + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=SELECT_FOLDER + QUALIFIER MARKED, NONNEGATABLE + QUALIFIER UNMARKED, NONNEGATABLE + QUALIFIER SEEN, NONNEGATABLE + QUALIFIER UNSEEN, NONNEGATABLE + DISALLOW (MARKED AND SEEN) OR (MARKED AND UNSEEN) OR + (UNMARKED AND SEEN) OR (UNMARKED AND UNSEEN) + DEFINE SYNTAX SET_NOACCESS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=ACCESS_ID, VALUE(LIST) + PARAMETER P3, LABEL=ACCESS_FOLDER + QUALIFIER ALL, NONNEGATABLE + QUALIFIER READONLY, NONNEGATABLE + DISALLOW NOT ALL AND NOT ACCESS_ID + DISALLOW ALL AND NOT READONLY + DEFINE SYNTAX SET_ACCESS + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=ACCESS_ID, VALUE(LIST) + PARAMETER P3, LABEL=ACCESS_FOLDER + QUALIFIER READONLY, NONNEGATABLE + QUALIFIER ALL, NONNEGATABLE + DISALLOW NOT ALL AND NOT ACCESS_ID + DEFINE SYNTAX SET_PRIVILEGES + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=PRIVILEGES, PROMPT="Privileges" + VALUE (REQUIRED,LIST) + DEFINE SYNTAX SET_DEFAULT_EXPIRE + PARAMETER P1, LABEL=SET_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SET_OPTIONS) + PARAMETER P2, LABEL=DEFAULT_EXPIRE, VALUE(TYPE=$NUMBER,REQUIRED) + DEFINE VERB SHOW + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) +! +! The following are defined to allow qualifiers to be specified +! directly after the SHOW command, i.e. SHOW/FULL FOLDER. +! Otherwise, the CLI routines will reject the command, because it +! first attempts to process the qualifier before process the parameter, +! so it has no information the qualifiers are valid. +! + QUALIFIER FULL, SYNTAX=SHOW_FOLDER_FULL, NONNEGATABLE + QUALIFIER ALL, SYNTAX=SHOW_USER + QUALIFIER FOLDER, VALUE, SYNTAX=SHOW_USER + QUALIFIER LOGIN, SYNTAX=SHOW_USER + QUALIFIER NOLOGIN, SYNTAX=SHOW_USER + QUALIFIER PRINT, SYNTAX=SHOW_KEYPAD_PRINT + QUALIFIER SINCE, VALUE(TYPE=$DATETIME), SYNTAX=SHOW_USER + QUALIFIER START, SYNTAX=SHOW_USER + DEFINE TYPE SHOW_OPTIONS + KEYWORD FOLDER, SYNTAX=SHOW_FOLDER + KEYWORD NEW, SYNTAX=SHOW_FLAGS + KEYWORD PRIVILEGES, SYNTAX=SHOW_FLAGS + KEYWORD FLAGS, SYNTAX=SHOW_FLAGS + KEYWORD KEYPAD, SYNTAX=SHOW_KEYPAD + KEYWORD USER, SYNTAX=SHOW_USER + KEYWORD VERSION + DEFINE SYNTAX SHOW_FLAGS + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + DEFINE SYNTAX SHOW_KEYPAD + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + QUALIFIER PRINT + DEFINE SYNTAX SHOW_KEYPAD_PRINT + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + QUALIFIER PRINT,DEFAULT + DEFINE SYNTAX SHOW_FOLDER + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + PARAMETER P2, LABEL=SHOW_FOLDER + DEFINE SYNTAX SHOW_USER + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + PARAMETER P2, LABEL=USERNAME + QUALIFIER ALL + QUALIFIER FOLDER, VALUE + QUALIFIER LOGIN + QUALIFIER NOLOGIN + QUALIFIER SINCE, VALUE(TYPE=$DATETIME) + QUALIFIER START, VALUE + DISALLOW (NOLOGIN OR LOGIN OR ALL) AND USERNAME + DISALLOW (LOGIN AND NOLOGIN) + DISALLOW (LOGIN OR NOLOGIN) AND FOLDER + DEFINE SYNTAX SHOW_FOLDER_FULL + QUALIFIER FULL, DEFAULT + PARAMETER P1, LABEL=SHOW_PARAM1, PROMPT="What" + VALUE(REQUIRED, TYPE=SHOW_OPTIONS) + PARAMETER P2, LABEL=SHOW_FOLDER + DEFINE VERB SUBSCRIBE + DEFINE VERB SPAWN + PARAMETER P1, LABEL=COMMAND, VALUE(TYPE=$REST_OF_LINE) + DEFINE VERB UNMARK + PARAMETER P1, LABEL=NUMBER, VALUE(TYPE=$FILE,LIST) + DEFINE VERB UNDELETE + PARAMETER P1, LABEL=BULLETIN_NUMBER, VALUE(TYPE=$FILE) + DEFINE VERB UNSEEN + PARAMETER P1, LABEL=NUMBER, VALUE(TYPE=$FILE,LIST) + DEFINE VERB UNSUBSCRIBE +$eod +$copy/log sys$input BULLETIN.CLD +$deck +! +! This file is the CLD file used to define a command to execute +! BULLETIN by using CDU, which adds the command to the command table. +! The alternative is to define a symbol to execute BULLETIN. +! Either way will work, and it is up to the user's to decide which +! method to work. (If you don't know which, you probably should use +! the default symbol method.) +! + +Define Verb BULLETIN + Image BULL_DIR:BULLETIN + Parameter P1, Label = SELECT_FOLDER + Qualifier ALL + Qualifier BBOARD + Qualifier BULLCP + Qualifier CLEANUP, Value (Required) + Qualifier EDIT + Qualifier KEYPAD, Default + Qualifier LOGIN + Qualifier MARKED + Qualifier PAGE, Default + Qualifier PGFLQUOTA, Value (Type = $NUMBER, Required) + Qualifier PROMPT, Value (Default = "BULLETIN"), Default + Qualifier READNEW + Qualifier REVERSE + ! + ! The following line causes a line to be outputted separating system notices. + ! The line consists of a line of all "-"s, i.e.: + !-------------------------------------------------------------------------- + ! If you want a different character to be used, simply put in the desired one + ! in the following line. If you want to disable the feature, remove the + ! Default at the end of the line. (Don't remove the whole line!) + ! + Qualifier SEPARATE, Value (Default = "-"), Default + Qualifier SEEN + Qualifier STARTUP + Qualifier STOP + Qualifier SYSTEM, Value (Type = $NUMBER, Default = "7") + Qualifier UNMARKED + Qualifier UNSEEN + Qualifier WIDTH, Value (Type = $NUMBER, Required) + Qualifier WSEXTENT, Value (Type = $NUMBER, Required) + Disallow (WSEXTENT Or PGFLQUOTA) And Not STARTUP +$eod +$copy/log sys$input BULLETIN.COM +$deck +$ DEFINE SYS$INPUT SYS$NET +$ BULLETIN +$eod +$copy/log sys$input BULLMAIN.CLD +$deck + MODULE BULLETIN_MAINCOMMANDS + DEFINE VERB BULLETIN + PARAMETER P1, LABEL=SELECT_FOLDER + QUALIFIER ALL + QUALIFIER BBOARD + QUALIFIER BULLCP + QUALIFIER CLEANUP, LABEL=CLEANUP, VALUE(REQUIRED) + QUALIFIER EDIT + QUALIFIER KEYPAD, DEFAULT + QUALIFIER LOGIN + QUALIFIER MARKED + QUALIFIER PAGE, DEFAULT + QUALIFIER PGFLQUOTA, VALUE(TYPE=$NUMBER, REQUIRED) + QUALIFIER READNEW + QUALIFIER REVERSE +! +! The following line causes a line to be outputted separating system notices. +! The line consists of a line of all "-"s, i.e.: +!-------------------------------------------------------------------------- +! If you want a different character to be used, simply put in the desired one +! in the following line. If you want to disable the feature, remove the +! DEFAULT at the end of the line. (Don't remove the whole line!) +! + QUALIFIER SEEN + QUALIFIER SEPARATE, VALUE(DEFAULT="-"), DEFAULT + QUALIFIER STARTUP + QUALIFIER STOP + QUALIFIER SYSTEM, VALUE(TYPE=$NUMBER, DEFAULT="7") + QUALIFIER UNSEEN + QUALIFIER UNMARKED + QUALIFIER WIDTH, VALUE(TYPE=$NUMBER, REQUIRED) + QUALIFIER WSEXTENT, VALUE(TYPE=$NUMBER, REQUIRED) + DISALLOW (WSEXTENT OR PGFLQUOTA) AND NOT STARTUP +$eod +$copy/log sys$input BULLSTART.COM +$deck +$ RUN SYS$SYSTEM:INSTALL +BULL_DIR:BULLETIN/SHAR/OPEN/HEAD/- +PRIV=(OPER,SYSPRV,CMKRNL,WORLD,DETACH,PRMMBX,SYSNAM) +/EXIT +$ BULL*ETIN :== $BULL_DIR:BULLETIN +$ BULLETIN/STARTUP +$eod +$copy/log sys$input BULL_NEWSDUMMY.FOR +$deck + INTEGER FUNCTION NEWS_ASSIGN() + + NEWS_ASSIGN = 0 + + RETURN + END + + INTEGER FUNCTION NEWS_GET_CHAN(I) + + RETURN + END + + + SUBROUTINE NEWS_SET_CHAN(I) + + RETURN + END + + INTEGER FUNCTION NEWS_SOCKET_BULLCP(I,J,K,L) + + RETURN + END + + + INTEGER FUNCTION NEWS_CREATE_BULLCP(I,J,K,L) + + RETURN + END + + + INTEGER FUNCTION NEWS_WRITE_PACKET_BULLCP(I,J,K,L,M,N) + + RETURN + END + + + SUBROUTINE NEWS_DISCONNECT + + RETURN + END + + + + INTEGER FUNCTION NEWS_CONNECT + + NEWS_CONNECT = .FALSE. + + RETURN + END + + + + INTEGER FUNCTION NEWS_WRITE_PACKET(BUF) + + CHARACTER*(*) BUF + + RETURN + END + + + + INTEGER FUNCTION NEWS_READ_PACKET(BUF) + + CHARACTER*(*) BUF + + RETURN + END + + + + INTEGER FUNCTION NEWS_GETHOSTNAME(BUF) + + CHARACTER*(*) BUF + + RETURN + END +$eod +$copy/log sys$input CREATE.COM +$deck +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN0 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN1 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN2 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN3 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN4 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN5 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN6 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN7 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN8 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN9 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN10 +$ FORTRAN/EXTEND/CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW)/NOHPO BULLETIN11 +$ MAC ALLMACS +$ SET COMMAND/OBJ BULLCOM +$ SET COMMAND/OBJ BULLMAIN +$ ON WARNING THEN GOTO DUMMY +$ IF F$TRNLNM("TWG$TCP") .EQS. "" THEN GOTO MULTI +$ DEFINE VAXC$INCLUDE TWG$TCP:[NETDIST.INCLUDE],- + TWG$TCP:[NETDIST.INCLUDE.SYS],- + TWG$TCP:[NETDIST.INCLUDE.VMS],- + TWG$TCP:[NETDIST.INCLUDE.NETINET],- + TWG$TCP:[NETDIST.INCLUDE.ARPA],- + SYS$LIBRARY +$ CC BULL_NEWS/DEFINE=(TWG=1) +$ GOTO LINK +$MULTI: +$ IF F$TRNLNM("MULTINET_SOCKET_LIBRARY") .EQS. "" THEN GOTO UCX +$ CC BULL_NEWS/DEFINE=(MULTINET=1) +$ GOTO LINK +$UCX: +$ IF F$TRNLNM("UCX$DEVICE") .EQS. "" THEN GOTO CMU +$ CC BULL_NEWS/DEFINE=(UCX=1) +$ GOTO LINK +$CMU: +$ CC BULL_NEWS +$ GOTO LINK +$DUMMY: +$ WRITE SYS$OUTPUT "There is no C compiler available for the NEWS software." +$ WRITE SYS$OUTPUT "BULLETIN will be assembled without that feature." +$ FOR BULL_NEWSDUMMY +$LINK: +$ IF F$SEARCH("BULL_DIR:READ_BOARD.COM") .NES. "" THEN- + DELETE BULL_DIR:READ_BOARD.COM;* +$ IF F$SEARCH("BULL.OLB") .EQS. "" THEN LIBRARY/CREATE BULL +$ LIBRARY BULL *.OBJ; +$ DELETE *.OBJ;* +$ @BULLETIN.LNK +$eod +$copy/log sys$input DCLREMOTE.COM +$deck +$! DCL procedure to execute DCL commands passed over Decnet on a remote system. +$! Commands sent by the command procedure REMOTE.COM on the local system are +$! are received by this procedure on the remote node. +$! This procedure is usually a DECNET OBJECT with task name DCLREMOTE and +$! normally resides in the default DECNET account. To install as an object, +$! enter NCP, and then use the command: +$! NCP> SET OBJECT DCLREMOTE FILE file-spec NUM 0 +$! where file-spec includes the disk, directory, and file name of the file. +$! If DCLREMOTE is not installed as an object, the logical name DCLREMOTE can +$! be defined to point at it. +$! +$! Alternativley, DCLREMOTE.COM could be placed in the directory of the user's +$! proxy login on the remote system. +$! +$! WARNING: An EXIT command must not be passed as a command to execute at this +$! procedure level or the link will hang. +$! +$ SET NOON +$ N = 0 +$AGAIN: +$ N = N + 1 +$ IF N .GE. 5 THEN GOTO DONE +$ OPEN/WRITE/READ/ERR=AGAIN NET SYS$NET +$ DEFINE /NOLOG SYS$OUTPUT NET +$ DEFINE /NOLOG SYS$ERROR NET +$NEXT_CMD: +$ READ /ERR=DONE NET COMMAND +$ 'COMMAND' +$ WRITE/ERR=DONE SYS$OUTPUT "COMMAND$DONE ''$STATUS'" +$ GOTO NEXT_CMD +$DONE: +$ CLOSE NET +$eod +$copy/log sys$input INSTALL.COM +$deck +$ COPY BULLETIN.EXE BULL_DIR: +$ RUN SYS$SYSTEM:INSTALL +BULL_DIR:BULLETIN/DEL +BULL_DIR:BULLETIN/SHAR/OPEN/HEAD/- +PRIV=(OPER,SYSPRV,CMKRNL,WORLD,DETACH,PRMMBX,SYSNAM) +/EXIT +$! +$! NOTE: BULLETIN requires a separate help library. If you do not wish +$! the library to be placed in SYS$HELP, modify the following lines and +$! define the logical name BULL_HELP to be the help library directory, i.e. +$! $ DEFINE/SYSTEM BULL_HELP SYSD$:[NEWDIRECTORY] +$! The above line should be placed in BULLSTART.COM to be executed after +$! every system reboot. +$! +$ IF F$SEARCH("SYS$HELP:BULL.HLB") .NES. "" THEN LIBRARY/DELETE=*/HELP SYS$HELP:BULL +$ IF F$SEARCH("SYS$HELP:BULL.HLB") .EQS. "" THEN LIBRARY/CREATE/HELP SYS$HELP:BULL +$ LIBRARY/HELP SYS$HELP:BULL BULLCOMS1,BULLCOMS2 +$ LIBRARY/HELP SYS$HELP:HELPLIB BULLETIN +$eod +$copy/log sys$input INSTALL_REMOTE.COM +$deck +$! +$! INSTALL_REMOTE.COM +$! VERSION 5/25/88 +$! +$! DESCRIPTION: +$! Command procedure to easily install BULLETIN.EXE on several nodes. +$! +$! INPUTS: +$! The following parameters can be added to the command line. They +$! should be placed on the command line which executes this command +$! procedure, separated by spaces. I.e. @INSTALL_REMOTE.COM OLD COPY TEST +$! +$! OLD - Specifies that the present version of BULLETIN is 1.51 or earlier. +$! COPY - Specifies that the executable is to be copied to the nodes. +$! TEST - Specifies that all the nodes are to be checked to see if they +$! are up before beginning the intallation. +$! +$! NOTES: +$! ***PLEASE READ ALL COMMENTS BEFORE RUNNING THIS*** +$! This calls REMOTE.COM which is also included with the installation. +$! +$! DCLREMOTE.COM must be properly installed on all nodes. +$! See comments at the beginning of that file for instructions. +$! Also, you need to have a proxy login with privileges on those nodes. +$! This procedure assumes that the BULLETIN executable on each node is +$! located in the BULL_DIR directory. The new executable should be copied +$! to that directory before running this procedure, or the COPY option +$! should be used. +$! +$! If the present version of BULLETIN is 1.51 or earlier, it does not have +$! the ability of setting BULL_DISABLE to disable BULLETIN, so you should +$! use the OLD parameter when running this procedure. +$! +$! INSTRUCTIONS FOR SPECIFYING THE NODES AT YOUR SITE: +$! Place the nodes where bulletin is to be reinstalled in variable NODES. +$! Place the nodes where the executable is to be copied to in COPY_NODES. +$! Place nodes where BULLCP is running in BULLCP_NODES. +$! +$ NODES = "ALCVAX,NERUS,ANANSI,MOLVAX,LAURIE,CANDLE,KLYPSO,DOME" +- +",ARVON,LARAN,ORYANA,PALDAR,MOTHRA,TARNA,DARIUS" +$ COPY_NODES = "NERUS,LAURIE,ARVON" +$ BULLCP_NODES = "NERUS,LAURIE,ARVON" +$! +$ NODES = NODES + "," +$ COPY_NODES = COPY_NODES + "," +$ BULLCP_NODES = BULLCP_NODES + "," +$! +$! Check for any parameters passed to the command procedure. +$! +$ PARAMETER = P1 + P2 + P3 +$ OLD = 0 +$ IF F$LOCATE("OLD",PARAMETER) .NE. F$LENGTH(PARAMETER) THEN OLD = 1 +$ TEST = 0 +$ IF F$LOCATE("TEST",PARAMETER) .NE. F$LENGTH(PARAMETER) THEN TEST = 1 +$ COPYB = 0 +$ IF F$LOCATE("COPY",PARAMETER) .NE. F$LENGTH(PARAMETER) THEN COPYB = 1 +$! +$! If TEST requested, see if nodes are accessible. +$! +$ IF .NOT. TEST THEN GOTO END_TEST +$BEGIN_TEST: +$ NODES1 = NODES +$TEST: +$ IF F$LEN(NODES1) .EQ. 0 THEN GOTO END_TEST +$ NODE = F$EXTRACT(0,F$LOCATE(",",NODES1),NODES1) +$ NODES1 = NODES1 - NODE - "," +$ @REMOTE 'NODE' END +$ GOTO TEST +$END_TEST: +$! +$! If COPY requested, copy executable to nodes. +$! +$ IF .NOT. COPYB THEN GOTO END_COPY +$COPY: +$ IF F$LEN(COPY_NODES) .EQ. 0 THEN GOTO END_COPY +$ NODE = F$EXTRACT(0,F$LOCATE(",",COPY_NODES),COPY_NODES) +$ COPY_NODES = COPY_NODES - NODE - "," +$ COPY BULLETIN.EXE 'NODE'::BULL_DIR: +$ GOTO COPY +$END_COPY: +$! +$! The procedure now goes to each node and disables bulletin and kills +$! the BULLCP process if present. NOTE: If version is < 1.51, we assume +$! that BULLCP is running under SYSTEM account. This is not necessary +$! for older versions where the BULLETIN/STOP command can be used. +$! If BULLCP is not running under the SYSTEM account for version 1.51 +$! or less, you will have to kill them manually before running this! +$! +$BEGIN_DISABLE: +$ NODES1 = NODES +$DISABLE: +$ IF F$LEN(NODES1) .EQ. 0 THEN GOTO END_DISABLE +$ NODE = F$EXTRACT(0,F$LOCATE(",",NODES1),NODES1) +$ NODES1 = NODES1 - NODE - "," +$ @REMOTE 'NODE' CONTINUE SET PROC/PRIV=ALL +$ IF F$LOCATE(","+NODE+",",","+BULLCP_NODES) .EQ. - + F$LENGTH(","+BULLCP_NODES) THEN GOTO SKIP_STOP_BULLCP +$ IF OLD THEN @REMOTE 'NODE' CONTINUE SET UIC [SYSTEM] +$ IF OLD THEN @REMOTE 'NODE' CONTINUE STOP BULLCP +$ IF .NOT. OLD THEN @REMOTE 'NODE' CONTINUE BULLETIN := $BULL_DIR:BULLETIN +$ IF .NOT. OLD THEN @REMOTE 'NODE' CONTINUE BULLETIN/STOP +$SKIP_STOP_BULLCP: +$ @REMOTE 'NODE' CONTINUE INS := $SYS$SYSTEM:INSTALL +$ IF OLD THEN @REMOTE 'NODE' END INS BULL_DIR:BULLETIN/DELETE +$ IF .NOT. OLD THEN @REMOTE 'NODE' END DEF/SYSTEM BULL_DISABLE DISABLE +$ GOTO DISABLE +$END_DISABLE: +$! +$! The procedure now installs the new BULLETIN. +$! +$ NODES1 = NODES +$INSTALL: +$ IF F$LEN(NODES1) .EQ. 0 THEN EXIT +$ NODE = F$EXTRACT(0,F$LOCATE(",",NODES1),NODES1) +$ NODES1 = NODES1 - NODE - "," +$ @REMOTE 'NODE' CONTINUE SET PROC/PRIV=ALL +$ @REMOTE 'NODE' CONTINUE INS := $SYS$SYSTEM:INSTALL +$ @REMOTE 'NODE' CONTINUE BULLETIN := $BULL_DIR:BULLETIN +$ IF OLD THEN @REMOTE 'NODE' CONTINUE INS BULL_DIR:BULLETIN/SHAR- +/OPEN/HEAD/PRIV=(OPER,SYSPRV,CMKRNL,WORLD,DETACH,PRMMBX,SYSNAM) +$ IF .NOT. OLD THEN @REMOTE 'NODE' CONTINUE INS BULL_DIR:BULLETIN/REPLACE +$ IF .NOT. OLD THEN @REMOTE 'NODE' CONTINUE DEASS/SYSTEM BULL_DISABLE +$ IF F$LOCATE(","+NODE+",",","+BULLCP_NODES) .EQ. - + F$LENGTH(","+BULLCP_NODES) THEN GOTO SKIP_START_BULLCP +$ @REMOTE 'NODE' CONTINUE SET UIC [SYSTEM] +$ @REMOTE 'NODE' CONTINUE BULLETIN := $BULL_DIR:BULLETIN" +$ @REMOTE 'NODE' CONTINUE BULLETIN/START +$SKIP_START_BULLCP: +$ @REMOTE 'NODE' END CONTINUE +$ GOTO INSTALL +$eod +$copy/log sys$input INSTRUCT.COM +$deck +$ BULLETIN +ADD/PERMANENT/SYSTEM INSTRUCT.TXT +INFO ON HOW TO USE THE BULLETIN UTILITY. +ADD/PERMANENT NONSYSTEM.TXT +INFO ON BEING PROMPTED TO READ NON-SYSTEM BULLETINS. +EXIT +$eod +$copy/log sys$input LOGIN.COM +$deck +$! +$! The following line defines the BULLETIN command. +$! +$ BULL*ETIN :== $BULL_DIR:BULLETIN +$! +$! Note: The command prompt when executing the utility is named after +$! the executable image. Thus, as it is presently set up, the prompt +$! will be "BULLETIN>". DO NOT make the command that executes the +$! image different from the image name, or certain things will break. +$! +$! If you would rather define the BULLETIN command using CDU rather than +$! defining it using a symbol, use the BULLETIN.CLD file to do so. +$! +$! The following line causes new messages to be displayed upon logging in. +$! +$ BULLETIN/LOGIN/REVERSE +$! +$! If you wish bulletins to be displayed starting with +$! the newest rather the oldest, omit the /REVERSE qualifier. +$! Note that for totally new users, only permanent system messages and +$! the first non-system general message is displayed (which, if you ran +$! INSTURCT.COM, would describe what a non-system message is). +$! This is done so as to avoid overwhelming a new user with lots of +$! messages upon logging in for the first time. +$! Users who have DISMAIL enabled in the authorzation table will automatically +$! be set to "NOLOGIN" (see HELP SET NOLOGIN). If you wish to disable this +$! feature, add /ALL to the /LOGIN command. +$! +$eod +$copy/log sys$input MAKEFILE. +$deck +# Makefile for BULLETIN + +Bulletin : Bulletin.Exe Bull.Hlb + +Bulletin.Exe : Bull.Olb + Link /NoTrace Bull.Olb/Lib /Inc=Bulletin$Main,Sys$System:Sys.Stb/Sel - + /NoUserlib /Exe=Bulletin.Exe,Sys$Input/Opt + ID="V2.06" $ + +Bull.Olb : Bulletin.Obj Bulletin0.Obj Bulletin1.Obj Bulletin2.Obj \ + Bulletin3.Obj Bulletin4.Obj Bulletin5.Obj Bulletin6.Obj \ + Bulletin7.Obj Bulletin8.Obj Bulletin9.Obj Bulletin10.Obj \ + Bulletin11.Obj Bullcom.Obj Bullmain.Obj Allmacs.Obj + Library /Create Bull.Olb *.Obj + Purge /Log *.Obj,*.Exe + +Bulletin.Obj : Bulletin.For Bullfiles.Inc Bulldir.Inc Bullfolder.Inc \ + Bulluser.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin.For + +Bulletin0.Obj : Bulletin0.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin0.For + +Bulletin1.Obj : Bulletin1.For Bulldir.Inc Bullfolder.Inc Bulluser.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin1.For + +Bulletin2.Obj : Bulletin2.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin2.For + +Bulletin3.Obj : Bulletin3.For Bulldir.Inc Bullfolder.Inc Bulluser.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin3.For + +Bulletin4.Obj : Bulletin4.For Bullfolder.Inc Bulluser.Inc Bullfiles.Inc \ + Bulldir.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin4.For + +Bulletin5.Obj : Bulletin5.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin5.For + +Bulletin6.Obj : Bulletin6.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin6.For + +Bulletin7.Obj : Bulletin7.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin7.For + +Bulletin8.Obj : Bulletin8.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin8.For + +Bulletin9.Obj : Bulletin9.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin9.For + +Bulletin10.Obj : Bulletin10.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin10.For + +Bulletin11.Obj : Bulletin11.For Bulldir.Inc Bulluser.Inc Bullfolder.Inc \ + Bullfiles.Inc Bullnews.Inc + Fortran /Extend /NoList Bulletin11.For + +Allmacs.Obj : Allmacs.mar + Macro /NoList Allmacs.Mar + +Bullcom.Obj : Bullcom.cld + Set Command /Obj Bullcom.Cld + +Bullmain.Obj : Bullmain.cld + Set Command /Obj Bullmain.Cld + +Bull.Hlb : Bullcoms1.Hlp Bullcoms2.Hlp + Library /Create /Help Bull.Hlb Bullcoms1.Hlp, Bullcoms2.Hlp + Purge Bull.Hlb +*.hlb : + lib/help/cre $* +$eod +$copy/log sys$input OPTIMIZE_RMS.COM +$deck +$ SET NOON +$ EXIT_STATUS = 1 +$ IF P1 .NES. "" THEN GOTO BATCH +$! +$GET_FILE: +$ INQUIRE P1 "File to be optimized (^Y to quit)" +$! +$ FILENAME = P1 +$ SPEC = F$SEARCH(FILENAME) +$! +$GOT_NAME_INTERACTIVE: +$ NAME = F$PARSE(FILENAME,,,"NAME") +$! +$ IF F$FILE_ATTRIBUTE(FILENAME,"ORG") .EQS. "IDX" THEN- + GOTO INTERACTIVE_CHECK_ADDS +$ WRITE SYS$OUTPUT "File not indexed" +$ GOTO GET_FILE +$INTERACTIVE_CHECK_ADDS: +$ INQUIRE P2 "Number of records to add after initial load" +$ IF P2 .EQS. "" THEN P2 = 0 +$! +$ IF P2 .GE. 0 THEN GOTO INTERACTIVE_CHECK_CONVERT +$ WRITE SYS$OUTPUT "Added records must be >= 0 " +$ GOTO GOT_NAME_INTERACTIVE +$! +$INTERACTIVE_CHECK_CONVERT: +$ INQUIRE P3 "Turn OFF Data and Key compression? (N)" +$ INQUIRE P4 "Turn OFF Index compression? (N)" +$! +$ GOTO ADD_OK +$! +$BATCH: +$GOT_NAME: +$ FILENAME = P1 +$ SPEC = F$SEARCH(FILENAME) +$! +$ IF SPEC .NES. "" THEN GOTO FILE_EXISTS +$ WRITE SYS$OUTPUT "File does not exist" +$ EXIT_STATUS = %X18292 +$ GOTO DONE +$! +$FILE_EXISTS: +$ NAME = F$PARSE(FILENAME,,,"NAME") +$ IF F$FILE_ATTRIBUTE(FILENAME,"ORG") .EQS. "IDX" THEN- + GOTO TYPE_OK +$ WRITE SYS$OUTPUT "File not indexed" +$ EXIT_STATUS = 1000024 +$ GOTO DONE +$! +$TYPE_OK: +$ IF P2 .EQS. "" THEN P2 = 0 +$ IF P2 .GE. 0 THEN GOTO ADD_OK +$! +$ WRITE SYS$OUTPUT "Added records must be >= 0 " +$ EXIT_STATUS = %X38060 +$ GOTO DONE +$! +$ADD_OK: +$ ADD_RECORDS = P2 +$! +$ NUMBER_OF_KEYS == 'F$FILE_ATTRIBUTE(FILENAME,"NOK") +$ TURN_DATA_COMPRESSION_OFF = P3 +$ TURN_INDEX_COMPRESSION_OFF = P4 +$ FDL_NAME = F$PARSE(".FDL;0",SPEC) +$ TEMP_FILE = "''NAME'_TEMP_TEMP.COM" +$ OPEN/WRITE/ERROR=OPEN_ERROR OUT 'TEMP_FILE +$ WRITE OUT "$ DEFINE/USER SYS$COMMAND SYS$INPUT" +$ WRITE OUT "$ ANALYZE/RMS/FDL/OUT=''FDL_NAME' ''FILENAME'" +$ WRITE OUT "$ DEFINE/USER SYS$COMMAND SYS$INPUT" +$ WRITE OUT "$ DEFINE/USER EDF$$PLAYBACK_INPUT KLUDGE" +$ WRITE OUT "$ EDIT/FDL/SCRIPT=OPTIMIZE/ANALYZE=''FDL_NAME' ''FDL_NAME'" +$ WRITE OUT "" +$ WRITE OUT "" +$ WRITE OUT "" +$ WRITE OUT "" +$ WRITE OUT 'ADD_RECORDS +$ IF ADD_RECORDS .EQ. 0 THEN GOTO SKIP_NON_ZERO +$ WRITE OUT "" +$ WRITE OUT "" +$SKIP_NON_ZERO: +$ WRITE OUT "" +$ IF TURN_INDEX_COMPRESSION_OFF +$ THEN +$ WRITE OUT "IC" +$ WRITE OUT "NO" +$ ENDIF +$ IF TURN_DATA_COMPRESSION_OFF +$ THEN +$ WRITE OUT "RC" +$ WRITE OUT "NO" +$ WRITE OUT "KC" +$ WRITE OUT "NO" +$ ENDIF +$ WRITE OUT "FD" +$ WRITE OUT "Created from OPTIMIZE_RMS.COM, WITH SPACE/BUCKETSIZE for" +- + " ''A DD_RECORDS' ADDED RECORDS" +$ WRITE OUT "" +$ WRITE OUT "" +$LOOP: +$ IF NUMBER_OF_KEYS .EQ. 1 THEN GOTO CLOSE_FILE +$ WRITE OUT "" +$ WRITE OUT "" +$ WRITE OUT "" +$ IF TURN_INDEX_COMPRESSION_OFF +$ THEN +$ WRITE OUT "IC" +$ WRITE OUT "NO" +$ ENDIF +$ IF TURN_DATA_COMPRESSION_OFF +$ THEN +$ WRITE OUT "KC" +$ WRITE OUT "NO" +$ ENDIF +$ WRITE OUT "FD" +$ WRITE OUT "" +$ WRITE OUT "" +$ NUMBER_OF_KEYS = 'NUMBER_OF_KEYS - 1 +$ GOTO LOOP +$! +$CLOSE_FILE: +$ WRITE OUT "E" +$ CLOSE OUT +$! +$ @'TEMP_FILE +$ DELETE 'TEMP_FILE;* +$ WRITE SYS$OUTPUT "" +$ WRITE SYS$OUTPUT "Starting CONVERT of ''FILENAME'" +$ CONVERT /NOSORT /STAT /FDL='FDL_NAME 'FILENAME 'FILENAME +$ WRITE SYS$OUTPUT "" +$ GOTO DONE +$OPEN_ERROR: +$ WRITE SYS$OUTPUT "Unable to open ''TEMP_FILE'" +$DONE: +$ EXIT 'EXIT_STATUS +$eod +$copy/log sys$input REMOTE.COM +$deck +$! FILE: REMOTE.COM VERSION 1.3 EDIT 880513 - CAK +$! DCL procedure to execute DCL commands on a remote decnet node. +$! The remote DECNET object DCLREMOTE.COM must be defined as a known type 0 +$! object on the remote node or the file must be in the login directory +$! of the account used on the remote system. Or the logical name DCLREMOTE +$! can be defined to point at the object. +$! +$! Usage: REM*OTE :== @SYS$MANAGER:REMOTE [P1] [P2] ... +$! +$! P1 - Node name commands are to be executed on, including any access control. +$! If no access control is specified then a proxy login is attempted. +$! The you do not have an account on the remote system then the default +$! DECNET account is used. +$! P2 - DCL command to execute on the remote system. Optional. +$! P3-P8 Additional parameters passed to the command (so quotes aren't needed) +$ +$ ON WARNING THEN GOTO ERROR +$ ON CONTROL_Y THEN GOTO ERROR +$ COMMAND := 'P2' 'P3' 'P4' 'P5' 'P6' 'P7' 'P8' +$ IF P2 .EQS. "CONTINUE" THEN COMMAND = COMMAND - "CONTINUE" +$ IF P2 .EQS. "END" THEN COMMAND = COMMAND - "END" +$ NEXT_CMD = "NEXT_CMD" +$ IF P2 .NES. "" THEN NEXT_CMD = "DONE" +$ P1 = P1 - "::" +$ +$ IF F$LOG ("NET") .EQS. "" THEN GOTO OPEN_LINK +$ IF P2 .EQS. "CONTINUE" THEN GOTO NEXT_CMD +$ IF P2 .EQS. "END" THEN GOTO NEXT_CMD +$OPEN_LINK: +$ WRITE SYS$OUTPUT "Establishing DECNET link to node ''P1'..." +$ OPEN/WRITE/READ NET 'P1'::"TASK=DCLREMOTE" +$ +$NEXT_CMD: +$ IF P2 .EQS. "" THEN READ /ERR=ERROR/PROMPT="''P1'> " SYS$COMMAND COMMAND +$ IF F$EDIT(F$EXTR(0,1,COMMAND),"UPCASE") .EQS. "E" THEN GOTO DONE +$ WRITE NET COMMAND +$LOOP: +$ READ/ERR=ERROR/TIME_OUT=10 NET LINE +$ IF F$EXTR (0,12,LINE) .EQS. "COMMAND$DONE" THEN GOTO 'NEXT_CMD' +$ WRITE SYS$OUTPUT LINE +$ GOTO LOOP +$DONE: +$ IF P2 .EQS. "CONTINUE" THEN EXIT +$ IF F$LOG ("NET") .NES. "" THEN CLOSE NET +$ EXIT +$ERROR: +$ IF F$LOG ("NET") .NES. "" THEN CLOSE NET +$ STOP +$eod +$copy/log sys$input SETUSER.MAR +$deck + .Title SETUSER +; +; Program Setuser +; +; This program will change the username and UIC of the running process +; +; To assemble: $ MACRO SETUSER +; $ LINK SETUSER,SYS$SYSTEM:SYS.STB/SELECT +; + .LIBRARY /SYS$LIBRARY:LIB.MLB/ + $PCBDEF ;define PCB offsets + $JIBDEF ;define JIB offsets + $UAFDEF ;define user authorization file offsets +INFAB: $FAB FAC=GET - ;only gets on input file + FNM= - ;SYSUAF may be defined as logical name + DNM= - ;These are default directory & suffix + SHR= ;allow full sharing +INRAB: $RAB FAB=INFAB - ;FAB for this RAB + KBF=COMMLD+8 - ;key value is typed in by user + KRF=0 - ;primary key + KSZ=12 - ;username is 12 bytes long + RAC=KEY - ;key access on this file + ROP=NLK - ;don't lock read records + UBF=BUFFER - ;address of buffer for I/O + USZ=2048 ;size of buffer +BUFFER: .BLKB 2048 ;buffer for data +COMMLD: .ASCID / / ;space for typed in username +PROMPTD:.ASCID /Username: / ;prompt string +COMMLDS:.WORD 0 ;space for number of bytes typed in +FAODESC:.LONG 80 + .LONG FAOBUF +FAOBUF: .BLKB 80 +FAOLEN: .BLKW 1 + .BLKW 1 +FORSTR: .ASCID /PID:!XL from:[!OW,!OW] !AD to:[!OW,!OW] !AD/ +TT: .ASCID /SYS$OUTPUT/ +CHANTT: .WORD 0 ;space for terminal channel number +IOSB: .QUAD 0 +OLDUSER:.BLKB 12 ;space for old username +OLDUIC: .BLKL 1 ;space for old uic +ERRORB: JMP ERROR ;for branch out of range + +JPIUSER: .BLKB 12 +JPIUSER_LEN: .BLKL 1 + + $DEFINI IT ;DEFINE ITEM LIST FOR GETJPI +$DEF ITL .BLKW 1 ;LENGTH OF OUTPUT BUFFER +$DEF ITM .BLKW 1 ;ITEM CODE (PROCESS NAME) +$DEF ITA .BLKL 1 ;ADDR OF OUTPUT BUFFER +$DEF ITAL .BLKL 1 ;ADDR OF WORD TO RECIEVE BYTES USED +$DEF ITEND .BLKL 1 ;ZERO LONG WORD TO END LIST +$DEF ITSIZE ;SIZE NEEDED FOR IT BLOCK + $DEFEND IT + + .ENTRY START,^M<> ;start of program + PUSHAW COMMLDS ;address of word to get read byte count + PUSHAL PROMPTD ;address of prompt string descriptor + PUSHAL COMMLD ;address of descriptor to get command + CALLS #3,G^LIB$GET_FOREIGN ;use run time library to get command + BLBC R0,ERRORB ;low bit clear error + $OPEN FAB=INFAB ;open file + BLBC R0,ERRORB ;low bit clear error + $CONNECT RAB=INRAB ;connect file + BLBC R0,ERRORB ;low bit clear error + $GET RAB=INRAB ;read a record + CMPL R0,#RMS$_RNF ;record not found? + BEQL errorb ;that's all folks + CMPL R0,#RMS$_NORMAL ;ok? + BNEQ ERRORB ;no so quit + + SUBL #ITSIZE,SP ;GET SPACE FOR ITEM LIST + MOVL SP,R2 ;POINT TO IT + MOVW #12,ITL(R2) ;SET UP ITEM LIST + MOVW #JPI$_USERNAME,ITM(R2) + MOVAB JPIUSER,ITA(R2) + MOVAW JPIUSER_LEN,ITAL(R2) + CLRL ITEND(R2) + $GETJPI_S ITMLST=(R2) ;GET PROCESS NAME + ADDL #ITSIZE,SP ;RESTORE STACK POINTER + + MOVL INRAB+RAB$L_RBF,R7 ;put address of read record in R7 + MOVL UAF$L_UIC(R7),R8 ;R8 has UIC we want + $CMKRNL_S TWEAK ;change mode to kernel to tweak UIC + ;and username + BLBC R0,ERROR ;low bit clear error + ADDL3 #UAF$S_USERNAME,R7,R8 + ADDL3 #UAF$T_USERNAME,R7,R9 + $FAO_S CTRSTR=FORSTR,- ;format string + OUTBUF=FAODESC,- ;char descript for formatted output + OUTLEN=FAOLEN,- ;long word to hold length of output + P1=R9,- ;PID + P2=OLDUIC+2,- ;old UIC, group number + P3=OLDUIC,- ;old UIC, member number + P4=#12,- ;usernames are 12 bytes + P5=#OLDUSER,- ;address of old username + P6=UAF$L_UIC+2(R7),- ;UIC, group number + P7=UAF$L_UIC(R7),- ;UIC, member number + P8=R8,- ;usernames are 12 bytes + P9=R9 ;address of username + BLBC R0,ERROR ;low bit clear error + MOVL FAOLEN,FAODESC + PUSHAL FAODESC ;address of descriptor to get command + CALLS #1,G^LIB$PUT_OUTPUT ;use run time library to get command + BLBC R0,ERROR ;low bit clear error +EXIT: + $CLOSE FAB=INFAB - ;close file + ERR=ERROR +ERROR: $EXIT_S R0 ;exit with error if any + .ENTRY TWEAK,^M<> ;beginning of kernel mode code + MOVL @#CTL$GL_PCB,R11 ;put address of our PCB in R11 + MOVL PCB$L_PID(R11),R9 ;save PID + MOVL PCB$L_UIC(R11),OLDUIC ;save old UIC + MOVL R8,PCB$L_UIC(R11) ;change our UIC + MOVL PCB$L_JIB(R11),R10 ;put address of Job Info Block in R10 + ;MOVC blats R0-R5 + MOVC3 #12,JIB$T_USERNAME(R10),OLDUSER ;save old username + CMPC3 JPIUSER_LEN,JPIUSER,OLDUSER + BEQL GOOD + CLRL R0 + RET +GOOD: MOVC3 #12,UAF$T_USERNAME(R7),JIB$T_USERNAME(R10) ;change username JIB + MOVC3 #12,UAF$T_USERNAME(R7),CTL$T_USERNAME ;change username in P1 +EEXIT: MOVL #SS$_NORMAL,R0 ;set normal exit status + RET ;end of exec mode code + .END START ;end of program +$eod diff --git a/decus/vax91b/gce91b/net91b/bulletin.for b/decus/vax91b/gce91b/net91b/bulletin.for new file mode 100644 index 0000000..c123abc --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin.for @@ -0,0 +1,1768 @@ +C +C BULLETIN.FOR, Version 6/24/91 +C Purpose: Bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /POINT/ BULL_POINT + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING /.FALSE./ + + COMMON /CTRLY/ CTRLY + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + EXTERNAL ERROR_TRAP + EXTERNAL BULLETIN_SUBCOMMANDS,LIB$GET_INPUT + EXTERNAL BULLETIN_MAINCOMMANDS,ENABLE_CTRL_EXIT + EXTERNAL CLI$_ABSENT,CLI$_NOCOMD,CLI$_NEGATED + + PARAMETER PCB$M_BATCH = '4000'X + PARAMETER PCB$M_NETWRK = '200000'X + PARAMETER LIB$M_CLI_CTRLY = '2000000'X + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER HELP_DIRECTORY*64,SAVE_FOLDER*25 + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /PROMPT_PROMPT/ PROMPT,LPROMPT + CHARACTER*42 PROMPT + + CHARACTER DCL_CMD*132 + + CALL LIB$GET_FOREIGN(INCMD) + DCL_COMMAND = INDEX(INCMD,' "').GT.0.OR.INCMD(:1).EQ.'"' + + CALL LIB$ESTABLISH(ERROR_TRAP) + IF (.NOT.CLI$GET_VALUE('PROMPT',COMMAND_PROMPT,ILEN)) THEN + CALL LIB$REVERT + CALL CLI$GET_VALUE('$LINE',COMMAND_PROMPT,ILEN) + INCMD = 'BULLETIN '//INCMD + CALL CLI$DCL_PARSE(INCMD,BULLETIN_MAINCOMMANDS) + ELSE + CALL LIB$REVERT + END IF + + IF (DCL_COMMAND) THEN + IER = CLI$GET_VALUE('SELECT_FOLDER',DCL_CMD,LENP) + IF (LENP.GT.0) THEN + IF (DCL_CMD(LENP:LENP).EQ.'"') DCL_CMD = DCL_CMD(:LENP-1) + IF (DCL_CMD(:1).EQ.'"') DCL_CMD = DCL_CMD(2:) + END IF + END IF + + READIT = 0 + + LOGIN_SWITCH = CLI$PRESENT('LOGIN') + SYSTEM_SWITCH = CLI$PRESENT('SYSTEM') + REVERSE_SWITCH = CLI$PRESENT('REVERSE') + + IER = LIB$SYS_TRNLOG('BULL_DISABLE',LEN_P,BULL_PARAMETER) + IF (IER.EQ.1.AND.LEN_P.GT.0.AND..NOT.CLI$PRESENT('STOP')) THEN + IF (.NOT.LOGIN_SWITCH) THEN + WRITE (6,'('' BULLETIN temporarily disabled. Try later.'')') + END IF + CALL EXIT + END IF + + CALL SYS$SETDFPROT(,ORIGINAL_DEF_PROT) + ! Save original default protection in case it gets changed + + CALL DCLEXH(%LOC(ENABLE_CTRL_EXIT)) ! Declare exit handler + +C +C Check to see if CONTROL Y disabled. If so, then never disable CONTROL Y. +C Disabling and enabling CONTROL Y is done so that a person can not break +C while one of the data files is opened, as that would not allow anyone +C else to modify the files. However, if CONTROL Y is already disabled, +C this is not necessary, and should not be done! +C + + CALL LIB$DISABLE_CTRL(LIB$M_CLI_CTRLY,CTRLY) ! Disable CTRL-Y & -C + CTRLY = CTRLY .AND. LIB$M_CLI_CTRLY + CALL GETPRIV ! Check privileges + CALL CHECK_PRIV_IO(ERR) ! Check privileges on output I/O + CALL LIB$ENABLE_CTRL(CTRLY,) ! Renable CTRLY-Y & -C + + IF (ERR.EQ.1) CALL EXIT ! I/O privilege error, so exit + + CALL GETUSER(USERNAME) ! Get the process's username + IF (.NOT.LOGIN_SWITCH) CALL CHECK_BULLETIN_PRIV(USERNAME) + ! Check if has bulletin privileges + + I = 1 ! Strip off folder name if specified + DO WHILE (I.LE.ILEN) + IF (COMMAND_PROMPT(I:I).EQ.' ') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + I = ILEN + 1 + ELSE + I = I + 1 + END IF + END DO + ILEN = 1 ! Get executable name to use as prompt + DO WHILE (ILEN.GT.0) + ILEN = MAX(INDEX(COMMAND_PROMPT,':'),INDEX(COMMAND_PROMPT,']')) + IF (ILEN.GT.0) THEN + COMMAND_PROMPT = COMMAND_PROMPT(ILEN+1:) + ELSE + DO I=TRIM(COMMAND_PROMPT),1,-1 + IF (COMMAND_PROMPT(I:I).LT.'A'.OR. + & COMMAND_PROMPT(I:I).GT.'Z') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + END IF + END DO + END IF + END DO + COMMAND_PROMPT = COMMAND_PROMPT(:TRIM(COMMAND_PROMPT))//'> ' + IF (COMMAND_PROMPT.EQ.'RUN> '.OR.COMMAND_PROMPT.EQ.'RU> '.OR. + & COMMAND_PROMPT.EQ.'R> ') COMMAND_PROMPT = 'BULLETIN> ' + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + + CALL CLI$GET_VALUE('SEPARATE',SEPARATE) + + IF (CLI$PRESENT('EDIT')) EDIT_DEFAULT = .TRUE. ! /EDIT switch test + + CALL FIND_BULLCP ! See if BULLCP is running + + IF (CLI$PRESENT('CLEANUP')) THEN ! Test for /CLEANUP switch + CALL CLI$GET_VALUE('CLEANUP',BULL_PARAMETER,LEN_P) ! Get folder # + READ (BULL_PARAMETER,'(I)') FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + CALL EXIT ! all done with cleanup + ELSE IF (CLI$PRESENT('BBOARD')) THEN ! Test for /BBOARD switch + CALL BBOARD ! look for BBOARD mail + CALL EXIT ! all done with BBOARD + ELSE IF (CLI$PRESENT('STARTUP').OR. ! BULLCP process control + & CLI$PRESENT('STOP')) THEN + CALL CREATE_BULLCP + ELSE IF (CLI$PRESENT('BULLCP')) THEN ! This is BULLCP, so start + IF (.NOT.CLI$GET_VALUE('SELECT_FOLDER', + & BULL_PARAMETER,LENP)) THEN + CALL RUN_BULLCP ! doing what BULLCP does! + ELSE IF (BULL_PARAMETER(:LENP).EQ.'NEWS') THEN + CALL NEWS2BULL + END IF + END IF + + CALL GETSTS(STS) ! Get process status word + + IF (SYSTEM_SWITCH.OR.LOGIN_SWITCH) THEN ! If BULLETIN/LOGIN or /SYSTEM + IF ((STS.AND.PCB$M_BATCH).GT.0) CALL EXIT ! If BATCH, exit + CALL CRELNM('SYS$INPUT','TT') ! Take input from terminal + END IF + + IF ((STS.AND.PCB$M_NETWRK).EQ.0) THEN + DECNET_PROC = .FALSE. + ERROR_UNIT = 6 + + CALL ASSIGN_TERMINAL ! Assign terminal + + IF (.NOT.LOGIN_SWITCH) THEN + INCMD = 'SELECT' ! Causes nearest folder name to be selected + CALL SELECT_FOLDER(.FALSE.,IER) ! Select GENERAL folder + IF (.NOT.IER) RETURN ! If can't access, exit + + IF (.NOT.TEST_BULLCP()) CALL DELETE_EXPIRED + ! Delete expired messages + END IF + +C +C Get page size for the terminal. +C + + CALL GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) + + IER = CLI$GET_VALUE('WIDTH',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + DECODE(LEN_P,'(I)',BULL_PARAMETER) PAGE_WIDTH + END IF + + IF (CLI$PRESENT('PAGE')) PAGING = .TRUE. + + IF (SYSTEM_SWITCH) THEN + IER = CLI$GET_VALUE('SYSTEM',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Days specified? + CALL SUBTIME(SYSTEM_LOGIN_BTIM,BULL_PARAMETER(:LEN_P),IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Invalid parameter in /SYSTEM.'')') + CALL EXIT + END IF + END IF + IF (.NOT.LOGIN_SWITCH) THEN + CALL MODIFY_SYSTEM_LIST(0) + CALL SHOW_SYSTEM + CALL EXIT + END IF + END IF + +C +C Get user info stored in SYS$LOGIN. Currently, this simply stores +C the time of the latest message read for each folder. +C + + CALL OPEN_USERINFO + +C +C If /LOGIN, display SYSTEM bulletins and subject of non-SYSTEM bulletins. +C + + IF (LOGIN_SWITCH.OR.SYSTEM_SWITCH) THEN ! Is /LOGIN present? + CALL LOGIN ! Display SYSTEM bulletins + IF (READIT.EQ.0) CALL EXIT ! If no READNEWs not set, exit + END IF + +C +C If new bulletins have been added since the last time bulletins have been +C read, position bulletin pointer so that next bulletin read is the first new +C bulletin, and alert user. If READNEW set and no new bulletins, just exit. +C + + IF (.NOT.DCL_COMMAND) CALL NEW_MESSAGE_NOTIFICATION + + CALL OPEN_OLD_TAG + + ELSE + IF (TEST_BULLCP()) CALL EXIT + DECNET_PROC = .TRUE. + ERROR_UNIT = 5 + END IF + +C +C The MAIN loop for processing bulletin commands. +C + + DIR_COUNT = 0 ! # directory entry to continue bulletin read from + READ_COUNT = 0 ! # block that bulletin READ is to continue from + FOLDER_COUNT = 0 ! # folder entry to continue SHOW/ALL folder from + INDEX_COUNT = 0 + + IER = LIB$SYS_TRNLOG('BULL_HELP',HLEN,HELP_DIRECTORY) + IF (IER.NE.1) THEN + HELP_DIRECTORY = 'SYS$HELP:' + HLEN = 9 + ELSE IF (HELP_DIRECTORY(HLEN:HLEN).NE.':'.AND. + & HELP_DIRECTORY(HLEN:HLEN).NE.']') THEN + HELP_DIRECTORY = HELP_DIRECTORY(:HLEN)//':' + HLEN = HLEN + 1 + END IF + + LPROMPT = TRIM(COMMAND_PROMPT) + PROMPT = CHAR(10)//COMMAND_PROMPT(:LPROMPT)//' ' + LPROMPT = LPROMPT + 2 + + DO WHILE (1) + + IF (.NOT.DCL_COMMAND) THEN + CALL COMMAND_INPUT(IER) + ELSE + IF (INDEX(DCL_CMD,';').GT.0) THEN + INCMD = DCL_CMD(:INDEX(DCL_CMD,';')-1) + DCL_CMD = DCL_CMD(INDEX(DCL_CMD,';')+1:) + ELSE + INCMD = DCL_CMD + DCL_CMD = ' ' + END IF + IER = TRIM(INCMD) + END IF + + IF (IER.EQ.-2) THEN + IER = RMS$_EOF + ELSE IF (IER.LE.0) THEN + IER = %LOC(CLI$_NOCOMD) + ELSE + DO WHILE (IER.GT.0.AND.INCMD(:1).EQ.' ') + INCMD = INCMD(2:IER) + IER = IER - 1 + END DO + IF (IER.GT.0.AND.INCMD(:1).GE.'0'.AND.INCMD(:1).LE.'9') THEN + INCMD = 'READ '//INCMD + END IF + IER=CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS,LIB$GET_INPUT) + END IF + + IF (IER.EQ.RMS$_EOF) THEN + CALL EXIT ! If no command, exit + ELSE IF (IER.EQ.%LOC(CLI$_NOCOMD)) THEN ! If just RETURN entered + INCMD = ' ' ! Make sure there is none + LEN_P = 0 ! Indicate no parameter in command + IF (DIR_COUNT.GT.0) THEN ! If still more dir entries + CALL DIRECTORY(DIR_COUNT) ! continue outputting them + ELSE IF (INDEX_COUNT.GT.0) THEN + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (FOLDER_COUNT.GT.0) THEN ! If more folder entries + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! continue outputting them + ELSE ! Else try to read next bulletin + CALL READ_MSG(READ_COUNT,BULL_POINT+1) ! or finish old one + DIR_COUNT = 0 + FOLDER_COUNT = 0 + INDEX_COUNT = 0 + END IF + GO TO 100 ! Loop to read new command + ELSE IF (.NOT.IER) THEN ! If command has error + GO TO 100 ! ask for new command + END IF + + IER = MIN(INDEX(INCMD(:TRIM(INCMD)),' '),INDEX(INCMD,'/')) + IF (IER.GT.0) INCMD = ' '//INCMD(IER:) ! Save qualifiers + CALL CLI$GET_VALUE('$VERB',INCMD(:4)) ! Get user's command. + + IF (INCMD(:4).EQ.'BACK'.AND.DIR_COUNT.NE.0) THEN + DIR_COUNT = -1 + CALL DIRECTORY(DIR_COUNT) + INCMD = ' ' +C ELSE IF (INCMD(:4).EQ.'BACK'.AND.FOLDER_COUNT.NE.0) THEN +C FOLDER_COUNT = -1 +C CALL DIRECTORY_FOLDERS(FOLDER_COUNT) +C INCMD = ' ' + ELSE + DIR_COUNT = 0 ! Reinit display pointers + READ_COUNT = 0 + FOLDER_COUNT = 0 + INDEX_COUNT = 0 + END IF + + IF (READ_ONLY.AND.(INCMD(:3).EQ.'ADD'.OR.INCMD(:3).EQ.'DEL' + & .OR.INCMD(:3).EQ.'CHA'.OR.INCMD(:3).EQ.'REP')) THEN + ! FOLDER can only be read? + WRITE (6,'('' ERROR: Access to folder limited to reading.'')') + ELSE IF (INCMD(:3).EQ.'ADD') THEN ! ADD? + IF (REMOTE_SET.GE.3) THEN + INCMD = 'POST' + CALL RESPOND + ELSE + CALL ADD + END IF + ELSE IF (INCMD(:3).EQ.'ATT') THEN ! ATTACH? + CALL ATTACH + ELSE IF (INCMD(:4).EQ.'BACK') THEN ! BACK? + IF (BULL_POINT.LE.1) THEN + WRITE(6,1060) + ELSE + CALL READ_MSG(READ_COUNT,BULL_POINT-1) ! Try to read previous + END IF + ELSE IF (INCMD(:4).EQ.'CHAN') THEN ! CHANGE? + CALL REPLACE ! Replace old bulletin + ELSE IF (INCMD(:4).EQ.'COPY') THEN ! COPY? + CALL MOVE(.FALSE.) + ELSE IF (INCMD(:4).EQ.'CREA') THEN ! CREATE? + CALL CREATE_FOLDER ! Go create the folder + ELSE IF (INCMD(:4).EQ.'CURR') THEN ! CURRENT? + READ_COUNT = -1 ! Reread current message from beginning. + CALL READ_MSG(READ_COUNT,BULL_POINT) + ELSE IF (INCMD(:4).EQ.'DELE') THEN ! DELETE? + CALL DELETE_MSG ! Go delete bulletin + ELSE IF (INCMD(:4).EQ.'DIRE') THEN ! DIRECTORY? + IF (CLI$PRESENT('FOLDER').OR. ! /FOLDER specified? + & CLI$PRESENT('NEWS')) THEN ! or /NEWS? + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! Show all folders + ELSE IF (CLI$PRESENT('SELECT_FOLDER')) THEN! Folder specified? + CALL SELECT_FOLDER(.TRUE.,IER) ! Try to select folder + IF (IER) THEN ! If successful + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE IF (INCMD(:4).EQ.'FILE'.OR. + & INCMD(:4).EQ.'EXTR') THEN ! FILE? + CALL FILE ! Copy bulletin to file + ELSE IF (INCMD(:1).EQ.'E'.OR. + & INCMD(:4).EQ.'QUIT') THEN ! EXIT? + CALL EXIT ! Exit from program + ELSE IF (INCMD(:4).EQ.'FIRS') THEN ! FIRST? + READ_COUNT = -1 + BULL_READ = 1 + CALL READ_MSG(READ_COUNT,BULL_READ) + ELSE IF (INCMD(:4).EQ.'HELP') THEN ! HELP? + CALL HELP(HELP_DIRECTORY(:HLEN)//'BULL.HLB') ! Get help + ELSE IF (INCMD(:3).EQ.'IND') THEN ! INDEX? + INDEX_COUNT = 1 + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (INCMD(:4).EQ.'LAST') THEN ! LAST? + READ_COUNT = -1 + BULL_READ = 99999 + CALL READ_MSG(READ_COUNT,BULL_READ) + ELSE IF (INCMD(:4).EQ.'MARK') THEN ! MARK? + CALL TAG(.TRUE.,1) + ELSE IF (INCMD(:4).EQ.'MAIL'.OR. + & INCMD(:4).EQ.'FORW') THEN ! MAIL? + CALL MAIL + ELSE IF (INCMD(:3).EQ.'MOD') THEN ! MODIFY? + CALL MODIFY_FOLDER + ELSE IF (INCMD(:4).EQ.'MOVE') THEN ! MOVE? + CALL MOVE(.TRUE.) + ELSE IF (INCMD(:4).EQ.'NEWS') THEN ! NEWS + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! Show new folders + ELSE IF (INCMD(:4).EQ.'NEXT'.OR.INCMD(:1).EQ.'N') THEN ! NEXT? + CALL READ_MSG(READ_COUNT,BULL_POINT+1) ! Read next bulletin + ELSE IF (INCMD(:4).EQ.'POST') THEN ! POST? + CALL RESPOND + ELSE IF (INCMD(:4).EQ.'PRIN') THEN ! PRINT? + CALL PRINT(0,.TRUE.) ! Printout bulletin + ELSE IF (INCMD(:4).EQ.'READ') THEN ! READ? + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Bulletin specified? + DECODE(LEN_P,'(I)',BULL_PARAMETER) BULL_READ ! Yes + READ_COUNT = -1 + CALL READ_MSG(READ_COUNT,BULL_READ) + ELSE + CALL READ_MSG(READ_COUNT,BULL_POINT+1) + END IF + ELSE IF (INCMD(:3).EQ.'REM') THEN ! REMOVE? + CALL REMOVE_FOLDER + ELSE IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + IF (REMOTE_SET.GE.3.OR. + & INDEX(FOLDER_DESCRIP,'<').GT.0) THEN + CALL RESPOND + ELSE + CALL REPLY + END IF + ELSE IF (INCMD(:3).EQ.'RES') THEN ! RESPOND? + CALL RESPOND + ELSE IF (INCMD(:3).EQ.'SEA') THEN ! SEARCH? + CALL SEARCH(READ_COUNT) + ELSE IF (INCMD(:3).EQ.'SEE') THEN ! SEEN? + CALL TAG(.TRUE.,2) + ELSE IF (INCMD(:3).EQ.'SEL') THEN ! SELECT? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (INCMD(:3).EQ.'SET') THEN ! SET? + CALL CLI$GET_VALUE('SET_PARAM1',BULL_PARAMETER) + IF (BULL_PARAMETER(:1).EQ.'F') THEN ! SET FOLDER? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRI') THEN ! SET PRIVS? + CALL SET_PRIV + ELSE IF (BULL_PARAMETER(:2).EQ.'PA') THEN ! SET PAGE? + PAGING = .TRUE. + WRITE (6,'('' PAGE has been set.'')') + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SET KEYPAD? + CALL SET_KEYPAD + ELSE IF (BULL_PARAMETER(:3).EQ.'NOK') THEN ! SET NOKEYPAD? + CALL SET_NOKEYPAD + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPA') THEN ! SET NOPAGE? + PAGING = .FALSE. + WRITE (6,'('' NOPAGE has been set.'')') + ELSE IF (FOLDER_NUMBER.EQ.-1.AND.REMOTE_SET.EQ.1) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + ELSE IF (BULL_PARAMETER(:2).EQ.'SY') THEN ! SET SYSTEM? + CALL SET_SYSTEM(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOSY') THEN ! SET NOSYSTEM? + CALL SET_SYSTEM(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'BB') THEN ! SET BBOARD? + CALL SET_BBOARD(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBB') THEN ! SET NOBBOARD? + CALL SET_BBOARD(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'DU') THEN ! SET DUMP? + CALL SET_FOLDER_FLAG(.TRUE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODU') THEN ! SET NODUMP? + CALL SET_FOLDER_FLAG(.FALSE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:2).EQ.'ST') THEN ! SET STRIP? + CALL SET_FOLDER_FLAG(.TRUE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOST') THEN ! SET NOSTRIP? + CALL SET_FOLDER_FLAG(.FALSE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:2).EQ.'DI') THEN ! SET DIGEST? + CALL SET_FOLDER_FLAG(.TRUE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODI') THEN ! SET NODIGEST? + CALL SET_FOLDER_FLAG(.FALSE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:2).EQ.'AL') THEN ! SET ALWAYS? + CALL SET_FOLDER_FLAG(.TRUE.,7,'ALWAYS') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOAL') THEN ! SET NOALWAYS? + CALL SET_FOLDER_FLAG(.FALSE.,7,'ALWAYS') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOTI') THEN ! SET NOTIFY? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(1,-1,-1) + ELSE + CALL SET_USER_FLAG(1,-1,-1) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'E') THEN ! SET EXPIRE? + IER = CLI$GET_VALUE('EXPIRATION',BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.3) THEN + READ (BULL_PARAMETER,'(I)') LIMIT + CALL SET_FOLDER_EXPIRE_LIMIT(LIMIT) + ELSE + WRITE (6,'('' ERROR: Invalid expiration specified.'')') + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NODE') THEN ! SET NODE? + CALL SET_NODE(.TRUE.) + ELSE IF (BULL_PARAMETER(:6).EQ.'NONODE') THEN ! SET NONODE? + CALL SET_NODE(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOE') THEN ! SET NOEXPIRE? + CALL SET_FOLDER_EXPIRE_LIMIT(0) + ELSE IF (BULL_PARAMETER(:5).EQ.'NONOT') THEN ! SET NONOTIFY? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(0,-1,-1) + ELSE + CALL SET_USER_FLAG(0,-1,-1) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'S') THEN ! SET SHOWNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,1) + ELSE + CALL SET_USER_FLAG(-1,0,1) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOS') THEN ! SET NOSHOWNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE + CALL SET_USER_FLAG(-1,0,0) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'R') THEN ! SET READNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,1,0) + ELSE + CALL SET_USER_FLAG(-1,1,0) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOR') THEN ! SET NOREADNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE + CALL SET_USER_FLAG(-1,0,0) + END IF + ELSE IF (BULL_PARAMETER(:2).EQ.'BR') THEN ! SET BRIEF? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,1,1) + ELSE + CALL SET_USER_FLAG(-1,1,1) + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBR') THEN ! SET NOBRIEF? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE + CALL SET_USER_FLAG(-1,0,0) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'A') THEN ! SET ACCESS? + CALL SET_ACCESS(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOA') THEN ! SET NOACCESS? + CALL SET_ACCESS(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'C') THEN ! SET CONTINUOUS_BRIEF + CALL SET_BRIEF_CONTINUOUS(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOC') THEN ! SET NOCONTINUOUS_BRIEF + CALL SET_BRIEF_CONTINUOUS(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'G') THEN ! SET GENERIC? + CALL SET_GENERIC(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOG') THEN ! SET NOGENERIC? + CALL SET_GENERIC(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'L') THEN ! SET LOGIN? + CALL SET_LOGIN(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOL') THEN ! SET NOLOGIN? + CALL SET_LOGIN(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRO') THEN ! SET PROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.FALSE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPR') THEN ! SET NOPROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.TRUE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:3).EQ.'DEF') THEN ! SET DEFAULT_EXPIRE? + CALL SET_DEFAULT_EXPIRE + END IF + ELSE IF (INCMD(:4).EQ.'SHOW') THEN ! SHOW? + CALL CLI$GET_VALUE('SHOW_PARAM1',BULL_PARAMETER,LEN_P) + IF (BULL_PARAMETER(:2).EQ.'FL') THEN ! SHOW FLAGS? + CALL SHOW_FLAGS + ELSE IF (BULL_PARAMETER(:2).EQ.'FO') THEN ! SHOW FOLDER? + CALL SHOW_FOLDER + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SHOW KEYPAD + CALL SHOW_KEYPAD(HELP_DIRECTORY(:HLEN)//'BULL.HLB') + ELSE IF (BULL_PARAMETER(:1).EQ.'N') THEN ! SHOW NEW? + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + SAVE_FOLDER = FOLDER + CALL NEW_MESSAGE_NOTIFICATION + FOLDER1 = SAVE_FOLDER + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE IF (BULL_PARAMETER(:1).EQ.'P') THEN ! SHOW PRIVILEGES? + CALL SHOW_PRIV + ELSE IF (BULL_PARAMETER(:1).EQ.'U') THEN ! SHOW USER? + CALL SHOW_USER + ELSE IF (BULL_PARAMETER(:1).EQ.'V') THEN ! SHOW VERSION? + CALL SHOW_VERSION + END IF + ELSE IF (INCMD(:4).EQ.'SPAW') THEN ! SPAWN command? + CALL SPAWN_PROCESS + ELSE IF (INCMD(:3).EQ.'SUB') THEN ! SUBSCRIBE command? + CALL SUBSCRIBE + ELSE IF (INCMD(:4).EQ.'UNDE') THEN ! UNDELETE? + CALL UNDELETE + ELSE IF (INCMD(:3).EQ.'UNM') THEN ! UNMARK? + CALL TAG(.FALSE.,1) + ELSE IF (INCMD(:4).EQ.'UNSE') THEN ! UNSEEN? + CALL TAG(.FALSE.,2) + ELSE IF (INCMD(:4).EQ.'UNSU') THEN ! UNSUBSCRIBE command? + CALL UNSUBSCRIBE + END IF + +100 CONTINUE + + IF (DCL_COMMAND.AND.TRIM(DCL_CMD).EQ.0) CALL EXIT + + END DO + +1010 FORMAT(Q,A) +1060 FORMAT(' ERROR: There are no more preceding messages.') + + END + + + + SUBROUTINE COMMAND_INPUT(IER) + + IMPLICIT INTEGER (A - Z) + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /PROMPT_PROMPT/ PROMPT,LPROMPT + CHARACTER*42 PROMPT + + CALL GET_INPUT_PROMPT(INCMD,IER,PROMPT(:LPROMPT)) + + RETURN + + END + + + + + + SUBROUTINE ADD +C +C SUBROUTINE ADD +C +C FUNCTION: Adds bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /INDESCRIP/ INDESCRIP + CHARACTER*(LINE_LENGTH) INDESCRIP + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + CHARACTER INEXDATE*11,INEXTIME*11 + + CHARACTER INLINE*80,OLD_FOLDER*25,LOCAL_NODE*8 + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + EDITIT = (CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)) + + IF (CLI$PRESENT('EXTRACT').AND..NOT.EDITIT) THEN + WRITE (6,'('' ERROR: Cannot extract text without /EDIT.'')') + RETURN + END IF + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + ALLOW = SETPRV_PRIV() + + OLD_FOLDER_NUMBER = FOLDER_NUMBER + OLD_FOLDER = FOLDER + + LEN_P = 0 + + IF (CLI$PRESENT('EXTRACT')) THEN + BULL_PARAMETER = 'SYS$LOGIN:BULL.SCR' + LEN_P = TRIM(BULL_PARAMETER) + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH, + & STATUS='NEW',CARRIAGECONTROL='LIST',FORM='FORMATTED') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + +90 CALL CLOSE_BULLFIL + END IF + + IF (CLI$PRESENT('FILESPEC')) THEN + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + CALL DISABLE_PRIVS + IF (.NOT.CLI$PRESENT('EXTRACT')) THEN + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD', + & READONLY,SHARED,ERR=920,FORM='FORMATTED') + ELSE + OPEN (UNIT=4,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD', + & READONLY,SHARED,ERR=920,FORM='FORMATTED') + IER = 0 + ICOUNT = 0 + DO WHILE (IER.EQ.0) + READ (4,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.EQ.0) THEN + IF (ICOUNT.EQ.0) WRITE (3,'(A)') ' ' + ICOUNT = ICOUNT + 1 + WRITE (3,'(A)') INPUT(:ILEN) + END IF + END DO + CLOSE (UNIT=4) + BULL_PARAMETER = 'SYS$LOGIN:BULL.SCR' + LEN_P = TRIM(BULL_PARAMETER) + END IF + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + END IF + + SELECT_FOLDERS = .FALSE. + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL GET_FOLDER_INFO(IER) + IF (.NOT.IER) GO TO 910 + SELECT_FOLDERS = .TRUE. + ELSE + NODE_NUM = 1 + NODES(1) = OLD_FOLDER + END IF + + IF (FOLDER_NUMBER.GT.0.AND. ! If folder set and + & CLI$PRESENT('NODES')) THEN ! Decnet nodes specified? + WRITE (6,'('' ERROR: /NODES cannot be used with folder set.'')') + GO TO 910 + END IF + + IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0.AND. + & (CLI$PRESENT('SYSTEM').OR. ! Is /SYSTEM switch present? + & CLI$PRESENT('BROADCAST').OR. ! Is /BROADCAST swtich present? + & CLI$PRESENT('SHUTDOWN'))) THEN ! Is /SHUTDOWN switch present? + WRITE (6,'('' ERROR: Folder is not a SYSTEM folder.'')') + GO TO 910 + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN ! Is /SYSTEM switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1070) ! Tell user + GO TO 910 ! and abort + END IF + SYSTEM = 1 ! Set system bit + ELSE + SYSTEM = 0 ! Clear system bit + END IF + + IF (CLI$PRESENT('BROADCAST')) THEN ! Is /BROADCAST switch present? + IF (.NOT.(ALLOW.OR.OPER_PRIV())) THEN ! If no privileges + WRITE(ERROR_UNIT,1080) ! Tell user + GO TO 910 ! and abort + ELSE IF (CLI$PRESENT('CLUSTER')) THEN + SYSTEM = SYSTEM.OR.8 + END IF + END IF + + IF (CLI$PRESENT('PERMANENT')) THEN ! Is /PERMANENT switch present? + IF (F_EXPIRE_LIMIT.GT.0.AND..NOT. ! Expiration limit present + & FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE(ERROR_UNIT,1083) + GO TO 910 + ELSE + SYSTEM = SYSTEM.OR.2 ! Set permanent bit + INEXDATE = '5-NOV-2000' + INEXTIME = '00:00:00.00' + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN ! Is /SHUTDOWN switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1082) ! Tell user + GO TO 910 ! and abort + ELSE + IER = CLI$GET_VALUE('SHUTDOWN',INLINE) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (REMOTE_SET) THEN ! Can't specify node name if + WRITE (6,1090) ! remote folder, as no code + GO TO 910 ! present to send the name. + END IF + CALL GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,INLINE) + IF (NODE_AREA.EQ.0) GO TO 910 ! Invalid node name + ELSE + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + END IF + SYSTEM = SYSTEM.OR.4 ! Set shutdown bit + INEXDATE = '5-NOV-2000' + WRITE (INEXTIME,'(I4)') NODE_NUMBER + WRITE (INEXTIME(7:),'(I4)') NODE_AREA + DO I=1,11 + IF (INEXTIME(I:I).EQ.' ') INEXTIME(I:I) = '0' + END DO + INEXTIME = INEXTIME(1:2)//':'//INEXTIME(3:4)//':'// + & INEXTIME(7:8)//'.'//INEXTIME(9:10) + END IF + END IF + + SELECT_NODES = .FALSE. + IF (CLI$PRESENT('NODES')) THEN + CALL GET_NODE_INFO + IF (NODE_ERROR) GO TO 940 + SELECT_NODES = .TRUE. + END IF + + IF ((SYSTEM.AND.7).LE.1) THEN ! Not permanent or shutdown + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + + IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + LENDES = TRIM(INDESCRIP) ! filled in by main subroutine + ELSE IF (CLI$PRESENT('SUBJECT')) THEN ! /SUBJECT specified + CALL CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + ELSE + WRITE(6,1050) ! Request header for bulletin + CALL GET_LINE(INDESCRIP,LENDES) ! Get input line + IF (LENDES.LE.0) GO TO 910 + END IF + + LENDES = MIN(LEN(INDESCRIP)-6,LENDES) ! Make room for "Subj: " + +C +C If file specified in ADD command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + IF (EDITIT.AND..NOT.DECNET_PROC) THEN ! If /EDIT specified + IF (LEN_P.EQ.0) THEN ! If no file param specified + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=910,FORM='FORMATTED') + LEN_P = 1 + ELSE + CLOSE (UNIT=3) + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + IF (CLI$PRESENT('EXTRACT')) THEN + CONTEXT = 0 + CALL LIB$FIND_FILE('SYS$LOGIN:BULL.SCR',INPUT,CONTEXT) + VERSION = INDEX(INPUT,';') + 1 + IF (INPUT(VERSION:VERSION).EQ.'1') THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + END IF + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=910,FORM='FORMATTED') + END IF + END IF + + ICOUNT = 0 ! Line count for bulletin + + END = 0 + BLENGTH = 35 + IF (CLI$PRESENT('BELL')) BLENGTH = 37 + IF (LEN_P.GT.0) THEN ! If file param in ADD command + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + ICOUNT = ICOUNT + 1 + MIN(ILEN,80) + BLENGTH = BLENGTH + ILEN - 1 + 2 + IF (ILEN.EQ.0) ICOUNT = ICOUNT + 1! COPY_BULL writes line with + END DO ! 1 space for blank line + ELSE ! If no input file + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) ! Temp file to save message + WRITE (6,1000) ! Request input from terminal + ILEN = LINE_LENGTH + 1 ! Length of input line + ICOUNT = 0 ! Character count counter + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Input line too long + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput:'')') LINE_LENGTH + ELSE IF (ILEN.GE.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN ! Update counter + BLENGTH = BLENGTH + ILEN - 1 + 2 + WRITE(3,2010) INPUT(:ILEN) ! Save line in scratch file + END IF + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + REWIND (UNIT=3) + + BRDCST = .FALSE. + + IF (CLI$PRESENT('BROADCAST').AND.BLENGTH.GT.82*12+2) THEN + WRITE (6,'('' Message is too long for broadcasting.'', + & '' A truncated message will be broadcast.'')') + CALL GET_INPUT_PROMPT(INPUT,ILEN, + & 'Type C to continue, A to only ADD message, or Q to Quit: ') + IF (STREQ(INPUT(:1),'Q')) THEN + GO TO 910 + ELSE IF (STREQ(INPUT(:1),'A')) THEN + BRDCST = .TRUE. + END IF + END IF + + IF (SELECT_NODES.AND.NODE_NUM.GT.0) THEN + INLINE = 'ADD' + IF (CLI$PRESENT('SYSTEM')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SYSTEM' + IF (CLI$PRESENT('BROADCAST').AND..NOT.BRDCST) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BROADCAST' + IF (CLI$PRESENT('PERMANENT')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/PERMANENT' + IF (CLI$PRESENT('SHUTDOWN')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SHUTDOWN' + IF (CLI$PRESENT('BELL')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BELL' + + LEN_INLINE = STR$POSITION(INLINE,' ') - 1 + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + INLINE = INLINE(:LEN_INLINE) + + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + IF ((SYSTEM.AND.7).LE.1) + ! If not permanent or shutdown specify date + & WRITE (POINT_NODE+9,'(A)',ERR=940) INEXDATE//' '//INEXTIME + WRITE (POINT_NODE+9,'(A)',ERR=940) INDESCRIP(:LENDES) + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + ILEN = MIN(ILEN,LINE_LENGTH) + IF (IER.EQ.0) THEN + WRITE (POINT_NODE+9,'(A)',ERR=940) INPUT(:ILEN) + END IF + END DO + WRITE (POINT_NODE+9,'(A)',ERR=940) CHAR(26) + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INPUT + IF (INPUT.EQ.'END') THEN + WRITE (6,'('' Message successfully sent to node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while sending message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INPUT(:80) + GO TO 940 + END IF + REWIND (UNIT=3) + END DO + END IF + + IF (SELECT_NODES.AND..NOT.LOCAL_NODE_FOUND) GO TO 95 + ! Exit if local node not specified. + + IF (.NOT.SELECT_FOLDERS) THEN + NODE_NUM = 1 ! No folders specified so just + NODES(1) = FOLDER ! add to select folder + END IF + + IER = SYS_TRNLNM('SYS$NODE',LOCAL_NODE) + LNODE = TRIM(LOCAL_NODE) + LUSER = TRIM(USERNAME) + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + DO I = 1,NODE_NUM + + IF (FOLDER.NE.NODES(I)) THEN + FOLDER_NUMBER = -1 + FOLDER1 = NODES(I) + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE + IER = 1 + END IF + + IF (IER) THEN + CALL OPEN_BULLDIR ! Prepare to add dir entry + + DESCRIP=INDESCRIP(:LENDES) ! Description header + EXDATE=INEXDATE ! Expiration date + EXTIME=INEXTIME + FROM = USERNAME ! Username + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + REWIND (UNIT=3) + OBLOCK = NBLOCK+1 + CALL STORE_BULL(LNODE+LUSER+6,'From: '// + & LOCAL_NODE(:LNODE)//USERNAME(:LUSER),OBLOCK) + IF (LENDES.GT.LEN(DESCRIP)) THEN + CALL STORE_BULL(LENDES+6, + & 'Subj: '//INDESCRIP(:LENDES),OBLOCK) + END IF + CALL COPY_BULL(3,1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) GO TO 930 ! Error in creating bulletin + LENGTH = OCOUNT - (NBLOCK+1) + 1 +C +C Broadcast the bulletin if requested. +C + IF (.NOT.BRDCST.AND.CLI$PRESENT('BROADCAST').AND. + & (.NOT.REMOTE_SET.OR.FOLDER_NUMBER.GT.0)) THEN + CALL GET_BROADCAST_MESSAGE(CLI$PRESENT('BELL')) + BRDCST = .TRUE. + IF (.NOT.CLI$PRESENT('LOCAL')) THEN + CALL BROADCAST_ALL_NODES(CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER')) + END IF +C +C If the folder is remote, and local node is not the node which BULLCP is +C on, don't broadcast, as it will be broadcasted by BULLCP. The remote +C node will distribute the broadcast to nodes that are running BULLCP, +C but not if the node that originated the message matches. However, it +C has no way of knowing that the originating node is in the same cluster +C as that of the BULLCP node. +C + IF ((REMOTE_SET.AND.LOCAL_NODE(:LNODE-2).EQ.NODENAME) + & .OR.CLI$PRESENT('LOCAL').OR..NOT.REMOTE_SET) + & CALL BROADCAST( + & CLI$PRESENT('ALL'),CLI$PRESENT('CLUSTER')) + END IF + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CALL ADD_ENTRY ! Add the new directory entry + + IF (FOLDER_NUMBER.GE.0) THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + CALL UPDATE_FOLDER ! Update info in folder file +C +C If user is adding message, an no new messages, update last read time for +C folder, so user is not alerted of new message which is owned by user. +C + IF (DIFF.GE.0) THEN + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + ELSE + WRITE (6,'('' ERROR: Unable to add message to '',A)') + & NODES(I) + END IF + END DO + +95 CLOSE (UNIT=3) ! Close the input file + IF (DECNET_PROC) WRITE(5,'(''END'')') ! DECNET operation worked + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + DO I=10,NODE_NUM+9 + CLOSE (UNIT=I) + END DO + + IF (FOLDER_NUMBER.NE.OLD_FOLDER_NUMBER) THEN + FOLDER_NUMBER = OLD_FOLDER_NUMBER + FOLDER1 = OLD_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + + IF (CLI$PRESENT('EXTRACT')) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + +910 WRITE(ERROR_UNIT,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(ERROR_UNIT,1020) + CALL ENABLE_PRIVS + GOTO 100 + +930 WRITE (ERROR_UNIT,1025) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + +940 WRITE (6,1015) NODES(POINT_NODE) + WRITE (6,1018) + CLOSE (UNIT=3) + GO TO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1010 FORMAT (' No message was added.') +1015 FORMAT (' ERROR: Unable to reach node ',A) +1018 FORMAT (' Try using /FOLDER instead of /NODE.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1025 FORMAT (' ERROR: Unable to add message to file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1070 FORMAT (' ERROR: SETPRV privileges are needed for system + & messages.') +1080 FORMAT (' ERROR: SETPRV privileges are needed to broadcast + & messages.') +1082 FORMAT (' ERROR: SETPRV privileges are needed to shutdown + & messages.') +1083 FORMAT (' ERROR: Folder has expiration limit.') +1090 FORMAT (' ERROR: Nodename cannot be specified for shutdown + & if folder is remote.') +2010 FORMAT(A) +2020 FORMAT(1X,A) + + END + + + SUBROUTINE SUBTIME(BTIM,DAYS_BEFORE_TODAY,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER DAYS_BEFORE_TODAY*(*),TODAY_DATE*23 + + INTEGER BTIM(2),TODAY_BTIM(2) + + IER = SYS$BINTIM(DAYS_BEFORE_TODAY,BTIM) + IF (.NOT.IER) RETURN + + BTIM(1) = -BTIM(1) ! Convert to negative delta time + BTIM(2) = -BTIM(2)-1 + + IER = SYS$ASCTIM(TLEN,TODAY_DATE,,) + CALL SYS$BINTIM(TODAY_DATE(:TLEN),TODAY_BTIM) + + CALL LIB$SUBX(TODAY_BTIM,BTIM,BTIM) + + RETURN + END + + + + SUBROUTINE BROADCAST_ALL_NODES(ALL,CLUSTER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + COMMON /BROAD_MESSAGE/ BMESSAGE,BLENGTH + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER LOCALNODE*8,RESPONSE*1 + + IF (.NOT.TEST_BULLCP().OR.REMOTE_SET) RETURN + + CALL OPEN_BULLUSER_SHARED + + REMOTE_FOUND = .FALSE. + TEMP_USER = ':' + + DO WHILE (.NOT.REMOTE_FOUND) + DO WHILE (REC_LOCK(IER)) + READ (4,KEYGT=TEMP_USER,IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM,NEW_FLAG + END DO + IF (TEMP_USER(:1).NE.':') THEN + CALL CLOSE(4) + RETURN + END IF + REMOTE_FOUND = TEST2(NEW_FLAG,FOLDER_NUMBER) + END DO + + CALL CLOSE (4) + +100 OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=NODENAME(:TRIM(NODENAME))//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IER = 0 + I = 1 + DO WHILE (IER.EQ.0.AND.I.LT.BLENGTH) + WRITE (17,'(4A)',IOSTAT=IER) + & 15,-1,I,BMESSAGE(I:MIN(BLENGTH,I+127)) + I = I + 128 + END DO + IF (IER.EQ.0) WRITE (17,'(7A)',IOSTAT=IER) + & 15,BLENGTH,I,ALL,CLUSTER,FOLDER_NUMBER,FOLDER + ELSE + WRITE (6,'('' BULLCP not responding to request to'', + & '' broadcast to other nodes.'')') + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Want to try again? (Y/N with Y as default): ') + IF (RESPONSE.NE.'n'.AND.RESPONSE.NE.'N') THEN + WRITE (6,'('' Trying again...'')') + GO TO 100 + ELSE + WRITE (6,'('' Broadcast aborting. '', + & ''Continuing with message addition.'')') + END IF + END IF + + CLOSE (UNIT=17) + + RETURN + END + + + + + INTEGER FUNCTION ERROR_TRAP + + ERROR_TRAP = 1 + + RETURN + END + + + + SUBROUTINE REPLY + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /INDESCRIP/ INDESCRIP + CHARACTER*(LINE_LENGTH) INDESCRIP + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + INDESCRIP = INPUT(7:) + ELSE + INDESCRIP = DESCRIP + END IF + + CALL CLOSE_BULLFIL + + CALL CLOSE_BULLDIR + + WRITE (6,'('' Adding REPLY message with the subject:'')') + IF (STREQ(INDESCRIP(:3),'RE:')) THEN + INDESCRIP = 'RE:'//INDESCRIP(4:) + ELSE + INDESCRIP = 'RE: '//INDESCRIP + END IF + WRITE (6,'(1X,A)') INDESCRIP(:TRIM(INDESCRIP)) + + CALL ADD + + RETURN + END + + + + + SUBROUTINE CRELNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PSLDEF)' + + INCLUDE '($LNMDEF)' + + CHARACTER*(*) INPUT,OUTPUT + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT)) + CALL END_ITMLST(CRELNM_ITMLST) + + IER = SYS$CRELNM(,'LNM$PROCESS',INPUT,PSL$C_USER, + & %VAL(CRELNM_ITMLST)) + + RETURN + END + + + + SUBROUTINE GETPRIV +C +C SUBROUTINE GETPRIV +C +C FUNCTION: +C To get process privileges. +C OUTPUTS: +C PROCPRIV - Returned privileges +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /REALPROC/ REALPROCPRIV(2) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(8,JPI$_PROCPRIV,%LOC(PROCPRIV)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + REALPROCPRIV(1) = PROCPRIV(1) + REALPROCPRIV(2) = PROCPRIV(2) + + RETURN + END + + + + + LOGICAL FUNCTION SETPRV_PRIV + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + DATA NEEDPRIV/0,0/ + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (NEEDPRIV(1).EQ.0.AND.NEEDPRIV(2).EQ.0) THEN + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + CALL CLOSE_BULLUSER + NEEDPRIV(1) = USERPRIV(1) + NEEDPRIV(2) = USERPRIV(2) + END IF + + IF ((PROCPRIV(1).AND.NEEDPRIV(1)).NE.0.OR. + & (PROCPRIV(2).AND.NEEDPRIV(2)).NE.0) THEN + SETPRV_PRIV = .TRUE. + ELSE + SETPRV_PRIV = .FALSE. + END IF + + RETURN + END + + + + LOGICAL FUNCTION OPER_PRIV + IMPLICIT INTEGER (A-Z) + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + INCLUDE '($PRVDEF)' + OPER_PRIV = BTEST(PROCPRIV(1),PRV$V_OPER) + RETURN + END + + + + SUBROUTINE GETUSER(USERNAME) +C +C SUBROUTINE GETUSER +C +C FUNCTION: +C To get username of present process. +C OUTPUTS: +C USERNAME - Username owner of present process. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + CHARACTER*(*) USERNAME ! Limit is 12 characters + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + RETURN + END + + + + + LOGICAL FUNCTION CAPTIVE() + + IMPLICIT INTEGER (A - Z) + + INCLUDE '($UAIDEF)' + + INCLUDE 'BULLUSER.INC' + + DATA READ_UAI/.FALSE./ + + TYPE = 1 + + IF (.NOT.READ_UAI) THEN + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL END_ITMLST(GETUAI_ITMLST) + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) + READ_UAI = .TRUE. + END IF + + CAPTIVE = ((FLAGS.AND.(UAI$M_CAPTIVE.OR.UAI$M_RESTRICTED)).NE.0 + & .AND.1).OR.ISHFT(((FLAGS.AND.UAI$M_NOMAIL).NE.0).AND.1,1) + + RETURN + END + + + + + SUBROUTINE SPAWN_PROCESS + + IMPLICIT INTEGER (A - Z) + + COMMON /KEYPAD/ KEYPAD_MODE + + CHARACTER*255 COMMAND + + IF (CAPTIVE()) THEN + WRITE (6,'('' ERROR: SPAWN not allowed from CAPTIVE account.'')') + RETURN + END IF + + CALL DISABLE_PRIVS + + SAVE_KEYPAD_MODE = KEYPAD_MODE + IF (KEYPAD_MODE.EQ.0) CALL SET_KEYPAD + + IF (CLI$PRESENT('COMMAND')) THEN + CALL CLI$GET_VALUE('COMMAND',COMMAND,CLEN) + COMMAND = '$'//COMMAND(:CLEN) + CALL LIB$SPAWN(COMMAND(:CLEN+1)) + ELSE + CALL LIB$SPAWN() + END IF + + IF (SAVE_KEYPAD_MODE.EQ.0) CALL SET_NOKEYPAD + + CALL ENABLE_PRIVS + + RETURN + END + + + SUBROUTINE ATTACH + + IMPLICIT INTEGER (A - Z) + + COMMON /KEYPAD/ KEYPAD_MODE + + COMMON /TERM_CHAN/ TERM_CHAN + + INCLUDE '($JPIDEF)' + + CHARACTER*15 PROCESS + + IF (CLI$PRESENT('PROCESS')) THEN + CALL CLI$GET_VALUE('PROCESS',PROCESS,PLEN) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,JPI$_PID,%LOC(PROCESS_ID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,PROCESS(:PLEN),%VAL(GETJPI_ITMLST),,,,) + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,JPI$_OWNER,%LOC(PROCESS_ID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) + END IF + + IER = SYS$CANCEL(%VAL(TERM_CHAN)) + + SAVE_KEYPAD_MODE = KEYPAD_MODE + IF (KEYPAD_MODE.EQ.0) CALL SET_KEYPAD + + IF (IER) IER = LIB$ATTACH(PROCESS_ID) + IF (.NOT.IER) CALL SYS_GETMSG(IER) + + IF (SAVE_KEYPAD_MODE.EQ.0) CALL SET_NOKEYPAD + + RETURN + END + + + + + + SUBROUTINE GET_BROADCAST_MESSAGE(RING_BELL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($BRKDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + +C +C The largest message that can be broadcasted is dependent on system +C and user quotas. The following limit is 12 lines of ( 80 characters + +C CR/LF ) + 2 bells. This should be more than enough room, as broadcasts +C shouldn't be too large anyway. +C + + PARAMETER CR=CHAR(13),LF=CHAR(10),BELL=CHAR(7) + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BROAD + + COMMON /BROAD_MESSAGE/ BROAD,BLENGTH + + IF (RING_BELL) THEN ! Include BELL in message? + BROAD(:36) = ! Say who the bulletin is from + & BELL//BELL//CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 37 ! Start adding next line here + ELSE + BROAD(:34) = ! Say who the bulletin is from + & CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 35 ! Start adding next line here + END IF + + IF (REMOTE_SET) REWIND (UNIT=3) + + END = 0 + ILEN = LINE_LENGTH + 1 + I = 0 + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (REMOTE_SET) THEN + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0) RETURN + ELSE + CALL GET_BULL_LINE(NBLOCK+1,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0) I = I + 1 + IF (ILEN.GT.0.AND.(I.GT.2.OR.(INPUT(:6).NE.'From: '.AND. + & INPUT(:6).NE.'Subj: '))) THEN + END = BLENGTH + ILEN - 1 + 2 ! Check how long string will be + IF (END.GT.BRDCST_LIMIT) RETURN ! String too long? + BROAD(BLENGTH:END) = CR//LF//INPUT(:ILEN)! Else add new input + BLENGTH = END + 1 ! Reset pointer + END IF + END DO + + RETURN + + ENTRY BROADCAST(ALL,CLUSTER) + + CALL SYS$SETRWM(%VAL(1)) ! Don't wait if can't broadcast + + IF (ALL) THEN ! Should we broadcast to ALL? + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,,,,,) + END IF + ELSE ! Else just broadcast to users. + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,,,,,) + END IF + END IF + + CALL SYS$SETRWM(%VAL(0)) + + RETURN + END + + + SUBROUTINE GET_FOLDER_INFO(IER) +C +C SUBROUTINE GET_FOLDER_INFO +C +C FUNCTION: Obtains & verifies folder names from command line. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + CHARACTER NODE_TEMP*256 + + NODE_NUM = 0 ! Initialize number of nodes + DO WHILE (CLI$GET_VALUE('SELECT_FOLDER',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(:COMMA-1) + NODE_TEMP = NODE_TEMP(COMMA+1:) + ELSE + NODES(NODE_NUM) = NODE_TEMP + NODE_TEMP = ' ' + END IF + NLEN = TRIM(NODES(NODE_NUM)) + IF (NODES(NODE_NUM)(NLEN-1:NLEN).EQ.'::') THEN + NODES(NODE_NUM) = NODES(NODE_NUM)(:NLEN)//'GENERAL' + END IF + FOLDER_NUMBER = -1 + FOLDER1 = NODES(NODE_NUM) + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' Unable to access folder '',A)') + & NODES(NODE_NUM) + RETURN + ELSE IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No write access for folder '',A)') + & NODES(NODE_NUM) + IER = 0 + RETURN + END IF + END DO + END DO + + IER = 1 + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin.for_gcemod b/decus/vax91b/gce91b/net91b/bulletin.for_gcemod new file mode 100644 index 0000000..349304b --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin.for_gcemod @@ -0,0 +1,1778 @@ +C +C BULLETIN.FOR, Version 6/24/91 +C Purpose: Bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /POINT/ BULL_POINT + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING /.FALSE./ + + COMMON /CTRLY/ CTRLY + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + EXTERNAL ERROR_TRAP + EXTERNAL BULLETIN_SUBCOMMANDS,LIB$GET_INPUT + EXTERNAL BULLETIN_MAINCOMMANDS,ENABLE_CTRL_EXIT + EXTERNAL CLI$_ABSENT,CLI$_NOCOMD,CLI$_NEGATED + + PARAMETER PCB$M_BATCH = '4000'X + PARAMETER PCB$M_NETWRK = '200000'X + PARAMETER LIB$M_CLI_CTRLY = '2000000'X + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER HELP_DIRECTORY*64,SAVE_FOLDER*25 + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /PROMPT_PROMPT/ PROMPT,LPROMPT + CHARACTER*42 PROMPT + + CHARACTER DCL_CMD*132 + + CALL LIB$GET_FOREIGN(INCMD) + DCL_COMMAND = INDEX(INCMD,' "').GT.0.OR.INCMD(:1).EQ.'"' + + CALL LIB$ESTABLISH(ERROR_TRAP) + IF (.NOT.CLI$GET_VALUE('PROMPT',COMMAND_PROMPT,ILEN)) THEN + CALL LIB$REVERT + CALL CLI$GET_VALUE('$LINE',COMMAND_PROMPT,ILEN) + INCMD = 'BULLETIN '//INCMD + CALL CLI$DCL_PARSE(INCMD,BULLETIN_MAINCOMMANDS) + ELSE + CALL LIB$REVERT + END IF + + IF (DCL_COMMAND) THEN + IER = CLI$GET_VALUE('SELECT_FOLDER',DCL_CMD,LENP) + IF (LENP.GT.0) THEN + IF (DCL_CMD(LENP:LENP).EQ.'"') DCL_CMD = DCL_CMD(:LENP-1) + IF (DCL_CMD(:1).EQ.'"') DCL_CMD = DCL_CMD(2:) + END IF + END IF + + READIT = 0 + + LOGIN_SWITCH = CLI$PRESENT('LOGIN') + SYSTEM_SWITCH = CLI$PRESENT('SYSTEM') + REVERSE_SWITCH = CLI$PRESENT('REVERSE') + + IER = LIB$SYS_TRNLOG('BULL_DISABLE',LEN_P,BULL_PARAMETER) + IF (IER.EQ.1.AND.LEN_P.GT.0.AND..NOT.CLI$PRESENT('STOP')) THEN + IF (.NOT.LOGIN_SWITCH) THEN + WRITE (6,'('' BULLETIN temporarily disabled. Try later.'')') + END IF + CALL EXIT + END IF + + CALL SYS$SETDFPROT(,ORIGINAL_DEF_PROT) + ! Save original default protection in case it gets changed + + CALL DCLEXH(%LOC(ENABLE_CTRL_EXIT)) ! Declare exit handler + +C +C Check to see if CONTROL Y disabled. If so, then never disable CONTROL Y. +C Disabling and enabling CONTROL Y is done so that a person can not break +C while one of the data files is opened, as that would not allow anyone +C else to modify the files. However, if CONTROL Y is already disabled, +C this is not necessary, and should not be done! +C + + CALL LIB$DISABLE_CTRL(LIB$M_CLI_CTRLY,CTRLY) ! Disable CTRL-Y & -C + CTRLY = CTRLY .AND. LIB$M_CLI_CTRLY + CALL GETPRIV ! Check privileges + CALL CHECK_PRIV_IO(ERR) ! Check privileges on output I/O + CALL LIB$ENABLE_CTRL(CTRLY,) ! Renable CTRLY-Y & -C + + IF (ERR.EQ.1) CALL EXIT ! I/O privilege error, so exit + + CALL GETUSER(USERNAME) ! Get the process's username + IF (.NOT.LOGIN_SWITCH) CALL CHECK_BULLETIN_PRIV(USERNAME) + ! Check if has bulletin privileges + + I = 1 ! Strip off folder name if specified + DO WHILE (I.LE.ILEN) + IF (COMMAND_PROMPT(I:I).EQ.' ') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + I = ILEN + 1 + ELSE + I = I + 1 + END IF + END DO + ILEN = 1 ! Get executable name to use as prompt + DO WHILE (ILEN.GT.0) + ILEN = MAX(INDEX(COMMAND_PROMPT,':'),INDEX(COMMAND_PROMPT,']')) + IF (ILEN.GT.0) THEN + COMMAND_PROMPT = COMMAND_PROMPT(ILEN+1:) + ELSE + DO I=TRIM(COMMAND_PROMPT),1,-1 + IF (COMMAND_PROMPT(I:I).LT.'A'.OR. + & COMMAND_PROMPT(I:I).GT.'Z') THEN + COMMAND_PROMPT = COMMAND_PROMPT(:I-1) + END IF + END DO + END IF + END DO + COMMAND_PROMPT = COMMAND_PROMPT(:TRIM(COMMAND_PROMPT))//'> ' + IF (COMMAND_PROMPT.EQ.'RUN> '.OR.COMMAND_PROMPT.EQ.'RU> '.OR. + & COMMAND_PROMPT.EQ.'R> ') COMMAND_PROMPT = 'BULLETIN> ' + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + + CALL CLI$GET_VALUE('SEPARATE',SEPARATE) + + IF (CLI$PRESENT('EDIT')) EDIT_DEFAULT = .TRUE. ! /EDIT switch test + + CALL FIND_BULLCP ! See if BULLCP is running + + IF (CLI$PRESENT('CLEANUP')) THEN ! Test for /CLEANUP switch + CALL CLI$GET_VALUE('CLEANUP',BULL_PARAMETER,LEN_P) ! Get folder # + READ (BULL_PARAMETER,'(I)') FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + CALL EXIT ! all done with cleanup + ELSE IF (CLI$PRESENT('BBOARD')) THEN ! Test for /BBOARD switch + CALL BBOARD ! look for BBOARD mail + CALL EXIT ! all done with BBOARD + ELSE IF (CLI$PRESENT('STARTUP').OR. ! BULLCP process control + & CLI$PRESENT('STOP')) THEN + CALL CREATE_BULLCP + ELSE IF (CLI$PRESENT('BULLCP')) THEN ! This is BULLCP, so start + IF (.NOT.CLI$GET_VALUE('SELECT_FOLDER', + & BULL_PARAMETER,LENP)) THEN + CALL RUN_BULLCP ! doing what BULLCP does! + ELSE IF (BULL_PARAMETER(:LENP).EQ.'NEWS') THEN + CALL NEWS2BULL + END IF + END IF + + CALL GETSTS(STS) ! Get process status word + + IF (SYSTEM_SWITCH.OR.LOGIN_SWITCH) THEN ! If BULLETIN/LOGIN or /SYSTEM + IF ((STS.AND.PCB$M_BATCH).GT.0) CALL EXIT ! If BATCH, exit + CALL CRELNM('SYS$INPUT','TT') ! Take input from terminal + END IF + + IF ((STS.AND.PCB$M_NETWRK).EQ.0) THEN + DECNET_PROC = .FALSE. + ERROR_UNIT = 6 + + CALL ASSIGN_TERMINAL ! Assign terminal + + IF (.NOT.LOGIN_SWITCH) THEN + INCMD = 'SELECT' ! Causes nearest folder name to be selected + CALL SELECT_FOLDER(.FALSE.,IER) ! Select GENERAL folder + IF (.NOT.IER) RETURN ! If can't access, exit + + IF (.NOT.TEST_BULLCP()) CALL DELETE_EXPIRED + ! Delete expired messages + END IF + +C +C Get page size for the terminal. +C + + CALL GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) + + IER = CLI$GET_VALUE('WIDTH',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + DECODE(LEN_P,'(I)',BULL_PARAMETER) PAGE_WIDTH + END IF + + IF (CLI$PRESENT('PAGE')) PAGING = .TRUE. + + IF (SYSTEM_SWITCH) THEN + IER = CLI$GET_VALUE('SYSTEM',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Days specified? + CALL SUBTIME(SYSTEM_LOGIN_BTIM,BULL_PARAMETER(:LEN_P),IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Invalid parameter in /SYSTEM.'')') + CALL EXIT + END IF + END IF + IF (.NOT.LOGIN_SWITCH) THEN + CALL MODIFY_SYSTEM_LIST(0) + CALL SHOW_SYSTEM + CALL EXIT + END IF + END IF + +C +C Get user info stored in SYS$LOGIN. Currently, this simply stores +C the time of the latest message read for each folder. +C + + CALL OPEN_USERINFO + +C +C If /LOGIN, display SYSTEM bulletins and subject of non-SYSTEM bulletins. +C + + IF (LOGIN_SWITCH.OR.SYSTEM_SWITCH) THEN ! Is /LOGIN present? + CALL LOGIN ! Display SYSTEM bulletins + IF (READIT.EQ.0) CALL EXIT ! If no READNEWs not set, exit + END IF + +C +C If new bulletins have been added since the last time bulletins have been +C read, position bulletin pointer so that next bulletin read is the first new +C bulletin, and alert user. If READNEW set and no new bulletins, just exit. +C + + IF (.NOT.DCL_COMMAND) CALL NEW_MESSAGE_NOTIFICATION + + CALL OPEN_OLD_TAG + + ELSE + IF (TEST_BULLCP()) CALL EXIT + DECNET_PROC = .TRUE. + ERROR_UNIT = 5 + END IF + +C +C The MAIN loop for processing bulletin commands. +C + + DIR_COUNT = 0 ! # directory entry to continue bulletin read from + READ_COUNT = 0 ! # block that bulletin READ is to continue from + FOLDER_COUNT = 0 ! # folder entry to continue SHOW/ALL folder from + INDEX_COUNT = 0 + + IER = LIB$SYS_TRNLOG('BULL_HELP',HLEN,HELP_DIRECTORY) + IF (IER.NE.1) THEN + HELP_DIRECTORY = 'SYS$HELP:' + HLEN = 9 + ELSE IF (HELP_DIRECTORY(HLEN:HLEN).NE.':'.AND. + & HELP_DIRECTORY(HLEN:HLEN).NE.']') THEN + HELP_DIRECTORY = HELP_DIRECTORY(:HLEN)//':' + HLEN = HLEN + 1 + END IF + + LPROMPT = TRIM(COMMAND_PROMPT) + PROMPT = CHAR(10)//COMMAND_PROMPT(:LPROMPT)//' ' + LPROMPT = LPROMPT + 2 + + DO WHILE (1) + + IF (.NOT.DCL_COMMAND) THEN + CALL COMMAND_INPUT(IER) + ELSE + IF (INDEX(DCL_CMD,';').GT.0) THEN + INCMD = DCL_CMD(:INDEX(DCL_CMD,';')-1) + DCL_CMD = DCL_CMD(INDEX(DCL_CMD,';')+1:) + ELSE + INCMD = DCL_CMD + DCL_CMD = ' ' + END IF + IER = TRIM(INCMD) + END IF + + IF (IER.EQ.-2) THEN + IER = RMS$_EOF + ELSE IF (IER.LE.0) THEN + IER = %LOC(CLI$_NOCOMD) + ELSE + DO WHILE (IER.GT.0.AND.INCMD(:1).EQ.' ') + INCMD = INCMD(2:IER) + IER = IER - 1 + END DO + IF (IER.GT.0.AND.INCMD(:1).GE.'0'.AND.INCMD(:1).LE.'9') THEN + INCMD = 'READ '//INCMD + END IF + IER=CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS,LIB$GET_INPUT) + END IF + + IF (IER.EQ.RMS$_EOF) THEN + CALL EXIT ! If no command, exit + ELSE IF (IER.EQ.%LOC(CLI$_NOCOMD)) THEN ! If just RETURN entered + INCMD = ' ' ! Make sure there is none + LEN_P = 0 ! Indicate no parameter in command + IF (DIR_COUNT.GT.0) THEN ! If still more dir entries + CALL DIRECTORY(DIR_COUNT) ! continue outputting them + ELSE IF (INDEX_COUNT.GT.0) THEN + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (FOLDER_COUNT.GT.0) THEN ! If more folder entries + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! continue outputting them + ELSE ! Else try to read next bulletin + CALL READ_MSG(READ_COUNT,BULL_POINT+1) ! or finish old one + DIR_COUNT = 0 + FOLDER_COUNT = 0 + INDEX_COUNT = 0 + END IF + GO TO 100 ! Loop to read new command + ELSE IF (.NOT.IER) THEN ! If command has error + GO TO 100 ! ask for new command + END IF + + IER = MIN(INDEX(INCMD(:TRIM(INCMD)),' '),INDEX(INCMD,'/')) + IF (IER.GT.0) INCMD = ' '//INCMD(IER:) ! Save qualifiers + CALL CLI$GET_VALUE('$VERB',INCMD(:4)) ! Get user's command. + + IF (INCMD(:4).EQ.'BACK'.AND.DIR_COUNT.NE.0) THEN + DIR_COUNT = -1 + CALL DIRECTORY(DIR_COUNT) + INCMD = ' ' +C ELSE IF (INCMD(:4).EQ.'BACK'.AND.FOLDER_COUNT.NE.0) THEN +C FOLDER_COUNT = -1 +C CALL DIRECTORY_FOLDERS(FOLDER_COUNT) +C INCMD = ' ' + ELSE + DIR_COUNT = 0 ! Reinit display pointers + READ_COUNT = 0 + FOLDER_COUNT = 0 + INDEX_COUNT = 0 + END IF + + IF (READ_ONLY.AND.(INCMD(:3).EQ.'ADD'.OR.INCMD(:3).EQ.'DEL' + & .OR.INCMD(:3).EQ.'CHA'.OR.INCMD(:3).EQ.'REP')) THEN + ! FOLDER can only be read? + WRITE (6,'('' ERROR: Access to folder limited to reading.'')') + ELSE IF (INCMD(:3).EQ.'ADD') THEN ! ADD? + IF (REMOTE_SET.GE.3) THEN + INCMD = 'POST' + CALL RESPOND + ELSE + CALL ADD + END IF + ELSE IF (INCMD(:3).EQ.'ATT') THEN ! ATTACH? + CALL ATTACH + ELSE IF (INCMD(:4).EQ.'BACK') THEN ! BACK? + IF (BULL_POINT.LE.1) THEN + WRITE(6,1060) + ELSE + CALL READ_MSG(READ_COUNT,BULL_POINT-1) ! Try to read previous + END IF + ELSE IF (INCMD(:4).EQ.'CHAN') THEN ! CHANGE? + CALL REPLACE ! Replace old bulletin + ELSE IF (INCMD(:4).EQ.'COPY') THEN ! COPY? + CALL MOVE(.FALSE.) + ELSE IF (INCMD(:4).EQ.'CREA') THEN ! CREATE? + CALL CREATE_FOLDER ! Go create the folder + ELSE IF (INCMD(:4).EQ.'CURR') THEN ! CURRENT? + READ_COUNT = -1 ! Reread current message from beginning. + CALL READ_MSG(READ_COUNT,BULL_POINT) + ELSE IF (INCMD(:4).EQ.'DELE') THEN ! DELETE? + CALL DELETE_MSG ! Go delete bulletin + ELSE IF (INCMD(:4).EQ.'DIRE') THEN ! DIRECTORY? + IF (CLI$PRESENT('FOLDER').OR. ! /FOLDER specified? + & CLI$PRESENT('NEWS')) THEN ! or /NEWS? + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! Show all folders + ELSE IF (CLI$PRESENT('SELECT_FOLDER')) THEN! Folder specified? + CALL SELECT_FOLDER(.TRUE.,IER) ! Try to select folder + IF (IER) THEN ! If successful + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE + CALL DIRECTORY(DIR_COUNT) ! Show messages + END IF + ELSE IF (INCMD(:4).EQ.'FILE'.OR. + & INCMD(:4).EQ.'EXTR') THEN ! FILE? + CALL FILE ! Copy bulletin to file + ELSE IF (INCMD(:1).EQ.'E'.OR. + & INCMD(:4).EQ.'QUIT') THEN ! EXIT? + CALL EXIT ! Exit from program + ELSE IF (INCMD(:4).EQ.'FIRS') THEN ! FIRST? + READ_COUNT = -1 + BULL_READ = 1 + CALL READ_MSG(READ_COUNT,BULL_READ) + ELSE IF (INCMD(:4).EQ.'HELP') THEN ! HELP? + CALL HELP(HELP_DIRECTORY(:HLEN)//'BULL.HLB') ! Get help + ELSE IF (INCMD(:3).EQ.'IND') THEN ! INDEX? + INDEX_COUNT = 1 + CALL FULL_DIR(INDEX_COUNT) + ELSE IF (INCMD(:4).EQ.'LAST') THEN ! LAST? + READ_COUNT = -1 + BULL_READ = 99999 + CALL READ_MSG(READ_COUNT,BULL_READ) + ELSE IF (INCMD(:4).EQ.'MARK') THEN ! MARK? + CALL TAG(.TRUE.,1) + ELSE IF (INCMD(:4).EQ.'MAIL'.OR. + & INCMD(:4).EQ.'FORW') THEN ! MAIL? + CALL MAIL + ELSE IF (INCMD(:3).EQ.'MOD') THEN ! MODIFY? + CALL MODIFY_FOLDER + ELSE IF (INCMD(:4).EQ.'MOVE') THEN ! MOVE? + CALL MOVE(.TRUE.) + ELSE IF (INCMD(:4).EQ.'NEWS') THEN ! NEWS + CALL DIRECTORY_FOLDERS(FOLDER_COUNT) ! Show new folders + ELSE IF (INCMD(:4).EQ.'NEXT'.OR.INCMD(:1).EQ.'N') THEN ! NEXT? + CALL READ_MSG(READ_COUNT,BULL_POINT+1) ! Read next bulletin + ELSE IF (INCMD(:4).EQ.'POST') THEN ! POST? + CALL RESPOND + ELSE IF (INCMD(:4).EQ.'PRIN') THEN ! PRINT? + CALL PRINT(0,.TRUE.) ! Printout bulletin + ELSE IF (INCMD(:4).EQ.'READ') THEN ! READ? + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Bulletin specified? + DECODE(LEN_P,'(I)',BULL_PARAMETER) BULL_READ ! Yes + READ_COUNT = -1 + CALL READ_MSG(READ_COUNT,BULL_READ) + ELSE + CALL READ_MSG(READ_COUNT,BULL_POINT+1) + END IF + ELSE IF (INCMD(:3).EQ.'REM') THEN ! REMOVE? + CALL REMOVE_FOLDER + ELSE IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + IF (REMOTE_SET.GE.3.OR. + & INDEX(FOLDER_DESCRIP,'<').GT.0) THEN + CALL RESPOND + ELSE + CALL REPLY + END IF + ELSE IF (INCMD(:3).EQ.'RES') THEN ! RESPOND? + CALL RESPOND + ELSE IF (INCMD(:3).EQ.'SEA') THEN ! SEARCH? + CALL SEARCH(READ_COUNT) + ELSE IF (INCMD(:3).EQ.'SEE') THEN ! SEEN? + CALL TAG(.TRUE.,2) + ELSE IF (INCMD(:3).EQ.'SEL') THEN ! SELECT? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (INCMD(:3).EQ.'SET') THEN ! SET? + CALL CLI$GET_VALUE('SET_PARAM1',BULL_PARAMETER) + IF (BULL_PARAMETER(:1).EQ.'F') THEN ! SET FOLDER? + CALL SELECT_FOLDER(.TRUE.,IER) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRI') THEN ! SET PRIVS? + CALL SET_PRIV + ELSE IF (BULL_PARAMETER(:2).EQ.'PA') THEN ! SET PAGE? + PAGING = .TRUE. + WRITE (6,'('' PAGE has been set.'')') + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SET KEYPAD? + CALL SET_KEYPAD + ELSE IF (BULL_PARAMETER(:3).EQ.'NOK') THEN ! SET NOKEYPAD? + CALL SET_NOKEYPAD + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPA') THEN ! SET NOPAGE? + PAGING = .FALSE. + WRITE (6,'('' NOPAGE has been set.'')') + ELSE IF (FOLDER_NUMBER.EQ.-1.AND.REMOTE_SET.EQ.1) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + ELSE IF (BULL_PARAMETER(:2).EQ.'SY') THEN ! SET SYSTEM? + CALL SET_SYSTEM(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOSY') THEN ! SET NOSYSTEM? + CALL SET_SYSTEM(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'BB') THEN ! SET BBOARD? + CALL SET_BBOARD(.TRUE.) + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBB') THEN ! SET NOBBOARD? + CALL SET_BBOARD(.FALSE.) + ELSE IF (BULL_PARAMETER(:2).EQ.'DU') THEN ! SET DUMP? + CALL SET_FOLDER_FLAG(.TRUE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODU') THEN ! SET NODUMP? + CALL SET_FOLDER_FLAG(.FALSE.,1,'DUMP') + ELSE IF (BULL_PARAMETER(:2).EQ.'ST') THEN ! SET STRIP? + CALL SET_FOLDER_FLAG(.TRUE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOST') THEN ! SET NOSTRIP? + CALL SET_FOLDER_FLAG(.FALSE.,4,'STRIP') + ELSE IF (BULL_PARAMETER(:2).EQ.'DI') THEN ! SET DIGEST? + CALL SET_FOLDER_FLAG(.TRUE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:4).EQ.'NODI') THEN ! SET NODIGEST? + CALL SET_FOLDER_FLAG(.FALSE.,5,'DIGEST') + ELSE IF (BULL_PARAMETER(:2).EQ.'AL') THEN ! SET ALWAYS? + CALL SET_FOLDER_FLAG(.TRUE.,7,'ALWAYS') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOAL') THEN ! SET NOALWAYS? + CALL SET_FOLDER_FLAG(.FALSE.,7,'ALWAYS') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOTI') THEN ! SET NOTIFY? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(1,-1,-1) + ELSE + CALL SET_USER_FLAG(1,-1,-1) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'E') THEN ! SET EXPIRE? + IER = CLI$GET_VALUE('EXPIRATION',BULL_PARAMETER,LEN_P) + IF (LEN_P.LE.3) THEN + READ (BULL_PARAMETER,'(I)') LIMIT + CALL SET_FOLDER_EXPIRE_LIMIT(LIMIT) + ELSE + WRITE (6,'('' ERROR: Invalid expiration specified.'')') + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NODE') THEN ! SET NODE? + CALL SET_NODE(.TRUE.) + ELSE IF (BULL_PARAMETER(:6).EQ.'NONODE') THEN ! SET NONODE? + CALL SET_NODE(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOE') THEN ! SET NOEXPIRE? + CALL SET_FOLDER_EXPIRE_LIMIT(0) + ELSE IF (BULL_PARAMETER(:5).EQ.'NONOT') THEN ! SET NONOTIFY? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(0,-1,-1) + ELSE + CALL SET_USER_FLAG(0,-1,-1) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'S') THEN ! SET SHOWNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,1) + ELSE + CALL SET_USER_FLAG(-1,0,1) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOS') THEN ! SET NOSHOWNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE + CALL SET_USER_FLAG(-1,0,0) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'R') THEN ! SET READNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,1,0) + ELSE + CALL SET_USER_FLAG(-1,1,0) + END IF + ELSE IF (BULL_PARAMETER(:3).EQ.'NOR') THEN ! SET NOREADNEW? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE + CALL SET_USER_FLAG(-1,0,0) + END IF + ELSE IF (BULL_PARAMETER(:2).EQ.'BR') THEN ! SET BRIEF? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,1,1) + ELSE + CALL SET_USER_FLAG(-1,1,1) + END IF + ELSE IF (BULL_PARAMETER(:4).EQ.'NOBR') THEN ! SET NOBRIEF? + IF (CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('ALL').OR. + & CLI$PRESENT('PERMANENT').OR.CLI$PRESENT('NOPERMANENT')) + & THEN + CALL SET_FOLDER_DEFAULT(-1,0,0) + ELSE + CALL SET_USER_FLAG(-1,0,0) + END IF + ELSE IF (BULL_PARAMETER(:1).EQ.'A') THEN ! SET ACCESS? + CALL SET_ACCESS(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOA') THEN ! SET NOACCESS? + CALL SET_ACCESS(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'C') THEN ! SET CONTINUOUS_BRIEF + CALL SET_BRIEF_CONTINUOUS(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOC') THEN ! SET NOCONTINUOUS_BRIEF + CALL SET_BRIEF_CONTINUOUS(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'G') THEN ! SET GENERIC? + CALL SET_GENERIC(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOG') THEN ! SET NOGENERIC? + CALL SET_GENERIC(.FALSE.) + ELSE IF (BULL_PARAMETER(:1).EQ.'L') THEN ! SET LOGIN? + CALL SET_LOGIN(.TRUE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'NOL') THEN ! SET NOLOGIN? + CALL SET_LOGIN(.FALSE.) + ELSE IF (BULL_PARAMETER(:3).EQ.'PRO') THEN ! SET PROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.FALSE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:4).EQ.'NOPR') THEN ! SET NOPROMPT_EXPIRE? + CALL SET_FOLDER_FLAG(.TRUE.,3,'PROMPT_EXPIRE') + ELSE IF (BULL_PARAMETER(:3).EQ.'DEF') THEN ! SET DEFAULT_EXPIRE? + CALL SET_DEFAULT_EXPIRE + END IF + ELSE IF (INCMD(:4).EQ.'SHOW') THEN ! SHOW? + CALL CLI$GET_VALUE('SHOW_PARAM1',BULL_PARAMETER,LEN_P) + IF (BULL_PARAMETER(:2).EQ.'FL') THEN ! SHOW FLAGS? + CALL SHOW_FLAGS + ELSE IF (BULL_PARAMETER(:2).EQ.'FO') THEN ! SHOW FOLDER? + CALL SHOW_FOLDER + ELSE IF (BULL_PARAMETER(:1).EQ.'K') THEN ! SHOW KEYPAD + CALL SHOW_KEYPAD(HELP_DIRECTORY(:HLEN)//'BULL.HLB') + ELSE IF (BULL_PARAMETER(:1).EQ.'N') THEN ! SHOW NEW? + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + SAVE_FOLDER = FOLDER + CALL NEW_MESSAGE_NOTIFICATION + FOLDER1 = SAVE_FOLDER + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE IF (BULL_PARAMETER(:1).EQ.'P') THEN ! SHOW PRIVILEGES? + CALL SHOW_PRIV + ELSE IF (BULL_PARAMETER(:1).EQ.'U') THEN ! SHOW USER? + CALL SHOW_USER + ELSE IF (BULL_PARAMETER(:1).EQ.'V') THEN ! SHOW VERSION? + CALL SHOW_VERSION + END IF + ELSE IF (INCMD(:4).EQ.'SPAW') THEN ! SPAWN command? + CALL SPAWN_PROCESS + ELSE IF (INCMD(:3).EQ.'SUB') THEN ! SUBSCRIBE command? + CALL SUBSCRIBE + ELSE IF (INCMD(:4).EQ.'UNDE') THEN ! UNDELETE? + CALL UNDELETE + ELSE IF (INCMD(:3).EQ.'UNM') THEN ! UNMARK? + CALL TAG(.FALSE.,1) + ELSE IF (INCMD(:4).EQ.'UNSE') THEN ! UNSEEN? + CALL TAG(.FALSE.,2) + ELSE IF (INCMD(:4).EQ.'UNSU') THEN ! UNSUBSCRIBE command? + CALL UNSUBSCRIBE + END IF + +100 CONTINUE + + IF (DCL_COMMAND.AND.TRIM(DCL_CMD).EQ.0) CALL EXIT + + END DO + +1010 FORMAT(Q,A) +1060 FORMAT(' ERROR: There are no more preceding messages.') + + END + + + + SUBROUTINE COMMAND_INPUT(IER) + + IMPLICIT INTEGER (A - Z) + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /PROMPT_PROMPT/ PROMPT,LPROMPT + CHARACTER*42 PROMPT + + CALL GET_INPUT_PROMPT(INCMD,IER,PROMPT(:LPROMPT)) + + RETURN + + END + + + + + + SUBROUTINE ADD +C +C SUBROUTINE ADD +C +C FUNCTION: Adds bulletin to bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /INDESCRIP/ INDESCRIP + CHARACTER*(LINE_LENGTH) INDESCRIP + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + character*40 PERSUSR + logical Perr + CHARACTER INEXDATE*11,INEXTIME*11 + + CHARACTER INLINE*80,OLD_FOLDER*25,LOCAL_NODE*8 + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + EDITIT = (CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)) + + IF (CLI$PRESENT('EXTRACT').AND..NOT.EDITIT) THEN + WRITE (6,'('' ERROR: Cannot extract text without /EDIT.'')') + RETURN + END IF + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + ALLOW = SETPRV_PRIV() + + OLD_FOLDER_NUMBER = FOLDER_NUMBER + OLD_FOLDER = FOLDER + + LEN_P = 0 + + IF (CLI$PRESENT('EXTRACT')) THEN + BULL_PARAMETER = 'SYS$LOGIN:BULL.SCR' + LEN_P = TRIM(BULL_PARAMETER) + OPEN(UNIT=3,FILE=BULL_PARAMETER(:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH, + & STATUS='NEW',CARRIAGECONTROL='LIST',FORM='FORMATTED') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + +90 CALL CLOSE_BULLFIL + END IF + + IF (CLI$PRESENT('FILESPEC')) THEN + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + CALL DISABLE_PRIVS + IF (.NOT.CLI$PRESENT('EXTRACT')) THEN + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD', + & READONLY,SHARED,ERR=920,FORM='FORMATTED') + ELSE + OPEN (UNIT=4,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD', + & READONLY,SHARED,ERR=920,FORM='FORMATTED') + IER = 0 + ICOUNT = 0 + DO WHILE (IER.EQ.0) + READ (4,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.EQ.0) THEN + IF (ICOUNT.EQ.0) WRITE (3,'(A)') ' ' + ICOUNT = ICOUNT + 1 + WRITE (3,'(A)') INPUT(:ILEN) + END IF + END DO + CLOSE (UNIT=4) + BULL_PARAMETER = 'SYS$LOGIN:BULL.SCR' + LEN_P = TRIM(BULL_PARAMETER) + END IF + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + END IF + + SELECT_FOLDERS = .FALSE. + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL GET_FOLDER_INFO(IER) + IF (.NOT.IER) GO TO 910 + SELECT_FOLDERS = .TRUE. + ELSE + NODE_NUM = 1 + NODES(1) = OLD_FOLDER + END IF + + IF (FOLDER_NUMBER.GT.0.AND. ! If folder set and + & CLI$PRESENT('NODES')) THEN ! Decnet nodes specified? + WRITE (6,'('' ERROR: /NODES cannot be used with folder set.'')') + GO TO 910 + END IF + + IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0.AND. + & (CLI$PRESENT('SYSTEM').OR. ! Is /SYSTEM switch present? + & CLI$PRESENT('BROADCAST').OR. ! Is /BROADCAST swtich present? + & CLI$PRESENT('SHUTDOWN'))) THEN ! Is /SHUTDOWN switch present? + WRITE (6,'('' ERROR: Folder is not a SYSTEM folder.'')') + GO TO 910 + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN ! Is /SYSTEM switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1070) ! Tell user + GO TO 910 ! and abort + END IF + SYSTEM = 1 ! Set system bit + ELSE + SYSTEM = 0 ! Clear system bit + END IF + + IF (CLI$PRESENT('BROADCAST')) THEN ! Is /BROADCAST switch present? + IF (.NOT.(ALLOW.OR.OPER_PRIV())) THEN ! If no privileges + WRITE(ERROR_UNIT,1080) ! Tell user + GO TO 910 ! and abort + ELSE IF (CLI$PRESENT('CLUSTER')) THEN + SYSTEM = SYSTEM.OR.8 + END IF + END IF + + IF (CLI$PRESENT('PERMANENT')) THEN ! Is /PERMANENT switch present? + IF (F_EXPIRE_LIMIT.GT.0.AND..NOT. ! Expiration limit present + & FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE(ERROR_UNIT,1083) + GO TO 910 + ELSE + SYSTEM = SYSTEM.OR.2 ! Set permanent bit + INEXDATE = '5-NOV-2000' + INEXTIME = '00:00:00.00' + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN ! Is /SHUTDOWN switch present? + IF (.NOT.ALLOW) THEN ! If no privileges + WRITE(ERROR_UNIT,1082) ! Tell user + GO TO 910 ! and abort + ELSE + IER = CLI$GET_VALUE('SHUTDOWN',INLINE) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (REMOTE_SET) THEN ! Can't specify node name if + WRITE (6,1090) ! remote folder, as no code + GO TO 910 ! present to send the name. + END IF + CALL GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,INLINE) + IF (NODE_AREA.EQ.0) GO TO 910 ! Invalid node name + ELSE + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + END IF + SYSTEM = SYSTEM.OR.4 ! Set shutdown bit + INEXDATE = '5-NOV-2000' + WRITE (INEXTIME,'(I4)') NODE_NUMBER + WRITE (INEXTIME(7:),'(I4)') NODE_AREA + DO I=1,11 + IF (INEXTIME(I:I).EQ.' ') INEXTIME(I:I) = '0' + END DO + INEXTIME = INEXTIME(1:2)//':'//INEXTIME(3:4)//':'// + & INEXTIME(7:8)//'.'//INEXTIME(9:10) + END IF + END IF + + SELECT_NODES = .FALSE. + IF (CLI$PRESENT('NODES')) THEN + CALL GET_NODE_INFO + IF (NODE_ERROR) GO TO 940 + SELECT_NODES = .TRUE. + END IF + + IF ((SYSTEM.AND.7).LE.1) THEN ! Not permanent or shutdown + CALL GET_EXPIRED(INPUT,IER) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + + IF (INCMD(:3).EQ.'REP') THEN ! REPLY? + LENDES = TRIM(INDESCRIP) ! filled in by main subroutine + ELSE IF (CLI$PRESENT('SUBJECT')) THEN ! /SUBJECT specified + CALL CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + ELSE + WRITE(6,1050) ! Request header for bulletin + CALL GET_LINE(INDESCRIP,LENDES) ! Get input line + IF (LENDES.LE.0) GO TO 910 + END IF + + LENDES = MIN(LEN(INDESCRIP)-6,LENDES) ! Make room for "Subj: " + +C +C If file specified in ADD command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + IF (EDITIT.AND..NOT.DECNET_PROC) THEN ! If /EDIT specified + IF (LEN_P.EQ.0) THEN ! If no file param specified + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=910,FORM='FORMATTED') + LEN_P = 1 + ELSE + CLOSE (UNIT=3) + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + IF (CLI$PRESENT('EXTRACT')) THEN + CONTEXT = 0 + CALL LIB$FIND_FILE('SYS$LOGIN:BULL.SCR',INPUT,CONTEXT) + VERSION = INDEX(INPUT,';') + 1 + IF (INPUT(VERSION:VERSION).EQ.'1') THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + END IF + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=910,FORM='FORMATTED') + END IF + END IF + + ICOUNT = 0 ! Line count for bulletin + + END = 0 + BLENGTH = 35 + IF (CLI$PRESENT('BELL')) BLENGTH = 37 + IF (LEN_P.GT.0) THEN ! If file param in ADD command + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + ICOUNT = ICOUNT + 1 + MIN(ILEN,80) + BLENGTH = BLENGTH + ILEN - 1 + 2 + IF (ILEN.EQ.0) ICOUNT = ICOUNT + 1! COPY_BULL writes line with + END DO ! 1 space for blank line + ELSE ! If no input file + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) ! Temp file to save message + WRITE (6,1000) ! Request input from terminal + ILEN = LINE_LENGTH + 1 ! Length of input line + ICOUNT = 0 ! Character count counter + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Input line too long + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput:'')') LINE_LENGTH + ELSE IF (ILEN.GE.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN ! Update counter + BLENGTH = BLENGTH + ILEN - 1 + 2 + WRITE(3,2010) INPUT(:ILEN) ! Save line in scratch file + END IF + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + REWIND (UNIT=3) + + BRDCST = .FALSE. + + IF (CLI$PRESENT('BROADCAST').AND.BLENGTH.GT.82*12+2) THEN + WRITE (6,'('' Message is too long for broadcasting.'', + & '' A truncated message will be broadcast.'')') + CALL GET_INPUT_PROMPT(INPUT,ILEN, + & 'Type C to continue, A to only ADD message, or Q to Quit: ') + IF (STREQ(INPUT(:1),'Q')) THEN + GO TO 910 + ELSE IF (STREQ(INPUT(:1),'A')) THEN + BRDCST = .TRUE. + END IF + END IF + + IF (SELECT_NODES.AND.NODE_NUM.GT.0) THEN + INLINE = 'ADD' + IF (CLI$PRESENT('SYSTEM')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SYSTEM' + IF (CLI$PRESENT('BROADCAST').AND..NOT.BRDCST) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BROADCAST' + IF (CLI$PRESENT('PERMANENT')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/PERMANENT' + IF (CLI$PRESENT('SHUTDOWN')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/SHUTDOWN' + IF (CLI$PRESENT('BELL')) + & INLINE = INLINE(:STR$POSITION(INLINE,' ')-1)//'/BELL' + + LEN_INLINE = STR$POSITION(INLINE,' ') - 1 + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + INLINE = INLINE(:LEN_INLINE) + + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + IF ((SYSTEM.AND.7).LE.1) + ! If not permanent or shutdown specify date + & WRITE (POINT_NODE+9,'(A)',ERR=940) INEXDATE//' '//INEXTIME + WRITE (POINT_NODE+9,'(A)',ERR=940) INDESCRIP(:LENDES) + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + ILEN = MIN(ILEN,LINE_LENGTH) + IF (IER.EQ.0) THEN + WRITE (POINT_NODE+9,'(A)',ERR=940) INPUT(:ILEN) + END IF + END DO + WRITE (POINT_NODE+9,'(A)',ERR=940) CHAR(26) + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INPUT + IF (INPUT.EQ.'END') THEN + WRITE (6,'('' Message successfully sent to node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while sending message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INPUT(:80) + GO TO 940 + END IF + REWIND (UNIT=3) + END DO + END IF + + IF (SELECT_NODES.AND..NOT.LOCAL_NODE_FOUND) GO TO 95 + ! Exit if local node not specified. + + IF (.NOT.SELECT_FOLDERS) THEN + NODE_NUM = 1 ! No folders specified so just + NODES(1) = FOLDER ! add to select folder + END IF + + IER = SYS_TRNLNM('SYS$NODE',LOCAL_NODE) + LNODE = TRIM(LOCAL_NODE) + LUSER = TRIM(USERNAME) + persusr=' ' + perr=lib$sys_trnlog('SYS$USERNAME',puser,persusr) + if(.not.Perr) persusr = username +C if a logical sys$username exists it is used in the FROM addres +C of the added message. This makes it possible to tell who was +C actually sending a message when logged into a common account +C somewhere (assuming the login uses the sys$rem_id and sys$rem_node +C logicals to construct the sys$username logical) +C gce, 9/26/1991 +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + DO I = 1,NODE_NUM + + IF (FOLDER.NE.NODES(I)) THEN + FOLDER_NUMBER = -1 + FOLDER1 = NODES(I) + CALL SELECT_FOLDER(.FALSE.,IER) + ELSE + IER = 1 + END IF + + IF (IER) THEN + CALL OPEN_BULLDIR ! Prepare to add dir entry + + DESCRIP=INDESCRIP(:LENDES) ! Description header + EXDATE=INEXDATE ! Expiration date + EXTIME=INEXTIME + FROM = USERNAME ! Username + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + REWIND (UNIT=3) + OBLOCK = NBLOCK+1 + CALL STORE_BULL(LNODE+PUSER+6,'From: '// + & LOCAL_NODE(:LNODE)//PersUsr(:PUSER),OBLOCK) + IF (LENDES.GT.LEN(DESCRIP)) THEN + CALL STORE_BULL(LENDES+6, + & 'Subj: '//INDESCRIP(:LENDES),OBLOCK) + END IF + CALL COPY_BULL(3,1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) GO TO 930 ! Error in creating bulletin + LENGTH = OCOUNT - (NBLOCK+1) + 1 +C +C Broadcast the bulletin if requested. +C + IF (.NOT.BRDCST.AND.CLI$PRESENT('BROADCAST').AND. + & (.NOT.REMOTE_SET.OR.FOLDER_NUMBER.GT.0)) THEN + CALL GET_BROADCAST_MESSAGE(CLI$PRESENT('BELL')) + BRDCST = .TRUE. + IF (.NOT.CLI$PRESENT('LOCAL')) THEN + CALL BROADCAST_ALL_NODES(CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER')) + END IF +C +C If the folder is remote, and local node is not the node which BULLCP is +C on, don't broadcast, as it will be broadcasted by BULLCP. The remote +C node will distribute the broadcast to nodes that are running BULLCP, +C but not if the node that originated the message matches. However, it +C has no way of knowing that the originating node is in the same cluster +C as that of the BULLCP node. +C + IF ((REMOTE_SET.AND.LOCAL_NODE(:LNODE-2).EQ.NODENAME) + & .OR.CLI$PRESENT('LOCAL').OR..NOT.REMOTE_SET) + & CALL BROADCAST( + & CLI$PRESENT('ALL'),CLI$PRESENT('CLUSTER')) + END IF + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + CALL ADD_ENTRY ! Add the new directory entry + + IF (FOLDER_NUMBER.GE.0) THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + CALL UPDATE_FOLDER ! Update info in folder file +C +C If user is adding message, an no new messages, update last read time for +C folder, so user is not alerted of new message which is owned by user. +C + IF (DIFF.GE.0) THEN + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + END IF + + CALL CLOSE_BULLDIR ! Totally finished with add + ELSE + WRITE (6,'('' ERROR: Unable to add message to '',A)') + & NODES(I) + END IF + END DO + +95 CLOSE (UNIT=3) ! Close the input file + IF (DECNET_PROC) WRITE(5,'(''END'')') ! DECNET operation worked + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + DO I=10,NODE_NUM+9 + CLOSE (UNIT=I) + END DO + + IF (FOLDER_NUMBER.NE.OLD_FOLDER_NUMBER) THEN + FOLDER_NUMBER = OLD_FOLDER_NUMBER + FOLDER1 = OLD_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + + IF (CLI$PRESENT('EXTRACT')) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + RETURN + +910 WRITE(ERROR_UNIT,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(ERROR_UNIT,1020) + CALL ENABLE_PRIVS + GOTO 100 + +930 WRITE (ERROR_UNIT,1025) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + +940 WRITE (6,1015) NODES(POINT_NODE) + WRITE (6,1018) + CLOSE (UNIT=3) + GO TO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1010 FORMAT (' No message was added.') +1015 FORMAT (' ERROR: Unable to reach node ',A) +1018 FORMAT (' Try using /FOLDER instead of /NODE.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1025 FORMAT (' ERROR: Unable to add message to file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1070 FORMAT (' ERROR: SETPRV privileges are needed for system + & messages.') +1080 FORMAT (' ERROR: SETPRV privileges are needed to broadcast + & messages.') +1082 FORMAT (' ERROR: SETPRV privileges are needed to shutdown + & messages.') +1083 FORMAT (' ERROR: Folder has expiration limit.') +1090 FORMAT (' ERROR: Nodename cannot be specified for shutdown + & if folder is remote.') +2010 FORMAT(A) +2020 FORMAT(1X,A) + + END + + + SUBROUTINE SUBTIME(BTIM,DAYS_BEFORE_TODAY,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER DAYS_BEFORE_TODAY*(*),TODAY_DATE*23 + + INTEGER BTIM(2),TODAY_BTIM(2) + + IER = SYS$BINTIM(DAYS_BEFORE_TODAY,BTIM) + IF (.NOT.IER) RETURN + + BTIM(1) = -BTIM(1) ! Convert to negative delta time + BTIM(2) = -BTIM(2)-1 + + IER = SYS$ASCTIM(TLEN,TODAY_DATE,,) + CALL SYS$BINTIM(TODAY_DATE(:TLEN),TODAY_BTIM) + + CALL LIB$SUBX(TODAY_BTIM,BTIM,BTIM) + + RETURN + END + + + + SUBROUTINE BROADCAST_ALL_NODES(ALL,CLUSTER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + COMMON /BROAD_MESSAGE/ BMESSAGE,BLENGTH + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER LOCALNODE*8,RESPONSE*1 + + IF (.NOT.TEST_BULLCP().OR.REMOTE_SET) RETURN + + CALL OPEN_BULLUSER_SHARED + + REMOTE_FOUND = .FALSE. + TEMP_USER = ':' + + DO WHILE (.NOT.REMOTE_FOUND) + DO WHILE (REC_LOCK(IER)) + READ (4,KEYGT=TEMP_USER,IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM,NEW_FLAG + END DO + IF (TEMP_USER(:1).NE.':') THEN + CALL CLOSE(4) + RETURN + END IF + REMOTE_FOUND = TEST2(NEW_FLAG,FOLDER_NUMBER) + END DO + + CALL CLOSE (4) + +100 OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=NODENAME(:TRIM(NODENAME))//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IER = 0 + I = 1 + DO WHILE (IER.EQ.0.AND.I.LT.BLENGTH) + WRITE (17,'(4A)',IOSTAT=IER) + & 15,-1,I,BMESSAGE(I:MIN(BLENGTH,I+127)) + I = I + 128 + END DO + IF (IER.EQ.0) WRITE (17,'(7A)',IOSTAT=IER) + & 15,BLENGTH,I,ALL,CLUSTER,FOLDER_NUMBER,FOLDER + ELSE + WRITE (6,'('' BULLCP not responding to request to'', + & '' broadcast to other nodes.'')') + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Want to try again? (Y/N with Y as default): ') + IF (RESPONSE.NE.'n'.AND.RESPONSE.NE.'N') THEN + WRITE (6,'('' Trying again...'')') + GO TO 100 + ELSE + WRITE (6,'('' Broadcast aborting. '', + & ''Continuing with message addition.'')') + END IF + END IF + + CLOSE (UNIT=17) + + RETURN + END + + + + + INTEGER FUNCTION ERROR_TRAP + + ERROR_TRAP = 1 + + RETURN + END + + + + SUBROUTINE REPLY + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /INDESCRIP/ INDESCRIP + CHARACTER*(LINE_LENGTH) INDESCRIP + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + INDESCRIP = INPUT(7:) + ELSE + INDESCRIP = DESCRIP + END IF + + CALL CLOSE_BULLFIL + + CALL CLOSE_BULLDIR + + WRITE (6,'('' Adding REPLY message with the subject:'')') + IF (STREQ(INDESCRIP(:3),'RE:')) THEN + INDESCRIP = 'RE:'//INDESCRIP(4:) + ELSE + INDESCRIP = 'RE: '//INDESCRIP + END IF + WRITE (6,'(1X,A)') INDESCRIP(:TRIM(INDESCRIP)) + + CALL ADD + + RETURN + END + + + + + SUBROUTINE CRELNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PSLDEF)' + + INCLUDE '($LNMDEF)' + + CHARACTER*(*) INPUT,OUTPUT + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT)) + CALL END_ITMLST(CRELNM_ITMLST) + + IER = SYS$CRELNM(,'LNM$PROCESS',INPUT,PSL$C_USER, + & %VAL(CRELNM_ITMLST)) + + RETURN + END + + + + SUBROUTINE GETPRIV +C +C SUBROUTINE GETPRIV +C +C FUNCTION: +C To get process privileges. +C OUTPUTS: +C PROCPRIV - Returned privileges +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /REALPROC/ REALPROCPRIV(2) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(8,JPI$_PROCPRIV,%LOC(PROCPRIV)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + REALPROCPRIV(1) = PROCPRIV(1) + REALPROCPRIV(2) = PROCPRIV(2) + + RETURN + END + + + + + LOGICAL FUNCTION SETPRV_PRIV + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + DATA NEEDPRIV/0,0/ + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + IF (NEEDPRIV(1).EQ.0.AND.NEEDPRIV(2).EQ.0) THEN + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + CALL CLOSE_BULLUSER + NEEDPRIV(1) = USERPRIV(1) + NEEDPRIV(2) = USERPRIV(2) + END IF + + IF ((PROCPRIV(1).AND.NEEDPRIV(1)).NE.0.OR. + & (PROCPRIV(2).AND.NEEDPRIV(2)).NE.0) THEN + SETPRV_PRIV = .TRUE. + ELSE + SETPRV_PRIV = .FALSE. + END IF + + RETURN + END + + + + LOGICAL FUNCTION OPER_PRIV + IMPLICIT INTEGER (A-Z) + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + INCLUDE '($PRVDEF)' + OPER_PRIV = BTEST(PROCPRIV(1),PRV$V_OPER) + RETURN + END + + + + SUBROUTINE GETUSER(USERNAME) +C +C SUBROUTINE GETUSER +C +C FUNCTION: +C To get username of present process. +C OUTPUTS: +C USERNAME - Username owner of present process. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + CHARACTER*(*) USERNAME ! Limit is 12 characters + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info + + RETURN + END + + + + + LOGICAL FUNCTION CAPTIVE() + + IMPLICIT INTEGER (A - Z) + + INCLUDE '($UAIDEF)' + + INCLUDE 'BULLUSER.INC' + + DATA READ_UAI/.FALSE./ + + TYPE = 1 + + IF (.NOT.READ_UAI) THEN + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL END_ITMLST(GETUAI_ITMLST) + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) + READ_UAI = .TRUE. + END IF + + CAPTIVE = ((FLAGS.AND.(UAI$M_CAPTIVE.OR.UAI$M_RESTRICTED)).NE.0 + & .AND.1).OR.ISHFT(((FLAGS.AND.UAI$M_NOMAIL).NE.0).AND.1,1) + + RETURN + END + + + + + SUBROUTINE SPAWN_PROCESS + + IMPLICIT INTEGER (A - Z) + + COMMON /KEYPAD/ KEYPAD_MODE + + CHARACTER*255 COMMAND + + IF (CAPTIVE()) THEN + WRITE (6,'('' ERROR: SPAWN not allowed from CAPTIVE account.'')') + RETURN + END IF + + CALL DISABLE_PRIVS + + SAVE_KEYPAD_MODE = KEYPAD_MODE + IF (KEYPAD_MODE.EQ.0) CALL SET_KEYPAD + + IF (CLI$PRESENT('COMMAND')) THEN + CALL CLI$GET_VALUE('COMMAND',COMMAND,CLEN) + COMMAND = '$'//COMMAND(:CLEN) + CALL LIB$SPAWN(COMMAND(:CLEN+1)) + ELSE + CALL LIB$SPAWN() + END IF + + IF (SAVE_KEYPAD_MODE.EQ.0) CALL SET_NOKEYPAD + + CALL ENABLE_PRIVS + + RETURN + END + + + SUBROUTINE ATTACH + + IMPLICIT INTEGER (A - Z) + + COMMON /KEYPAD/ KEYPAD_MODE + + COMMON /TERM_CHAN/ TERM_CHAN + + INCLUDE '($JPIDEF)' + + CHARACTER*15 PROCESS + + IF (CLI$PRESENT('PROCESS')) THEN + CALL CLI$GET_VALUE('PROCESS',PROCESS,PLEN) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,JPI$_PID,%LOC(PROCESS_ID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,PROCESS(:PLEN),%VAL(GETJPI_ITMLST),,,,) + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,JPI$_OWNER,%LOC(PROCESS_ID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) + END IF + + IER = SYS$CANCEL(%VAL(TERM_CHAN)) + + SAVE_KEYPAD_MODE = KEYPAD_MODE + IF (KEYPAD_MODE.EQ.0) CALL SET_KEYPAD + + IF (IER) IER = LIB$ATTACH(PROCESS_ID) + IF (.NOT.IER) CALL SYS_GETMSG(IER) + + IF (SAVE_KEYPAD_MODE.EQ.0) CALL SET_NOKEYPAD + + RETURN + END + + + + + + SUBROUTINE GET_BROADCAST_MESSAGE(RING_BELL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($BRKDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + +C +C The largest message that can be broadcasted is dependent on system +C and user quotas. The following limit is 12 lines of ( 80 characters + +C CR/LF ) + 2 bells. This should be more than enough room, as broadcasts +C shouldn't be too large anyway. +C + + PARAMETER CR=CHAR(13),LF=CHAR(10),BELL=CHAR(7) + + PARAMETER BRDCST_LIMIT = 82*12 + 2 + CHARACTER*(BRDCST_LIMIT) BROAD + + COMMON /BROAD_MESSAGE/ BROAD,BLENGTH + + IF (RING_BELL) THEN ! Include BELL in message? + BROAD(:36) = ! Say who the bulletin is from + & BELL//BELL//CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 37 ! Start adding next line here + ELSE + BROAD(:34) = ! Say who the bulletin is from + & CR//LF//LF//'NEW BULLETIN FROM: '//FROM + BLENGTH = 35 ! Start adding next line here + END IF + + IF (REMOTE_SET) REWIND (UNIT=3) + + END = 0 + ILEN = LINE_LENGTH + 1 + I = 0 + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (REMOTE_SET) THEN + READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.NE.0) RETURN + ELSE + CALL GET_BULL_LINE(NBLOCK+1,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0) I = I + 1 + IF (ILEN.GT.0.AND.(I.GT.2.OR.(INPUT(:6).NE.'From: '.AND. + & INPUT(:6).NE.'Subj: '))) THEN + END = BLENGTH + ILEN - 1 + 2 ! Check how long string will be + IF (END.GT.BRDCST_LIMIT) RETURN ! String too long? + BROAD(BLENGTH:END) = CR//LF//INPUT(:ILEN)! Else add new input + BLENGTH = END + 1 ! Reset pointer + END IF + END DO + + RETURN + + ENTRY BROADCAST(ALL,CLUSTER) + + CALL SYS$SETRWM(%VAL(1)) ! Don't wait if can't broadcast + + IF (ALL) THEN ! Should we broadcast to ALL? + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLTERMS),,,,,,,) + END IF + ELSE ! Else just broadcast to users. + IF (CLUSTER) THEN + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,%VAL(BRK$M_CLUSTER),,,,) + ELSE + CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, + & %VAL(BRK$C_ALLUSERS),,,,,,,) + END IF + END IF + + CALL SYS$SETRWM(%VAL(0)) + + RETURN + END + + + SUBROUTINE GET_FOLDER_INFO(IER) +C +C SUBROUTINE GET_FOLDER_INFO +C +C FUNCTION: Obtains & verifies folder names from command line. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + CHARACTER NODE_TEMP*256 + + NODE_NUM = 0 ! Initialize number of nodes + DO WHILE (CLI$GET_VALUE('SELECT_FOLDER',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(:COMMA-1) + NODE_TEMP = NODE_TEMP(COMMA+1:) + ELSE + NODES(NODE_NUM) = NODE_TEMP + NODE_TEMP = ' ' + END IF + NLEN = TRIM(NODES(NODE_NUM)) + IF (NODES(NODE_NUM)(NLEN-1:NLEN).EQ.'::') THEN + NODES(NODE_NUM) = NODES(NODE_NUM)(:NLEN)//'GENERAL' + END IF + FOLDER_NUMBER = -1 + FOLDER1 = NODES(NODE_NUM) + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' Unable to access folder '',A)') + & NODES(NODE_NUM) + RETURN + ELSE IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No write access for folder '',A)') + & NODES(NODE_NUM) + IER = 0 + RETURN + END IF + END DO + END DO + + IER = 1 + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin0.for b/decus/vax91b/gce91b/net91b/bulletin0.for new file mode 100644 index 0000000..dd77e7c --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin0.for @@ -0,0 +1,1746 @@ +C +C BULLETIN0.FOR, Version 7/11/91 +C Purpose: Bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + SUBROUTINE DELETE_MSG +C +C SUBROUTINE DELETE_MSG +C +C FUNCTION: Deletes a bulletin entry from the bulletin file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER ANSWER*1,REMOTE_USER*12,SUBJECT*53 + + INTEGER NOW(2) + + IMMEDIATE = 0 + IF (CLI$PRESENT('IMMEDIATE')) IMMEDIATE = 1 + + IF (CLI$PRESENT('NODES')) THEN ! Delete messages on DECNET node? + CALL DELETE_NODE ! Yes... + RETURN + ELSE IF (DECNET_PROC) THEN ! Is this from remote node? + IER = CLI$GET_VALUE('SUBJECT',SUBJECT,SLEN) + CALL STR$UPCASE(SUBJECT,SUBJECT) + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + DEL_BULL = 0 + IER = 1 + DO WHILE (DEL_BULL+1.EQ.IER) + DEL_BULL = DEL_BULL + 1 + CALL READDIR(DEL_BULL,IER) + CALL STR$UPCASE(DESCRIP,DESCRIP) + IF (DEL_BULL+1.EQ.IER.AND.USERNAME.EQ.FROM + & .AND.INDEX(DESCRIP,SUBJECT(:SLEN)).GT.0) THEN + CALL REMOVE_ENTRY(DEL_BULL,DEL_BULL,DEL_BULL,IMMEDIATE) + CALL CLOSE_BULLDIR + WRITE (5,'(''END'')') ! Tell DECNET that delete went ok. + RETURN + END IF + END DO + CALL CLOSE_BULLDIR ! Specified message not found, + WRITE(ERROR_UNIT,1030) ! so error out. + RETURN + END IF + +C +C Get the bulletin number to be deleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT ! Delete the file we are reading + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1020) + RETURN + ELSE IF (EBULL.GT.F_NBULL.AND..NOT.REMOTE_SET.AND. + & SBULL.NE.EBULL) THEN + WRITE (6,'('' Last message specified > number in folder.'')') + WRITE (6,'('' Do you want to delete to end of folder? '',$)') + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') THEN + WRITE (6,'('' Deletion aborted.'')') + RETURN + ELSE + EBULL = F_NBULL + END IF + END IF + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + IF (REMOTE_SET) THEN + IF (SBULL.NE.EBULL) THEN + WRITE (6,1025) + RETURN + END IF + IF (SBULL.NE.BULL_POINT) CALL READDIR(SBULL,IER) + CALL REMOTE_DELETE(SBULL,IMMEDIATE,DESCRIP,I,FOLDER1_COM,IER) + IF (IER.EQ.0.AND.REMOTE_SET.NE.3) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,INPUT,F1_NEWEST_BTIM,) + NEWEST_EXDATE = INPUT(1:11) + NEWEST_EXTIME = INPUT(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE IF (IER.NE.0) THEN + CALL DISCONNECT_REMOTE + END IF + RETURN + END IF + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + DO BULL_DELETE = SBULL,EBULL + CALL READDIR(BULL_DELETE,IER) ! Get info for bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + CALL STR$UPCASE(REMOTE_USER,FROM) + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges? + & (.NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER) + & .AND.FOLDER_SET)) THEN + WRITE(6,1040) ! No, then error out. + CALL CLOSE_BULLDIR + RETURN + ELSE IF (SBULL.EQ.EBULL) THEN + IF (TRIM(FROM).EQ.1) THEN + CALL OPEN_BULLFIL + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + CALL CLOSE_BULLFIL + ASK = ILEN.EQ.0.OR.INPUT(:6).NE.'From: ' + ELSE + ASK = REMOTE_USER.EQ.FROM + END IF + IF (ASK) THEN + CALL CLOSE_BULLDIR + WRITE (6,1050) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER + CALL STR$UPCASE(ANSWER,ANSWER) + IF (ANSWER.NE.'Y') RETURN + CALL OPEN_BULLDIR + CALL READDIR(BULL_DELETE,IER) + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + END IF + END IF + +C +C Delete the bulletin directory entry. +C + CALL REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + END DO + + CALL CLOSE_BULLDIR + RETURN + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1025 FORMAT(' ERROR: Cannot delete multiple messages in remote folder.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not deleted. Not owned by you.') +1050 FORMAT(' Message is not owned by you.', + & ' Are you sure you want to delete it? ',$) + + END + + + + SUBROUTINE REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + INTEGER NOW(2) + + IF (IMMEDIATE.EQ.1) THEN ! Delete it immediately + + CALL DELETE_ENTRY(BULL_DELETE) ! Delete the directory entry + + IF ((SYSTEM.AND.4).EQ.4) THEN ! Was entry shutdown bulletin? + SHUTDOWN = SHUTDOWN - 1 ! Decrement shutdown count + END IF + ELSE ! Delete it eventually +C +C Change year of expiration date of message to 100 years less, +C to indicate that message is to be deleted. Then, set expiration date +C in header of folder to 15 minutes from now. Thus, the folder will be +C checked in 15 minutes (or more), and will delete the messages then. +C +C NOTE: If some comic set their expiration date to > 1999, then +C the deleted date will be set to 1899 since can't specify date <1859. +C + + IF ((SYSTEM.AND.7).LE.1) THEN ! General or System message + EXDATE = EXDATE(1:7)//'18'//EXDATE(10:) + IF (EXDATE(10:10).LT.'6') EXDATE(10:11) = '99' + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(1:6)//'19'//EXDATE(9:) + ELSE + EXDATE = EXDATE(1:7)//'19'//EXDATE(10:) + END IF + END IF + + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + + IER = SYS$BINTIM('0 0:15',EX_BTIM) ! Get time 15 minutes from now + IER = SYS$GETTIM(NOW) + IER = LIB$SUBX(NOW,EX_BTIM,EX_BTIM) + IER = SYS$ASCTIM(,INPUT,EX_BTIM,) + + END IF + + IF (IMMEDIATE.NE.1.AND.BULL_DELETE.EQ.EBULL) THEN + CALL READDIR(0,IER) ! Get header + + NEWEST_EXDATE = INPUT(1:11) ! and store new expiration date + NEWEST_EXTIME = INPUT(13:) + + CALL WRITEDIR(0,IER) + ELSE IF (BULL_DELETE.EQ.EBULL) THEN + CALL CLEANUP_DIRFILE(SBULL) ! Reorder directory file + + CALL UPDATE_ALWAYS ! Somewhat a kludgey way of updating latest + ! bulletin and expired dates. + + IF (SBULL.LE.BULL_POINT) THEN + IF (BULL_POINT.GT.EBULL) THEN + BULL_POINT = BULL_POINT - (EBULL - SBULL + 1) + ELSE + BULL_POINT = SBULL - 1 + END IF + END IF ! Readjust where which bulletin to read next + ! if deletion causes messages to be moved. + END IF + + RETURN + END + + + + + + SUBROUTINE GET_2_VALS(INPUT,ILEN,SVAL,EVAL,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + CHARACTER*(*) INPUT + + DELIM = MAX(INDEX(INPUT,':'),INDEX(INPUT,'-')) + + IF (DELIM.EQ.0) THEN + DECODE(ILEN,'(I)',INPUT,IOSTAT=IER) SVAL + EVAL = SVAL + ELSE + DECODE(DELIM-1,'(I)',INPUT,IOSTAT=IER) SVAL + CALL STR$UPCASE(INPUT,INPUT) + IF (IER.NE.0) THEN + IF (INDEX('CURRENT',INPUT(:DELIM-1)).EQ.1) THEN + SVAL = BULL_POINT + IER = 0 + END IF + END IF + IF (IER.EQ.0) THEN + ILEN = ILEN - DELIM + DECODE(ILEN,'(I)',INPUT(DELIM+1:),IOSTAT=IER) EVAL + IF (IER.NE.0) THEN + IF (INDEX('LAST',INPUT(DELIM+1:TRIM(INPUT))).EQ.1) THEN + EVAL = F_NBULL + IER = 0 + ELSE IF (INDEX('CURRENT', + & INPUT(DELIM+1:TRIM(INPUT))).EQ.1) THEN + EVAL = BULL_POINT + IER = 0 + END IF + END IF + END IF + IF (EVAL.LT.SVAL) IER = 2 + END IF + + RETURN + END + + + + SUBROUTINE DIRECTORY(DIR_COUNT) +C +C SUBROUTINE DIRECTORY +C +C FUNCTION: Display directory of messages. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + DATA SCRATCH_D1/0/ + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /CLOSE_FILES_INFO/ CLOSED_FILES + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED,CLI$_PRESENT,CLOSE_FILES + EXTERNAL BULLETIN_SUBCOMMANDS + + CHARACTER DATETIME*23,SEARCH_STRING*80,HEADLINE*132 + + INTEGER TODAY(2) + + CHARACTER*9 EXPIRES,DIR_TYPE + + CHARACTER TIMBUF*13 + DATA TIMBUF/'0 00:00:05.00'/ + + INTEGER TIMADR(2) ! Buffer containing time + + DATA WAITEFN /0/ + + IF (WAITEFN.EQ.0) CALL LIB$GET_EF(WAITEFN) + IER=SYS$BINTIM(TIMBUF,TIMADR) + + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + IF (INCMD(:3).EQ.'DIR') THEN + IF (.NOT.CLI$PRESENT('SELECT_FOLDER')) THEN + IF (CLI$PRESENT('MARKED')) THEN + READ_TAG = 1 + IBSET(0,1) + ELSE IF (CLI$PRESENT('SEEN')) THEN + READ_TAG = 1 + IBSET(0,2) + ELSE IF (CLI$PRESENT('UNMARKED')) THEN + READ_TAG = 1 + IBSET(0,1) + IBSET(0,3) + ELSE IF (CLI$PRESENT('UNSEEN')) THEN + READ_TAG = 1 + IBSET(0,2) + IBSET(0,3) + ELSE IF (CLI$PRESENT('ALL')) THEN + READ_TAG = IBSET(0,1) + IBSET(0,2) + IF (REMOTE_SET.EQ.3) THEN + BULL_POINT = F_START - 1 + ELSE + BULL_POINT = 0 + END IF + END IF + IF (READ_TAG) THEN + IF (.NOT.(FOLDER_NUMBER.GE.0.OR.REMOTE_SET.EQ.3)) THEN + WRITE (6,'('' ERROR: Invalid qualifier'', + & '' with remote folder.'')') + READ_TAG = IBSET(0,1) + IBSET(0,2) + RETURN + END IF + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + END IF + END IF + IF (.NOT.READ_TAG) THEN + SUBJECT = CLI$PRESENT('SUBJECT') + REPLY = CLI$PRESENT('REPLY') + REPLY_FIRST = REPLY + SEARCH = CLI$PRESENT('SEARCH') + END IF + PRINTING = CLI$PRESENT('PRINT') + ELSE + PRINTING = .FALSE. + END IF + +C +C Directory listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C directory file, and to avoid the possibility of the user holding the screen, +C and thus causing the directory file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + CALL INIT_QUEUE(SCRATCH_D1,BULLDIR_ENTRY) + SCRATCH_D = SCRATCH_D1 + + CALL OPEN_BULLDIR_SHARED ! Get directory file + + CALL READDIR(0,IER) ! Does directory header exist? + IF (IER.EQ.1.AND.NBULL.GT.0) THEN ! And are there messages? + IF (DIR_COUNT.EQ.0) THEN + EXPIRATION = CLI$PRESENT('EXPIRATION') + IF (CLI$PRESENT('START')) THEN ! Start number specified? + IER = CLI$GET_VALUE('START',BULL_PARAMETER,LEN_P) + DECODE(LEN_P,'(I)',BULL_PARAMETER) DIR_COUNT + IF (DIR_COUNT.GT.NBULL) THEN + DIR_COUNT = NBULL + ELSE IF (DIR_COUNT.LT.1) THEN + WRITE (6,'('' ERROR: Invalid starting message.'')') + CALL CLOSE_BULLDIR + DIR_COUNT = 0 + RETURN + END IF + ELSE IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN + IF (CLI$PRESENT('SINCE')) THEN ! Was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + CALL READDIR_KEYGE(IER) + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + IF (REMOTE_SET.NE.3) THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present in'', + & '' folder '',A,''.'')') FOLDER(:TRIM(FOLDER)) + CALL CLOSE_BULLDIR + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + CALL READDIR_KEYGE(IER) + ELSE + CALL NEWS_GET_NEWEST_MESSAGE(IER) + IF (IER.EQ.0) THEN + WRITE (6,'('' No new messages are present in'', + & '' folder '',A,''.'')') + & FOLDER_NAME(:TRIM(FOLDER_NAME)) + RETURN + END IF + END IF + END IF + + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + CALL CLOSE_BULLDIR + RETURN + ELSE + DIR_COUNT = IER + END IF + ELSE + DIR_COUNT = BULL_POINT + IF (DIR_COUNT.EQ.0) DIR_COUNT = 1 + END IF + + IF (CLI$PRESENT('SEARCH')) THEN + IER1 = CLI$GET_VALUE('SEARCH',SEARCH_STRING,SLEN) + ELSE IF (CLI$PRESENT('SUBJECT')) THEN + IER1 = CLI$GET_VALUE('SUBJECT',SEARCH_STRING,SLEN) + ELSE IF (CLI$PRESENT('REPLY')) THEN + SEARCH_STRING = ' ' + END IF + + IF (READ_TAG) THEN + IF (SUBJECT.OR.REPLY.OR.SEARCH) THEN + WRITE (6,'('' ERROR: Qualifier not valid when '', + & ''displaying only tagged messages.'')') + SUBJECT = .FALSE. + REPLY = .FALSE. + SEARCH = .FALSE. + CALL CLOSE_BULLDIR + RETURN + END IF + IF (.NOT.(CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW') + & .OR.CLI$PRESENT('START'))) THEN + DIR_COUNT = 1 + END IF + CALL READDIR(DIR_COUNT,IER1) + IF (IER1.EQ.DIR_COUNT+1) IER1 = 0 + IF (REMOTE_SET.EQ.3.OR.BTEST(READ_TAG,3)) THEN + MSG_NUM = DIR_COUNT-1 + ELSE + CALL DECREMENT_MSG_KEY + END IF + END IF + + IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW') + & .OR.CLI$PRESENT('START')) THEN + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + ELSE IF (NBULL-DIR_COUNT+1.LE.PAGE_LENGTH-5) THEN + EBULL = NBULL + SBULL = NBULL - (PAGE_LENGTH-5) + 1 + IF (SBULL.LT.1) SBULL = 1 + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + END IF + ELSE IF (DIR_COUNT.EQ.-1.AND..NOT.READ_TAG) THEN + SUBJECT = .FALSE. + REPLY = .FALSE. + SEARCH = .FALSE. + SBULL = (SBULL - 1) - ((PAGE_LENGTH - 7) - 1) + IF (SBULL.LT.1) SBULL = 1 + EBULL = SBULL + (PAGE_LENGTH - 7) - 1 + IF (NBULL-SBULL+1.LE.PAGE_LENGTH-5) THEN + SBULL = NBULL - (PAGE_LENGTH-5) + 1 + EBULL = NBULL + IF (SBULL.LT.1) SBULL = 1 + END IF + ELSE IF (DIR_COUNT.EQ.-1.AND.READ_TAG) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,FIRST_BULL) + FIRST_BULL = FIRST_BULL + 1 + IER1 = 0 + IER = 0 + FBULL = 0 + DO WHILE (SBULL.GT.FIRST_BULL.AND.IER.EQ.0) + SBULL = SBULL - 1 + CALL READDIR(SBULL,IER) + IF (IER.EQ.SBULL+1) THEN + CALL GET_THIS_TAG(FOLDER_NUMBER,IER,DIR_COUNT,DUMMY) + IF (IER.EQ.0) THEN + IF (FBULL.EQ.0) THEN + EBULL = DIR_COUNT + FBULL = EBULL + 1 + END IF + FBULL = FBULL - 1 + IF (EBULL-FBULL.EQ.(PAGE_LENGTH-7)-1) THEN + IER = 1 + END IF + ELSE + IER = 0 + END IF + ELSE + IER = 1 + END IF + END DO + IF (FBULL.EQ.FIRST_BULL) THEN + CALL READDIR(EBULL,IER) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DIR_COUNT,DUMMY) + DO WHILE (IER.EQ.0.AND.EBULL-FBULL.LT.(PAGE_LENGTH-7)-1) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DIR_COUNT,DUMMY) + IF (IER.EQ.0) EBULL = EBULL + 1 + END DO + DO I=1,3 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DIR_COUNT,DUMMY) + END DO + IF (IER.NE.0) EBULL = DIR_COUNT + END IF + CALL READDIR(EBULL,IER) + IF (EBULL+1.NE.IER) THEN + EBULL = EBULL + 1 + ELSE + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DUMMY,DUMMY) + IF (IER.NE.0) EBULL = EBULL + 1 + END IF + CALL READDIR(SBULL,IER) + CALL DECREMENT_MSG_KEY + ELSE + SBULL = DIR_COUNT + EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 + IF (EBULL.GE.NBULL-2) EBULL = NBULL + END IF + IF (.NOT.PAGING.OR.PRINTING) EBULL = NBULL + IF (INCMD(:3).EQ.'DIR') THEN + IF (CLI$GET_VALUE('END',BULL_PARAMETER,LEN_P)) THEN + DECODE(LEN_P,'(I)',BULL_PARAMETER) EBULL + EBULL = MIN(EBULL,NBULL) + END IF + END IF + IF (SUBJECT.OR.REPLY.OR.SEARCH) THEN + CONTINUE + ELSE IF (.NOT.REMOTE_SET.AND..NOT.READ_TAG) THEN + DO I = SBULL,EBULL + CALL READDIR(I,IER) ! Into the queue + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + END DO + ELSE IF (READ_TAG) THEN + I = 0 + DO WHILE (I.LE.EBULL.AND.IER1.EQ.0) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,DIR_COUNT,TAG_TYPE) + IF (I.EQ.0.AND.IER1.EQ.0) THEN + EBULL = EBULL - SBULL + DIR_COUNT + SBULL = DIR_COUNT + I = SBULL + END IF + SYSTEM = SYSTEM.OR.ISHFT(TAG_TYPE,28) + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + I = I + 1 + END DO + EBULL = I - 1 + IF (IER1.NE.0) THEN + EBULL = EBULL - 1 + ELSE + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,DUMMY,TAG_TYPE) + IF (IER1.EQ.0) THEN + IER = 0 + EBULL_SAVE = EBULL + DO I=1,2 + IF (IER.EQ.0) THEN + SYSTEM = SYSTEM.OR.ISHFT(TAG_TYPE,28) + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D, + & BULLDIR_ENTRY) + EBULL = EBULL + 1 + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,DUMMY, + & TAG_TYPE) + END IF + END DO + IF (IER.NE.0) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,FIRST_BULL) + IF (SBULL.NE.FIRST_BULL+1) EBULL = EBULL_SAVE + IER1 = 1 + ELSE + EBULL = EBULL_SAVE + END IF + END IF + END IF + ELSE + CALL REMOTE_DIRECTORY_COMMAND + & (SBULL,EBULL,.FALSE.,SCRATCH_D,IER) + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + RETURN + END IF + END IF + ELSE + NBULL = 0 + END IF + + IF (NBULL.EQ.0.OR.EBULL.LT.SBULL) THEN + CALL CLOSE_BULLDIR ! We don't need file anymore + IF (READ_TAG) THEN + IF (BTEST(READ_TAG,1)) THEN + DIR_TYPE = 'marked' + ELSE IF (BTEST(READ_TAG,2)) THEN + DIR_TYPE = 'seen' + ELSE IF (BTEST(READ_TAG,1).AND.BTEST(READ_TAG,3)) THEN + DIR_TYPE = 'unmarked' + ELSE IF (BTEST(READ_TAG,2).AND.BTEST(READ_TAG,3)) THEN + DIR_TYPE = 'unseen' + END IF + WRITE (6,'('' No '',A,'' messages are present in'', + & '' folder '',A,''.'')') + & DIR_TYPE(:TRIM(DIR_TYPE)),FOLDER_NAME(:TRIM(FOLDER_NAME)) + ELSE + WRITE (6,'('' There are no messages present.'')') + END IF + DIR_COUNT = -1 + RETURN + END IF + +C +C Directory entries are now in queue. Output queue entries to screen. +C + + IF (REMOTE_SET.EQ.3) THEN + WRITE (HEADLINE,'('' ['',I,''-'',I,'']'')') + & F_START,F_NBULL + ELSE + WRITE (HEADLINE,'('' [1-'',I,'']'')') F_NBULL + END IF + DO WHILE (INDEX(HEADLINE,'- ').GT.0) + I = INDEX(HEADLINE,'- ') + HEADLINE(I+1:) = HEADLINE(I+2:) + END DO + DO WHILE (INDEX(HEADLINE,'[ ').GT.0) + I = INDEX(HEADLINE,'[ ') + HEADLINE(I+1:) = HEADLINE(I+2:) + END DO + DO WHILE (INDEX(HEADLINE,' ').LT.TRIM(HEADLINE)) + I = INDEX(HEADLINE,' ') + HEADLINE(I:) = HEADLINE(I+1:) + END DO + HEADLINE = FOLDER_NAME(:TRIM(FOLDER_NAME))//HEADLINE + BULL_PARAMETER = ' ' + IF (READ_TAG) THEN + IF (BTEST(READ_TAG,1)) THEN + BULL_PARAMETER = 'MARKED' + ELSE + BULL_PARAMETER = 'SEEN' + END IF + IF (BTEST(READ_TAG,3)) THEN + BULL_PARAMETER = 'UN'//BULL_PARAMETER + END IF + END IF + IF (PRINTING) THEN + BULL_PARAMETER = 'PRINTING '//BULL_PARAMETER + END IF + WRITE (6,'(1X,A,X,A)') + & BULL_PARAMETER(:TRIM(BULL_PARAMETER)), + & HEADLINE(:TRIM(HEADLINE)) + IF (EXPIRATION) THEN + WRITE(6,1005) + ELSE + WRITE(6,1000) + END IF + + TAG = (BULL_TAG.AND.REMOTE_SET.EQ.0).OR. + & (BULL_NEWS_TAG.AND.REMOTE_SET.EQ.3) + + IF (.NOT.(SUBJECT.OR.REPLY.OR.SEARCH).AND.TAG + & .AND..NOT.READ_TAG) THEN + IF (INCMD(1:3).NE.' ') THEN + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG,TAG_TYPE) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + DO I=SBULL,EBULL + SAVE_SCRATCH_D = SCRATCH_D + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + IF (TAG.AND.MSG_NUM.EQ.NEXT_TAG) THEN + SYSTEM = SYSTEM.OR.ISHFT(TAG_TYPE,28) + CALL WRITE_QUEUE(%VAL(SAVE_SCRATCH_D),DUMMY,BULLDIR_ENTRY) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG,TAG_TYPE) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + END IF + END DO + END IF + + CALL CLOSE_BULLDIR ! We don't need file anymore + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + + I = SBULL + START_SEARCH = I + IF (.NOT.REPLY_FIRST) START_SEARCH = I - 1 + IF (SUBJECT.OR.REPLY.OR.SEARCH.OR.PRINTING) THEN + CALL OPEN_BULLDIR_SHARED + IF (SEARCH.OR.PRINTING) CALL OPEN_BULLFIL_SHARED + CLOSED_FILES = .FALSE. + END IF + DO WHILE (I.LE.EBULL) + IF (.NOT.(SUBJECT.OR.REPLY.OR.SEARCH)) THEN + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) + ELSE + IF (CLOSED_FILES) THEN + CLOSED_FILES = .FALSE. + CALL OPEN_BULLDIR_SHARED + IF (SEARCH.OR.PRINTING) CALL OPEN_BULLFIL_SHARED + END IF + CALL GET_SEARCH(FOUND,SEARCH_STRING,START_SEARCH,.FALSE. + & ,SUBJECT,REPLY_FIRST,.FALSE.,.TRUE.) + IF (INCMD(1:3).NE.' '.AND.TAG.AND.FOUND.GT.0) THEN + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG, + & TAG_TYPE) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + CALL READDIR(FOUND,IER) + END IF + REPLY_FIRST = .FALSE. + IF (FOUND.GT.0) THEN + SEARCH_STRING = ' ' + START_SEARCH = FOUND + IF (TAG.AND.MSG_NUM.EQ.NEXT_TAG) THEN + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG,DUMMY) + IF (IER.NE.0) NEXT_TAG = NBULL + 1 + CALL READDIR(FOUND,IER) + SYSTEM = SYSTEM.OR.ISHFT(TAG_TYPE,28) + TAG_TYPE = DUMMY + END IF + ELSE + I = EBULL + 1 + END IF + IER = SYS$SETIMR(%VAL(WAITEFN),TIMADR,CLOSE_FILES,) + END IF + IF (I.LE.EBULL) THEN + CALL CONVERT_ENTRY_FROMBIN + IF (BTEST(SYSTEM,30)) THEN + WRITE (6,'('' >'',$)') + ELSE + WRITE (6,'('' '',$)') + END IF + IF (BTEST(SYSTEM,29)) THEN + WRITE (6,'(''+*'',$)') + ELSE + WRITE (6,'(''+ '',$)') + END IF + N = MAX(INT(LOG10(REAL(MSG_NUM)))+1,3) + IF ((EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) + & .AND.REMOTE_SET.NE.3) THEN + WRITE(6,2010) MSG_NUM,DESCRIP(:54-N),FROM,'(DELETED)' + ELSE IF (EXPIRATION) THEN + IF (BTEST(SYSTEM,2)) THEN ! Shutdown bulletin? + EXPIRES = 'Shutdown' + ELSE IF (BTEST(SYSTEM,1)) THEN ! Permanent bulletin? + EXPIRES = 'Permanent' + ELSE IF (EXDATE(8:9).EQ.'18'.AND.REMOTE_SET.EQ.3) THEN + EXPIRES = 'Unknown' + ELSE + EXPIRES = EXDATE(1:7)//EXDATE(10:11) + END IF + WRITE(6,2010) MSG_NUM,DESCRIP(:54-N),FROM,EXPIRES + ELSE + WRITE(6,2010) MSG_NUM,DESCRIP(:54-N),FROM, + & DATE(1:7)//DATE(10:11) + END IF + IF (PRINTING) THEN + FOUND_MSG = .TRUE. + CALL SYS$SETAST(%VAL(0)) + CALL PRINT(MSG_NUM,CLOSED_FILES) + CALL SYS$SETAST(%VAL(1)) + END IF + END IF + I = I + 1 + IF (SUBJECT.OR.REPLY.OR.SEARCH) IER = SYS$CANTIM(,) + END DO + + DIR_COUNT = MSG_NUM + 1 ! Update directory counter + + IF (SEARCH.OR.REPLY.OR.SUBJECT.OR.PRINTING) THEN + IF (SEARCH.OR.PRINTING) CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + IF (SEARCH.OR.REPLY.OR.SUBJECT) THEN + IF (FOUND.GT.0) THEN + DIR_COUNT = FOUND + 1 + ELSE + DIR_COUNT = NBULL + 1 + END IF + END IF + END IF + + IF (DIR_COUNT.GT.NBULL.OR.(READ_TAG.AND.IER1.NE.0)) THEN + ! Outputted all entries? + DIR_COUNT = -1 ! Yes. Set counter to -1. + IF (PRINTING.AND.CLI$PRESENT('NOW').AND.FOUND_MSG) THEN + INCMD = 'PRINT/NOW' + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + CALL PRINT(MSG_NUM,CLOSED_FILES) + END IF + ELSE + WRITE(6,1010) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(' #',1X,'Description',43X,'From',9X,'Date',/) +1005 FORMAT(' #',1X,'Description',43X,'From',8X,'Expires',/) +1010 FORMAT(1X,/,' Press RETURN for more...',/) + +2010 FORMAT('+',I,1X,A<54-N>,1X,A12,1X,A9) + + END + + + SUBROUTINE CLOSE_FILES + + IMPLICIT INTEGER (A-Z) + + COMMON /CLOSE_FILES_INFO/ CLOSED_FILES + + INQUIRE(UNIT=1,OPENED=IER) + IF (IER) CALL CLOSE_BULLFIL + + INQUIRE(UNIT=2,OPENED=IER) + IF (IER) CALL CLOSE_BULLDIR + + CLOSED_FILES = .TRUE. + + RETURN + END + + + + SUBROUTINE GET_MSGKEY(BTIM,MSG_KEY) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*8 MSG_KEY,INPUT + + CALL LIB$MOVC3(8,BTIM(1),%REF(INPUT)) + + DO I=1,8 + MSG_KEY(I:I) = INPUT(9-I:9-I) + END DO + + RETURN + END + + + + SUBROUTINE FILE +C +C SUBROUTINE FILE +C +C FUNCTION: Copies a bulletin to a file. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /READ_DISPLAY/ LINE_OFFSET + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + IF (CAPTIVE()) THEN + WRITE (6,'('' ERROR: Command invalid from CAPTIVE account.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + IF (EBULL.GT.F_NBULL) EBULL = F_NBULL + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN ! If no file name was specified + WRITE(6,1020) ! Write error + RETURN ! And return + END IF + + CALL DISABLE_PRIVS + + IF (CLI$PRESENT('NEW')) THEN + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),IOSTAT=IER, + & RECL=LINE_LENGTH, + & STATUS='OLD',CARRIAGECONTROL='LIST',ACCESS='APPEND') + IF (IER.NE.0) THEN + OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE IF (CLI$PRESENT('FF')) THEN + WRITE (3,'(A)') CHAR(12) + END IF + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + FIRST = .TRUE. + + DO FBULL = SBULL,EBULL + FBULL1 = FBULL + CALL READDIR(FBULL,IER) ! Get info for specified bulletin + + IF (IER.NE.FBULL+1.OR.FBULL.GT.EBULL.OR.(.NOT.CLI$PRESENT + & ('ALL').AND.FBULL1.EQ.SBULL.AND.FBULL.NE.SBULL)) THEN + IF (REMOTE_SET.NE.3.OR.FBULL1.EQ.SBULL) WRITE(6,1030) FBULL1 + IF (FBULL1.GT.SBULL) GO TO 100 + CLOSE (UNIT=3,STATUS='DELETE') + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + RETURN + ELSE IF (REMOTE_SET) THEN + CALL REMOTE_READ_MESSAGE(FBULL,IER1) + IF (IER1.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER1) + END IF + IF (IER1.NE.0) GO TO 100 + END IF + + IF (.NOT.FIRST.AND.CLI$PRESENT('FF')) THEN + WRITE (3,'(A)') CHAR(12) + ELSE IF (FIRST) THEN + FIRST = .FALSE. + END IF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + END DO + +100 CLOSE (UNIT=3) ! Bulletin copy completed + + WRITE(6,1040) BULL_PARAMETER(1:LEN_P) + ! Show name of file created. + + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + + RETURN + +900 WRITE(6,1000) + CALL ENABLE_PRIVS ! Reset BYPASS privileges + RETURN + +1000 FORMAT(' ERROR: Error in opening file.') +1010 FORMAT(' ERROR: You have not read any bulletin.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1020 FORMAT(' ERROR: No file name was specified.') +1030 FORMAT(' ERROR: Following bulletin was not found: ',I) +1040 FORMAT(' Message(s) written to ',A) +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,/,'Date: ',A) + + END + + + + SUBROUTINE COPY2(OUT,IN) + + CALL LIB$MOVC3(8,IN,OUT) + + RETURN + END + + + + SUBROUTINE LOGIN +C +C SUBROUTINE LOGIN +C +C FUNCTION: Alerts user of new messages upon logging in. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /READIT/ READIT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /POINT/ BULL_POINT + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY*23,INREAD*1 + + LOGICAL*1 CTRL_G/7/ + + DATA GEN_DIR1/0/ ! General directory link list header + DATA SYS_DIR1/0/ ! System directory link list header + DATA SYS_NUM1/0/ ! System message number link list header + DATA SYS_BUL1/0/ ! System bulletin link list header + DATA ALL_DIR1/0/ ! Full directory link list header (for remote) + + DATA PAGE/0/ + + DATA FIRST_WRITE/.TRUE./ + LOGICAL FIRST_WRITE + + COMMON /LOGIN_BTIM/ LOGIN_BTIM_SAVE(2) + + DIMENSION NOLOGIN_BTIM(2),TODAY_BTIM(2) + DIMENSION NEW_BTIM(2),PASSCHANGE(2),BULLCP_BTIM(2) + DIMENSION LOGIN_BTIM_OLD(2),LOGIN_BTIM_NEW(2) + + FOLDER_NAME = 'GENERAL' + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + CALL SYS_BINTIM('5-NOV-1956 11:05:56',NEW_BTIM) + +C +C Find user entry in BULLUSER.DAT to update information and +C to get the last date that messages were read. +C + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_HEADER(IER) ! Get the header + + IF (IER.EQ.0) THEN ! Header is present. + UNLOCK 4 + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + ! Find if there is an entry + IF (NEW_FLAG(1).LT.143.OR.NEW_FLAG(1).GT.143) THEN + NEW_FLAG(2)=0 ! If old version clear GENERIC value + NEW_FLAG(1)=143 ! Set new version number + END IF + IF (IER1.EQ.0) THEN ! There is a user entry + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + ! DISMAIL or SET LOGIN set + IF (CLI$PRESENT('ALL')) THEN + CALL COPY2(LOGIN_BTIM,TODAY_BTIM(1)) + ELSE + RETURN ! Don't notify + END IF + END IF + CALL COPY2(LOGIN_BTIM_SAVE,LOGIN_BTIM) + CALL COPY2(LOGIN_BTIM,TODAY_BTIM) + REWRITE (4) USER_ENTRY + IF (SYSTEM_FLAG(1).NE.0.AND.SYSTEM_FLAG(1).NE.1) READIT = 1 + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0.OR.BRIEF_FLAG(I).NE.0.OR. + & (I.GT.1.AND.SYSTEM_FLAG(I).NE.0)) READIT = 1 + END DO + ELSE + CALL CLEANUP_LOGIN ! Good time to delete dead users + CALL COPY2(READ_BTIM,NEW_BTIM) ! Make new entry + DO I = 1,FLONG + SET_FLAG(I) = SET_FLAG_DEF(I) + BRIEF_FLAG(I) = BRIEF_FLAG_DEF(I) + NOTIFY_FLAG(I) = NOTIFY_FLAG_DEF(I) + END DO + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) + IF (DISMAIL.EQ.1) THEN + CALL COPY2(LOGIN_BTIM,NOLOGIN_BTIM) + CALL COPY2(LOGIN_BTIM_SAVE,LOGIN_BTIM) + ELSE + CALL COPY2(LOGIN_BTIM_SAVE,NEW_BTIM) + CALL COPY2(LOGIN_BTIM,TODAY_BTIM) + DO I = 1,FLONG + IF (SET_FLAG(I).NE.0) READIT = 1 + END DO + IF (COMPARE_BTIM(PASSCHANGE,NEWEST_BTIM).LT.0) IER1 = 0 + ! Old password change indicates user is new to BULLETIN + ! but not to system, so don't limit message viewing. + END IF + CALL WRITE_USER_FILE(IER) + IF (IER.NE.0) THEN ! Error in writing to user file + WRITE (6,1070) ! Tell user of the error + CALL CLOSE_BULLUSER ! Close the user file + CALL EXIT ! Go away... + END IF + IF (DISMAIL.EQ.1) RETURN ! Go away if DISMAIL set + DIFF = -1 ! Force us to look at messages + CALL OPEN_BULLINF_SHARED + DO I=1,FOLDER_MAX + CALL COPY2(LAST_READ_BTIM(1,I),READ_BTIM) + END DO + WRITE (9,IOSTAT=IER) USERNAME, + & ((LAST_READ_BTIM(I,J),I=1,2),J=1,FOLDER_MAX) + CALL CLOSE_BULLINF + END IF + CALL COPY2(LOGIN_BTIM,LOGIN_BTIM_SAVE) + CALL READ_USER_FILE_HEADER(IER2) ! Reset read back to header + END IF + + IF (IER.EQ.0.AND.MINUTE_DIFF(TODAY_BTIM,BBOARD_BTIM) + & .GT.BBOARD_UPDATE) THEN ! Update BBOARD mail? + CALL COPY2(BBOARD_BTIM,TODAY_BTIM) + REWRITE (4) USER_HEADER ! Rewrite header + IF (.NOT.TEST_BULLCP()) CALL CREATE_PROCESS('BBOARD') + ELSE IF (IER.NE.0) THEN + CALL CLOSE_BULLUSER + CALL EXIT ! If no header, no messages + END IF + + IF (IER1.EQ.0) THEN ! Skip date comparison if new entry +C +C Compare and see if messages have been added since the last time +C that the user has logged in or used the BULLETIN facility. +C + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,READ_BTIM) + IF (DIFF1.LT.0) THEN ! If read messages since last login, + CALL COPY2(LOGIN_BTIM,READ_BTIM) + ! then use read date to compare with latest bulletin date + END IF ! to see if should alert user. + + IF (SYSTEM_SWITCH) THEN + DIFF1 = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,NEWEST_BTIM) + ELSE + DIFF1 = COMPARE_BTIM(LOGIN_BTIM,NEWEST_BTIM) + END IF + END IF + + CALL COPY2(LOGIN_BTIM_SAVE,LOGIN_BTIM) ! Destroyed in UPDATE_READ + + IF (NEW_FLAG(2).NE.0.AND.NEW_FLAG(2).NE.-1) THEN + CALL LIB$MOVC3(4,NEW_FLAG(2),%REF(BULL_PARAMETER)) + CALL SUBTIME(LOGIN_BTIM,BULL_PARAMETER(1:4),IER) + ELSE IF (DIFF1.GT.0) THEN + BULL_POINT = -1 + IF (READIT.EQ.1) THEN + CALL UPDATE_READ(1) + CALL COPY2(LOGIN_BTIM_NEW,LOGIN_BTIM) + CALL READ_IN_FOLDERS + CALL MODIFY_SYSTEM_LIST(1) + END IF + CALL CLOSE_BULLUSER + RETURN + END IF + + CALL READ_IN_FOLDERS + CALL MODIFY_SYSTEM_LIST(1) + + ENTRY LOGIN_FOLDER + + IF (NEW_FLAG(2).EQ.0.OR.NEW_FLAG(2).EQ.-1.OR.FOLDER_SET) THEN + CALL COPY2(LOGIN_BTIM,LOGIN_BTIM_SAVE) + END IF + + IF (REMOTE_SET.EQ.1) THEN ! If system remote folder, use remote + ! info, not local login time + IF (LAST_SYS_BTIM(1,FOLDER_NUMBER+1).NE.0) THEN + CALL COPY2(LOGIN_BTIM,LAST_SYS_BTIM(1,FOLDER_NUMBER+1)) + LAST_SYS_BTIM(1,FOLDER_NUMBER+1) = 0 + LAST_SYS_BTIM(2,FOLDER_NUMBER+1) = 0 + ELSE + DIFF1 = COMPARE_BTIM(LOGIN_BTIM, + & LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF1.LT.0) THEN + CALL COPY2(LOGIN_BTIM,LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + ELSE + DIFF = MINUTE_DIFF(LOGIN_BTIM,F_NEWEST_BTIM) + IF (DIFF.GE.0.AND.DIFF.LE.15) THEN ! BULLCP updates every 15 min + IER = SYS$BINTIM('0 00:15',BULLCP_BTIM) + BULLCP_BTIM(1) = -BULLCP_BTIM(1) ! Convert to -delta time + BULLCP_BTIM(2) = -BULLCP_BTIM(2)-1 + CALL LIB$SUBX(LOGIN_BTIM,BULLCP_BTIM,LOGIN_BTIM) + END IF + END IF + END IF + END IF + + ENTRY SHOW_SYSTEM + + JUST_SYSTEM = (.NOT.LOGIN_SWITCH.AND.SYSTEM_SWITCH).OR. + & (BTEST(FOLDER_FLAG,2) + & .AND..NOT.TEST_SET_FLAG(FOLDER_NUMBER) + & .AND..NOT.TEST_BRIEF_FLAG(FOLDER_NUMBER)) + + NGEN = 0 ! Number of general messages + NSYS = 0 ! Number of system messages + BULL_POINT = -1 + + IF (IER1.NE.0.AND.FOLDER_NUMBER.GT.0) THEN + IF (LOGIN_SWITCH) THEN + IF (READIT.EQ.1) THEN + CALL COPY2(LOGIN_BTIM_SAVE,LOGIN_BTIM) + CALL UPDATE_READ(1) + CALL COPY2(LOGIN_BTIM_NEW,LOGIN_BTIM) + END IF + CALL CLOSE_BULLUSER + END IF + RETURN ! Don't overwhelm new user with lots of non-general msgs + END IF + + IF (BTEST(FOLDER_FLAG,2).AND.SYSTEM_SWITCH) THEN + ! Can folder have SYSTEM messages and /SYSTEM specified? + CALL COPY2(LOGIN_BTIM,SYSTEM_LOGIN_BTIM) ! Use specified login time + ! for system messages. + END IF + + IF (LOGIN_SWITCH) THEN + IF (READIT.EQ.1) THEN + CALL COPY2(LOGIN_BTIM_OLD,LOGIN_BTIM) + CALL UPDATE_READ(1) + CALL COPY2(LOGIN_BTIM_NEW,LOGIN_BTIM) + CALL COPY2(LOGIN_BTIM,LOGIN_BTIM_OLD) + END IF + CALL CLOSE_BULLUSER + END IF + + IF (READIT.EQ.1.AND.FOLDER_NUMBER.GE.0) THEN + IF (LAST_SYS_BTIM(1,FOLDER_NUMBER+1).NE.0) THEN + DIFF1 = COMPARE_BTIM(LOGIN_BTIM, + & LAST_SYS_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF1.LT.0) THEN + CALL COPY2(LOGIN_BTIM,LAST_SYS_BTIM(1,FOLDER_NUMBER+1)) + END IF + CALL COPY2(LAST_SYS_BTIM(1,FOLDER_NUMBER+1), + & LOGIN_BTIM_NEW) + END IF + + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER) + & .AND.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + IF (.NOT.TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) GO TO 9999 + END IF + END IF + + CALL OPEN_BULLDIR_SHARED ! Get bulletin directory + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(0,IER) ! Get header info + ELSE + NBULL = F_NBULL + END IF + + CALL INIT_QUEUE(GEN_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_DIR1,BULLDIR_ENTRY) + CALL INIT_QUEUE(SYS_NUM1,%DESCR(ICOUNT)) + GEN_DIR = GEN_DIR1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + START = 1 + REVERSE = 0 + IF ((.NOT.TEST_SET_FLAG(FOLDER_NUMBER).OR. + & .NOT.TEST_BRIEF_FLAG(FOLDER_NUMBER)) + & .AND..NOT.BTEST(FOLDER_FLAG,7)) THEN + IF (REVERSE_SWITCH) REVERSE = 1 + IF (IER1.EQ.0) THEN + CALL GET_NEWEST_MSG(LOGIN_BTIM,START) + IF (START.EQ.-1) START = NBULL + 1 + END IF + END IF + + IF (REMOTE_SET) THEN + CALL INIT_QUEUE(ALL_DIR1,BULLDIR_ENTRY) + ALL_DIR = ALL_DIR1 + CALL REMOTE_DIRECTORY_COMMAND(START,NBULL, + & .NOT.REVERSE,ALL_DIR,IER) + IF (IER.NE.0) THEN + CALL CLOSE_BULLDIR + CALL DISCONNECT_REMOTE + GO TO 9999 + END IF + LAST_DIR = ALL_DIR + ALL_DIR = ALL_DIR1 + END IF + + DO ICOUNT1 = NBULL,START,-1 + IF (REVERSE) THEN + ICOUNT = NBULL + START - ICOUNT1 + ELSE + ICOUNT = ICOUNT1 + END IF + IF (REMOTE_SET) THEN + IF (ALL_DIR.EQ.LAST_DIR) GO TO 100 + CALL READ_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + IER = ICOUNT + 1 + ELSE + CALL READDIR(ICOUNT,IER) + END IF + IF (IER1.EQ.0.AND.IER.EQ.ICOUNT+1) THEN ! Is this a totally new user? + IF (.NOT.REVERSE.AND..NOT.BTEST(FOLDER_FLAG,7)) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM,MSG_BTIM) ! No, so compare date + IF (DIFF.GT.0) GO TO 100 + END IF + IF (.NOT.BTEST(FOLDER_FLAG,2)) SYSTEM = SYSTEM.AND.(.NOT.1) + ! Show system msg in non-system folder as general msg + IF (USERNAME.NE.FROM.OR.SYSTEM) THEN + ! Is bulletin system or from same user? + IF (SYSTEM) THEN ! Is it system bulletin? + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (.NOT.JUST_SYSTEM) THEN + IF (BTEST(FOLDER_FLAG,7)) THEN + DIFF = COMPARE_BTIM + & (LAST_READ_BTIM(1,FOLDER_NUMBER+1),MSG_BTIM) + ELSE IF (.NOT.SYSTEM_SWITCH) THEN + DIFF = -1 + ELSE + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,MSG_BTIM) + END IF + IF (DIFF.LT.0) THEN + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (.NOT.BTEST(FOLDER_FLAG,2).AND. + & TEST_BRIEF_FLAG(FOLDER_NUMBER).AND. + & TEST_SET_FLAG(FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + SYSTEM = ICOUNT + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END IF + ELSE IF (IER.EQ.ICOUNT+1) THEN + ! Totally new user, save only permanent system msgs + IF ((SYSTEM.AND.7).EQ.3.OR. + & (SYSTEM.AND.BTEST(FOLDER_FLAG,7))) THEN + NSYS = NSYS + 1 + CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + ELSE IF (NGEN.EQ.0.OR. ! And save only the first non-system msg + & BTEST(FOLDER_FLAG,7)) THEN ! and SET ALWAYS folder messages + SYSTEM = ICOUNT ! Save bulletin number for display + IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN + BULL_POINT = ICOUNT - 1 + IF (.NOT.BTEST(FOLDER_FLAG,2).AND. + & TEST_BRIEF_FLAG(FOLDER_NUMBER).AND. + & TEST_SET_FLAG(FOLDER_NUMBER)) GO TO 100 + END IF + NGEN = NGEN + 1 + CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + END IF + END IF + END DO +100 CALL CLOSE_BULLDIR +C +C Review new directory entries. If there are system messages, +C copy the system bulletin into GEN_DIR file BULLSYS.SCR for outputting +C to the terminal. If there are simple messages, just output the +C header information. +C + IF (TEST_BRIEF_FLAG(FOLDER_NUMBER).AND. + & TEST_SET_FLAG(FOLDER_NUMBER)) NGEN = 0 + + IF (NGEN.EQ.0.AND.NSYS.EQ.0) GO TO 9999 + + IF (NSYS.GT.0) THEN ! Are there any system messages? + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + LENF = TRIM(FOLDER_NAME) + S1 = (PAGE_WIDTH-(LENF+16))/2 + S2 = PAGE_WIDTH - S1 - (LENF + 16) + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE (6,1026) FOLDER_NAME(:LENF) ! Yep... + PAGE = PAGE + 1 + CTRL_G = 0 ! Don't ring bell for non-system bulls + CALL OPEN_BULLFIL_SHARED + CALL INIT_QUEUE(SYS_BUL1,INPUT) + SYS_BUL = SYS_BUL1 + SYS_DIR = SYS_DIR1 + SYS_NUM = SYS_NUM1 + NSYS_LINE = 0 + DO J=1,NSYS + CALL READ_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) + IF (REMOTE_SET) THEN + CALL READ_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,ICOUNT + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER) + END IF + IF (IER.GT.0) THEN + CALL CLOSE_BULLFIL + GO TO 9999 + END IF + END IF + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin to SYS_BUL link list + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + IF (ILEN.LT.0) THEN + CALL CLOSE_BULLFIL + GO TO 9999 + END IF + IF (J.LT.NSYS.AND.SEPARATE.NE.' ') THEN + INPUT = ' ' + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + DO I=1,PAGE_WIDTH + INPUT(I:I) = SEPARATE + END DO + CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + NSYS_LINE = NSYS_LINE + 2 + END IF + END DO + CALL CLOSE_BULLFIL + SYS_BUL = SYS_BUL1 + ILEN = 0 + I = 1 + DO WHILE (I.LE.NSYS_LINE.OR.ILEN.GT.0) ! Write out system messages + IF (ILEN.EQ.0) THEN + CALL READ_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) + ILEN = TRIM(INPUT) + I = I + 1 + END IF + IF (SYS_BUL.NE.0) THEN + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN + ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD,! Get terminal input + & 'HIT any key for next page....') + WRITE (6,'(1X)') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) '+'//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) '+'//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + ELSE + PAGE = PAGE + 1 + IF (ILEN.LE.PAGE_WIDTH) THEN + WRITE(6,1060) ' '//INPUT(:ILEN) + ILEN = 0 + ELSE + WRITE(6,1060) ' '//INPUT(:PAGE_WIDTH) + INPUT = INPUT(PAGE_WIDTH+1:) + ILEN = ILEN - PAGE_WIDTH + END IF + END IF + END IF + END DO + IF (NGEN.EQ.0) THEN + WRITE(6,'(A)') ! Write delimiting blank line + END IF + PAGE = PAGE + 1 + END IF + + ENTRY REDISPLAY_DIRECTORY + + GEN_DIR = GEN_DIR1 + IF (NGEN.GT.0) THEN ! Are there new non-system messages? + LENF = TRIM(FOLDER_NAME) + S1 = (PAGE_WIDTH-13-LENF)/2 + S2 = PAGE_WIDTH-S1-13-LENF + IF (PAGE+5+NGEN.GT.PAGE_LENGTH.AND.PAGE.GT.0) THEN + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, ! Get terminal input + & 'HIT any key for next page....') + WRITE (6,'(1X)') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1028) 'New '//FOLDER_NAME(1:LENF)//' messages' + PAGE = 1 + ELSE + IF (FIRST_WRITE) THEN + PAGE = 4 ! Don't erase MAIL/PASSWORD notifies + FIRST_WRITE = .FALSE. ! if this is first write to screen. + END IF + WRITE (6,'(''+'',A,$)') CTRL_G + WRITE(6,1027) 'New '//FOLDER_NAME(1:LENF)//' messages' + PAGE = PAGE + 1 + END IF + WRITE(6,1020) + WRITE(6,1025) + PAGE = PAGE + 2 + I = 0 + DO WHILE (I.LT.NGEN) + I = I + 1 + CALL READ_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) + CALL CONVERT_ENTRY_FROMBIN + N = MAX(INT(LOG10(REAL(SYSTEM)))+1,3) + N1 = MAX(1,6-N) + IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN ! If at end of screen + WRITE(6,1080) ! Ask for input to proceed to next page + CALL GET_INPUT_NOECHO_PROMPT(INREAD, + & 'HIT Q(Quit listing) or any other key for next page....') + CALL STR$UPCASE(INREAD,INREAD) + WRITE (6,'(1X)') + CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + PAGE = 1 + IF (INREAD.EQ.'Q') THEN + I = NGEN ! Quit directory listing + WRITE(6,'(''+Quitting directory listing.'')') + ELSE + WRITE(6,1040) '+'//DESCRIP(:53),FROM,DATE(:6),SYSTEM + END IF + ! Bulletin number is stored in SYSTEM + ELSE + PAGE = PAGE + 1 + WRITE(6,1040) ' '//DESCRIP(:53),FROM,DATE(:6),SYSTEM + END IF + END DO + IF ((.NOT.FOLDER_SET.AND.BTEST(SET_FLAG(1),0).AND.DIFF1.LE.0) + & .OR.(FOLDER_SET.AND.TEST_SET_FLAG(FOLDER_NUMBER))) THEN + PAGE = 0 ! Don't reset page counter if READNEW not set, + END IF ! as no prompt to read is generated. + END IF +C +C Instruct users how to read displayed messages if READNEW not selected. +C + IF (.NOT.TEST_BRIEF_FLAG(FOLDER_NUMBER).AND. + & TEST_SET_FLAG(FOLDER_NUMBER)) THEN + WRITE(6,1030) + ELSE IF (NGEN.EQ.0) THEN + ILEN = 57 + INDEX(COMMAND_PROMPT,'>') - 1 + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-57)// + & '/SYSTEM command can be used to reread these messages.' + ELSE + FLEN = TRIM(FOLDER_NAME) + IF (FOLDER_NUMBER.EQ.0) FLEN = -1 + ILEN = 30 + INDEX(COMMAND_PROMPT,'>') - 1 + FLEN + S1 = (PAGE_WIDTH-ILEN)/2 + S2 = PAGE_WIDTH - S1 - ILEN + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE(6,1035) 'Type ' //COMMAND_PROMPT(:ILEN-29)// + & ' to read these messages.' + ELSE + WRITE(6,1035) 'Type '//COMMAND_PROMPT(:ILEN-30-FLEN) + & //' '//FOLDER_NAME(:FLEN)// + & ' to read these messages.' + END IF + END IF + +9999 IF (LOGIN_SWITCH) THEN + CALL COPY2(LOGIN_BTIM,LOGIN_BTIM_NEW) + CALL COPY2(LOGIN_BTIM_SAVE,LOGIN_BTIM_OLD) + END IF + RETURN + +1020 FORMAT(' Description',43X,'From',9X,'Date',3X,'Number') +1025 FORMAT(' -----------',43X,'----',9X,'----',3X,'------') +1026 FORMAT(' ',('*'),A,' System Messages',('*')) +1027 FORMAT(/,' ',('*'),A,('*')) +1028 FORMAT('+',('*'),A,('*')) +1030 FORMAT(' ',('*')) +1035 FORMAT(' ',('*'),A,('*')) +1040 FORMAT(A<53>,2X,A12,1X,A6,X,I) +1060 FORMAT(A) +1070 FORMAT(' ERROR: Cannot add new entry to user file.') +1080 FORMAT(' ',/) + + END + + + + SUBROUTINE GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,NODE_NAME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + CHARACTER*(*) NODE_NAME + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) + CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) + CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist + + IER = SYS$GETSYIW(,,NODE_NAME(:TRIM(NODE_NAME)), + & %VAL(GETSYI_ITMLST),,,) ! Get Info command. + + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Specified node name not found.'')') + NODE_AREA = 0 + END IF + + RETURN + END + diff --git a/decus/vax91b/gce91b/net91b/bulletin1.for b/decus/vax91b/gce91b/net91b/bulletin1.for new file mode 100644 index 0000000..39ea677 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin1.for @@ -0,0 +1,1925 @@ +C +C BULLETIN1.FOR, Version 7/11/91 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + SUBROUTINE MAIL +C +C SUBROUTINE MAIL +C +C FUNCTION: Sends message which you have read to user via DEC mail. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*64 MAIL_SUBJECT + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + IF (BTEST(CAPTIVE(),1)) THEN + WRITE (6,'('' ERROR: MAIL invalid from DISMAIL account.'')') + RETURN + END IF + + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + MAIL_SUBJECT = DESCRIP + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',MAIL_SUBJECT,LEN_D) + IF (LEN_D.GT.LEN(MAIL_SUBJECT)-2) THEN + WRITE(6,'('' ERROR: Subject limit is 64 characters.'')') + RETURN + END IF + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL CLOSE_BULLDIR + + IF (CLI$PRESENT('EDIT')) THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + END IF + + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Error in opening scratch file.'')') + RETURN + END IF + + IF (CLI$PRESENT('HEADER')) THEN ! Printout header? + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + IF (REMOTE_SET.NE.3) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5) + END IF + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + WRITE (3,'(A)') INPUT(:TRIM(INPUT)) + END IF + + HEAD = CLI$PRESENT('HEADER') + + CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) WRITE(3,1060) INPUT(7:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(3,1060) FROM + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Message copy completed + + CALL CLOSE_BULLFIL + + LEN_D = TRIM(MAIL_SUBJECT) + IF (LEN_D.EQ.0) THEN + MAIL_SUBJECT = 'BULLETIN message.' + LEN_D = TRIM(MAIL_SUBJECT) + END IF + + I = 1 + DO WHILE (I.LE.LEN_D) + IF (MAIL_SUBJECT(I:I).EQ.'"') THEN + IF (LEN_D.EQ.64) THEN + MAIL_SUBJECT(I:I) = '`' + ELSE + MAIL_SUBJECT = MAIL_SUBJECT(:I)//'"'//MAIL_SUBJECT(I+1:) + I = I + 1 + LEN_D = LEN_D + 1 + END IF + END IF + I = I + 1 + END DO + + LEN_P = 0 + DO WHILE (CLI$GET_VALUE('RECIPIENTS',BULL_PARAMETER(LEN_P+1:),I) + & .NE.%LOC(CLI$_ABSENT)) ! Get all the usernames + LEN_P = LEN_P + I + 1 + BULL_PARAMETER(LEN_P:LEN_P) = ',' + END DO + LEN_P = LEN_P - 1 + + I = 1 ! Must change all " to """ in MAIL recipients + DO WHILE (I.LE.LEN_P) + IF (BULL_PARAMETER(I:I).EQ.'"') THEN + BULL_PARAMETER = BULL_PARAMETER(:I)//'""'// + & BULL_PARAMETER(I+1:) + I = I + 2 + LEN_P = LEN_P + 2 + END IF + I = I + 1 + END DO + + IF (CLI$PRESENT('EDIT')) THEN + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + CONTEXT = 0 + IER = LIB$FIND_FILE('SYS$LOGIN:BULL.SCR',INPUT,CONTEXT) + VERSION = INDEX(INPUT,';') + 1 + IF (INPUT(VERSION:VERSION).EQ.'1') THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + WRITE (6,'('' ERROR: No message mailed.'')') + RETURN + END IF + END IF + + CALL DISABLE_PRIVS + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR '//BULL_PARAMETER(:LEN_P) + & //'/SUBJECT="'//MAIL_SUBJECT(:LEN_D)//'"',,,,,,STATUS) + CALL ENABLE_PRIVS + + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR') + + RETURN + +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A) + + END + + + + SUBROUTINE MODIFY_FOLDER +C +C SUBROUTINE MODIFY_FOLDER +C +C FUNCTION: Modifies a folder's information. +C + IMPLICIT INTEGER (A - Z) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER PASSWORD*31,DEFAULT_USER*12 + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + RETURN + ELSE IF (.NOT.FOLDER_ACCESS + & (USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE (6,'('' ERROR: No privileges to modify folder.'')') + RETURN + END IF + + IF (CLI$PRESENT('NAME')) THEN + IF (REMOTE_SET) THEN + WRITE (6,'('' ERROR: Cannot change name of'', + & '' remote folder.'')') + RETURN + ELSE + CALL CLI$GET_VALUE('NAME',FOLDER1,LEN_P) + IF (LEN_P.GT.25) THEN + WRITE (6,'('' ERROR: Folder name cannot be larger + & than 25 characters.'')') + RETURN + END IF + END IF + ELSE + FOLDER1 = FOLDER + END IF + + IF (CLI$PRESENT('DESCRIPTION')) THEN + WRITE (6,'('' Enter one line description of folder.'')') + LENF = 81 + DO WHILE (LENF.GT.80) + CALL GET_LINE(FOLDER1_DESCRIP,LENF) ! Get input line + IF (LENF.LE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + RETURN + ELSE IF (LENF.GT.80) THEN ! If too many characters + WRITE (6,'('' ERROR: Description must be < 80 characters.'')') + ELSE + FOLDER1_DESCRIP = FOLDER1_DESCRIP(:LENF) ! End fill with spaces + END IF + END DO + ELSE + FOLDER1_DESCRIP = FOLDER_DESCRIP + END IF + + IF (CLI$PRESENT('OWNER')) THEN + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + IF (LEN_P.GT.12) THEN + WRITE (6,'('' ERROR: Owner name must be < 13 characters.'')') + RETURN + ELSE IF (CLI$PRESENT('ID')) THEN + IER = CHKPRO(FOLDER1_OWNER) + ELSE + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + END IF + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner name is not valid username.'')') + RETURN + ELSE IF (LEN_P.GT.LEN(FOLDER1_OWNER)) THEN + WRITE (6,'('' ERROR: Folder owner name too long.'')') + RETURN + ELSE IF (.NOT.SETPRV_PRIV()) THEN + WRITE(6,'('' Enter password of new owner: '',A)') CHAR(10) + CALL GET_INPUT_NOECHO(PASSWORD) + IF (TRIM(PASSWORD).EQ.0) THEN + WRITE (6,'('' ERROR: No password entered.'')') + RETURN + END IF + WRITE (6,'('' Attempting to verify password name...'')') + OPEN (UNIT=10,NAME='SYS$NODE"'// + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + & //' '//PASSWORD(:TRIM(PASSWORD))//'"::', + & TYPE='SCRATCH',IOSTAT=IER) + CLOSE (UNIT=10) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Password is invalid.'')') + RETURN + ELSE + WRITE (6,'('' Password was verified.'')') + END IF + ELSE + FOLDER1_OWNER = FOLDER1_OWNER(:LEN_P) + END IF + ELSE + FOLDER1_OWNER = FOLDER_OWNER + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + + IF (CLI$PRESENT('NAME')) THEN + READ (7,IOSTAT=IER,KEY=FOLDER1,KEYID=0) + ! See if folder exists + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder name already exists.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + END IF + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (IER.EQ.0.AND.CLI$PRESENT('NAME')) THEN + LEN_F = TRIM(FOLDER_DIRECTORY) + IER = LIB$RENAME_FILE(FOLDER_DIRECTORY(:LEN_F)// + & FOLDER(:TRIM(FOLDER))//'.*',FOLDER_DIRECTORY(:LEN_F)// + & FOLDER1(:TRIM(FOLDER1))//'.*') + IF (IER) THEN + IER = 0 + FOLDER_FILE = FOLDER_DIRECTORY(:LEN_F)//FOLDER1 + END IF + END IF + + IF (IER.EQ.0) THEN + IF (CLI$PRESENT('OWNER')) THEN + CALL CHKACL + & (FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + CALL DEL_ACL(FOLDER_OWNER,'R+W+C',IER) + END IF + END IF + FOLDER = FOLDER1 + FOLDER_OWNER = FOLDER1_OWNER + FOLDER_DESCRIP = FOLDER1_DESCRIP + DELETE (7) + IF (CLI$PRESENT('ID')) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,6) + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,6) + END IF + CALL WRITE_FOLDER_FILE(IER) + IF (IER.EQ.0) WRITE (6,'('' Folder successfully modified.'')') + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder modification aborted.'')') + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + FUNCTION FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME,FOLDER_OWNER + + IF (SETPRV_PRIV()) THEN + FOLDER_ACCESS = .TRUE. + ELSE IF (BTEST(FOLDER_FLAG,6)) THEN ! If folder owner is ID + FOLDER_ACCESS = CHKPRO(FOLDER_OWNER) + ELSE + FOLDER_ACCESS = USERNAME.EQ.FOLDER_OWNER + END IF + + RETURN + END + + + + SUBROUTINE MOVE(DELETE_ORIGINAL) +C +C SUBROUTINE MOVE +C +C FUNCTION: Moves message from one folder to another. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /HEADER/ HEADER + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + EXTERNAL CLI$_ABSENT,BULLETIN_SUBCOMMANDS + + LOGICAL DELETE_ORIGINAL + + CHARACTER SAVE_FOLDER*25,POST_SUBJECT*255 + + IF (CLI$PRESENT('ORIGINAL').AND..NOT.SETPRV_PRIV()) THEN + WRITE (6, + & '('' ERROR: You have no privileges to keep original owner.'')') + RETURN + END IF + + ALL = CLI$PRESENT('ALL') + + MERGE = CLI$PRESENT('MERGE') + + SAVE_BULL_POINT = BULL_POINT + + IER1 = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER1.EQ.%LOC(CLI$_ABSENT).AND..NOT.ALL) THEN + IF (BULL_POINT.EQ.0) THEN ! If no message has been read + WRITE(6,'('' ERROR: You are not reading any message.'')') + RETURN ! and return + END IF + + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) ! Get message directory entry + IF (IER.NE.BULL_POINT+1) THEN ! Was message found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + NUM_COPY = 1 + ELSE + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) ! Get message directory entry + IF (NBULL.EQ.0) THEN ! Were messages found? + WRITE(6,'('' ERROR: No messages were found.'')') + CALL CLOSE_BULLDIR + RETURN + END IF + + IF (IER1.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER1) + IF (EBULL.GT.F_NBULL) EBULL = F_NBULL + IF (SBULL.LE.0.OR.IER1.NE.0) THEN + WRITE (6,'(A)') + & ' ERROR: Specified message number has incorrect format.' + CALL CLOSE_BULLDIR + RETURN + ELSE + NUM_COPY = EBULL - SBULL + 1 + BULL_POINT = SBULL + END IF + IF (NUM_COPY.GT.1) ALL = .TRUE. + ELSE IF (CLI$PRESENT('ALL')) THEN + NUM_COPY = NBULL + BULL_POINT = 1 + END IF + END IF + + FROM_REMOTE = REMOTE_SET + + IF (REMOTE_SET) THEN + OPEN (UNIT=12,FILE='REMOTE.BULLDIR', + & STATUS='SCRATCH',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.0) THEN + OPEN (UNIT=11,FILE='REMOTE.BULLFIL', + & STATUS='SCRATCH',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END IF + IF (IER.EQ.0) THEN + CALL OPEN_BULLFIL + CALL READDIR(0,IER) + IF (IER.EQ.1) WRITE (12,IOSTAT=IER1) BULLDIR_HEADER + I = BULL_POINT - 1 + IER = I + 1 + NBLOCK = 1 + LAST = BULL_POINT+NUM_COPY-1 + NUM_COPY = 0 + DO WHILE (I.LT.LAST.AND.IER.EQ.I+1) + I = I + 1 + I1 = I + CALL READDIR(I,IER) + IF ((I1.EQ.BULL_POINT.AND.I1.NE.I) + & .AND..NOT.CLI$PRESENT('ALL')) THEN + WRITE(6,'('' ERROR: Message not found: '',I)') I1 + CLOSE (UNIT=11) + CLOSE (UNIT=12) + CALL CLOSE_BULLDIR + CALL CLOSE_BULLFIL + RETURN + END IF + IF (IER.EQ.I+1.AND.I.LE.LAST) THEN + BLOCK = NBLOCK + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL REMOTE_READ_MESSAGE(I,IER1) + IF (IER1.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER1) + END IF + IF (LENGTH.EQ.0) IER = 1 ! Don't allow empty messages + IF (IER1.EQ.0) THEN + SCRATCH_R = SCRATCH_R1 + DO J=1,LENGTH + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT(:128)) + WRITE (11'NBLOCK,IOSTAT=IER1) INPUT(:128) + IF (IER1.EQ.0) NBLOCK = NBLOCK + 1 + END DO + END IF + IF (IER1.EQ.0) WRITE (12,IOSTAT=IER1) BULLDIR_ENTRY + IF (IER1.NE.0) THEN + I = IER + ELSE + NUM_COPY = NUM_COPY + 1 + END IF + END IF + END DO + END IF + CALL CLOSE_BULLFIL + IF (IER1.NE.0) THEN + WRITE(6,'('' ERROR: Copy aborted. Remote folder problem.'')') + CLOSE (UNIT=11) + CLOSE (UNIT=12) + CALL CLOSE_BULLDIR + RETURN + END IF + END IF + + CALL CLOSE_BULLDIR + + SAVE_FOLDER = FOLDER + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + CALL CLI$GET_VALUE('FOLDER',FOLDER1) + + FOLDER_NUMBER = -1 ! Use FOLDER as key rather than FOLDER_NUMBER + CALL SELECT_FOLDER(.FALSE.,IER) + + IER1 = .TRUE. + + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Cannot access specified folder.'')') + ELSE IF (READ_ONLY.OR.(MERGE.AND.REMOTE_SET.GT.0)) THEN + IF (READ_ONLY) THEN + WRITE (6,'('' ERROR: No access to write into folder.'')') + ELSE + WRITE (6,'('' ERROR: /MERGE invalid into remote folder.'')') + END IF + IER1 = .FALSE. + ELSE IF (REMOTE_SET.EQ.4) THEN + IF (CLI$PRESENT('ORIGINAL')) THEN + REMOTE_SET = 0 + ELSE + SLIST = INDEX(FOLDER_DESCRIP,'<') + FOLDER1_DESCRIP = + & FOLDER_DESCRIP(SLIST+1:TRIM(FOLDER_DESCRIP)-1) + IF (FOLDER1_DESCRIP(1:1).EQ.'@') THEN + WRITE(6,'('' ERROR: Multiple newsgroup feed'', + & '' is present.'')') + IER1 = .FALSE. + END IF + END IF + END IF + + IF (.NOT.IER.OR..NOT.IER1) THEN + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + IF (.NOT.IER) THEN + FOLDER = SAVE_FOLDER + BULL_POINT = SAVE_BULL_POINT + ELSE + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + END IF + BULL_POINT = SAVE_BULL_POINT + CLOSE (UNIT=11) + CLOSE (UNIT=12) + RETURN + END IF +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + IF (REMOTE_SET.GE.3) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='SCRATCH',CARRIAGECONTROL='LIST') + ELSE + CALL OPEN_BULLDIR ! Prepare to add dir entry + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + CALL READDIR(0,IER) ! Get NBLOCK + IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + END IF + + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //SAVE_FOLDER + + IF (.NOT.FROM_REMOTE) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=12,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER.EQ.0) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=11,FILE=FOLDER1_FILE(:TRIM(FOLDER1_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + END DO + END IF + ELSE + IER= 0 + END IF + + IF (REMOTE_SET.GE.3) THEN + SAVE_HEADER = HEADER + IF (CLI$PRESENT('HEADER')) THEN + HEADER = .TRUE. + ELSE + HEADER = .FALSE. + END IF + END IF + + IF (MERGE) CALL INITIALIZE_MERGE(IER) + + START_BULL_POINT = BULL_POINT + + IF (IER.EQ.0) THEN + IF (FROM_REMOTE) THEN + READ (12,KEYID=0,KEY=0,IOSTAT=IER) + ELSE + READ (12,KEYID=0,KEY=BULL_POINT-1,IOSTAT=IER) + END IF + END IF + + DO WHILE (NUM_COPY.GT.0.AND.IER.EQ.0) + READ (12,IOSTAT=IER) BULLDIR_ENTRY + NUM_COPY = NUM_COPY - 1 + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + + IF (REMOTE_SET.GE.3) SYSTEM = 0 + + IF (FROM_REMOTE.EQ.3) THEN + SYSTEM = 0 + IF (FOLDER_BBEXPIRE.GT.0) THEN + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + ELSE IF (FOLDER_BBEXPIRE.EQ.-1) THEN ! Permanent message + EXDATE = '5-NOV-2000' + SYSTEM = 2 + ELSE IF (EX_BTIM(1).EQ.0.AND.EX_BTIM(2).EQ.0) THEN + CALL GET_EXDATE(EXDATE,14) + END IF + END IF + + IF (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV()) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,0) ! Remove system bit + END IF + + IF (BTEST(SYSTEM,2).AND. ! Shutdown message? + & (.NOT.BTEST(FOLDER_FLAG,2).OR. ! Not system folder? + & .NOT.SETPRV_PRIV())) THEN ! Or no privileges? + SYSTEM = IBCLR(SYSTEM,2) ! Remove shutdown bit + WRITE (6,'('' ERROR: No privileges to add'', + & '' shutdown message.'')') + IF (FOLDER_BBEXPIRE.GT.0) THEN + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + WRITE (6,'('' Expiration will be '',I,'' days.'')') + & FOLDER_BBEXPIRE + ELSE + CALL GET_EXDATE(EXDATE,14) + WRITE (6,'('' Expiration will be '',I,'' days.'')') 14 + END IF + EXTIME = '00:00:00.00' + ELSE IF (BTEST(SYSTEM,1).AND. ! Permanent? + & F_EXPIRE_LIMIT.GT.0.AND..NOT. ! Expiration limit present? + & FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE (6,'('' ERROR: No privileges to add'', + & '' permanent message.'')') + WRITE (6,'('' Expiration will be '',I,'' days.'')') + & F_EXPIRE_LIMIT + SYSTEM = IBCLR(SYSTEM,1) + CALL GET_EXDATE(EXDATE,F_EXPIRE_LIMIT) + EXTIME = '00:00:00.00' + END IF + + IF (.NOT.CLI$PRESENT('ORIGINAL')) THEN ! If not /ORIGINAL + FROM = USERNAME ! Specify owner + END IF + + IF (REMOTE_SET.EQ.1) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + IF (IER.NE.0) CALL ERROR_AND_EXIT + ELSE IF (REMOTE_SET.GE.3) THEN + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + POST_SUBJECT = INPUT(7:ILEN) + ELSE + POST_SUBJECT = DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) + END DO + + REWIND (UNIT=3) + + CALL NEWS_POST('SYS$LOGIN:BULL.SCR',.TRUE.,IER,POST_SUBJECT) + END IF + + IF (REMOTE_SET.LT.3) THEN + IF (MERGE) CALL ADD_MERGE_TO(IER) + + IF (IER.EQ.0) THEN + NBLOCK = NBLOCK + 1 + + DO I=BLOCK,BLOCK+LENGTH-1 + READ (11'I,IOSTAT=IER) INPUT(:128) + IF (IER.EQ.0) THEN + CALL WRITE_BULL_FILE(NBLOCK,INPUT(:128)) + END IF + NBLOCK = NBLOCK + 1 + END DO + END IF + + IF (IER.EQ.0) THEN + IF (MERGE) THEN + CALL ADD_MERGE_FROM(IER) + ELSE IF (FROM_REMOTE) THEN + CALL ADD_ENTRY + ELSE + CALL ADD_ENTRY ! Add the new directory entry + END IF + BULL_POINT = BULL_POINT + 1 + END IF + END IF + END DO + + IF (REMOTE_SET.GE.3) CLOSE (UNIT=3) + + IF (MERGE) CALL ADD_MERGE_REST(IER) + + IF (REMOTE_SET.LT.3) CALL CLOSE_BULLFIL + + CLOSE (UNIT=11) + + CLOSE (UNIT=12) + + IF (FOLDER_NUMBER.GE.0.AND.IER.EQ.0.AND.REMOTE_SET.LT.3) THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + CALL UPDATE_FOLDER ! Update folder info +C +C If user is adding message, an no new messages, update last read time for +C folder, so user is not alerted of new message which is owned by user. +C + IF (DIFF.GE.0) THEN + CALL COPY2(LAST_READ_BTIM(1,FOLDER_NUMBER+1),F_NEWEST_BTIM) + END IF + END IF + + IF (REMOTE_SET.LT.3) CALL CLOSE_BULLDIR ! Totally finished with add + + IF (IER.EQ.0) THEN + WRITE (6,'('' Successful copy to folder '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + IF (MERGE) THEN + CALL LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END IF + ELSE IF (MERGE) THEN + WRITE (6,'('' ERROR: Copy aborted. No files copied.'')') + ELSE + WRITE (6,'('' ERROR: Copy aborted. '',I,'' files copied.'')') + & BULL_POINT - START_BULL_POINT + END IF + + IF (REMOTE_SET.LT.3) HEADER = SAVE_HEADER + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + FOLDER1 = SAVE_FOLDER + CALL SELECT_FOLDER(.FALSE.,IER1) + + BULL_POINT = SAVE_BULL_POINT + + IF (DELETE_ORIGINAL.AND.IER.EQ.0) THEN + IF (FROM_REMOTE.AND.ALL) THEN + WRITE (6,'('' WARNING: Original messages not deleted.'')') + WRITE (6,'('' Multiple deletions not possible for '', + & ''remote folders.'')') + ELSE + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + CALL DELETE_MSG + END IF + END IF + + RETURN + END + + + + + SUBROUTINE PRINT(PRINT_NUM,OPEN_IT) +C +C SUBROUTINE PRINT +C +C FUNCTION: Print header to queue. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SJCDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL CLI$_ABSENT + + CHARACTER*32 QUEUE + + INTEGER*2 FILE_ID(14) + INTEGER*2 IOSB(4) + EQUIVALENCE (IOSB(1),JBC_ERROR) + + CHARACTER*31 FORM + + PARAMETER FF = CHAR(12) + + DATA FIRST /.TRUE./ + + IF (CLI$PRESENT('NOW').AND..NOT.FIRST.AND. + & INCMD(:4).EQ.'PRIN') THEN + WRITE (6,'('' Printing all previously queued messages.'')') + GO TO 200 + END IF + + IF (PRINT_NUM.EQ.0) THEN + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + IF (EBULL.GT.F_NBULL) EBULL = F_NBULL + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = F_NBULL + IER = 0 + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE + SBULL = BULL_POINT + EBULL = SBULL + IER = 0 + END IF + IF (SBULL.LE.0.OR.IER.NE.0) THEN + WRITE (6,1015) + RETURN + END IF + ELSE + SBULL = PRINT_NUM + EBULL = SBULL + END IF + + IF (FIRST) THEN + QLEN = 0 + IER = CLI$GET_VALUE('QUEUE',QUEUE,QLEN) ! Get queue name + IF (QLEN.EQ.0) THEN + QUEUE = 'SYS$PRINT' + QLEN = TRIM(QUEUE) + END IF + + NOTIFY = CLI$PRESENT('NOTIFY') + + FLEN = 0 + IER = CLI$GET_VALUE('FORM',FORM,FLEN) ! Get form name + + CALL DISABLE_PRIVS + + OPEN(UNIT=24,FILE='SYS$LOGIN:BULL.LIS',ERR=900,IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + CALL ENABLE_PRIVS + END IF + + IF (OPEN_IT) THEN + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED + END IF + + HEAD = CLI$PRESENT('HEADER') + + DO I=SBULL,EBULL + I1 = I + CALL READDIR(I,IER) ! Get info for specified message + IF (IER.NE.I+1.OR.I.GT.EBULL.OR.(.NOT.CLI$PRESENT + & ('ALL').AND.I1.EQ.SBULL.AND.I.NE.SBULL)) THEN + IF (REMOTE_SET.NE.3.OR.I1.EQ.SBULL) WRITE(6,1030) I1 + IF (I1.GT.SBULL) GO TO 100 + CLOSE (UNIT=24,STATUS='DELETE') + IF (OPEN_IT) THEN + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + END IF + RETURN + ELSE IF (REMOTE_SET) THEN + CALL REMOTE_READ_MESSAGE(I,IER1) + IF (IER1.GT.0) THEN + CALL DISCONNECT_REMOTE + ELSE + CALL GET_REMOTE_MESSAGE(IER1) + END IF + IF (IER1.NE.0) GO TO 100 + END IF + + IF (.NOT.FIRST) THEN + WRITE (24,'(A)') FF + ELSE + FIRST = .FALSE. + END IF + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + IF (HEAD) THEN + WRITE(24,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (HEAD) THEN + WRITE(24,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (HEAD) WRITE(24,1050) INPUT(7:ILEN) + ELSE + IF (HEAD) WRITE(24,1050) DESCRIP + IF (ILEN.GT.0) WRITE (24,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (24,'(A)') INPUT(1:ILEN) + END DO + END DO + +100 IF (OPEN_IT) THEN + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + END IF + + IF (.NOT.CLI$PRESENT('NOW').OR.INCMD(:4).NE.'PRIN') RETURN + + ENTRY PRINT_NOW + +200 IF (FIRST) RETURN + + FIRST = .TRUE. + + CLOSE (UNIT=24) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(18,SJC$_FILE_SPECIFICATION, + & %LOC('SYS$LOGIN:BULL.LIS')) + + CALL ADD_2_ITMLST(QLEN,SJC$_QUEUE,%LOC(QUEUE)) + CALL ADD_2_ITMLST(0,SJC$_DELETE_FILE,0) + + IF (NOTIFY) CALL ADD_2_ITMLST(0,SJC$_NOTIFY,0) + + IF (FLEN.GT.0) THEN + CALL ADD_2_ITMLST(FLEN,SJC$_FORM_NAME,%LOC(FORM)) + END IF + + CALL DISABLE_PRIVS + + CALL ADD_2_ITMLST(4,SJC$_ENTRY_NUMBER_OUTPUT,%LOC(JOBNUM)) + + CALL END_ITMLST(SJC_ITMLST) + + IER=SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SJC_ITMLST),IOSB,,) + IF (IER.AND.(.NOT.JBC_ERROR)) THEN + CALL SYS_GETMSG(JBC_ERROR) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + ELSE IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.LIS;') + ELSE + IER = OTS$CVT_L_TI(JOBNUM,BULL_PARAMETER,,,) + IF (IER) WRITE (6,'('' Job BULL (queue '',A,'', entry '',A, + & '') started on '',A)') QUEUE(:QLEN), + & BULL_PARAMETER(FIRST_ALPHA(BULL_PARAMETER):),QUEUE(:QLEN) + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + RETURN + +900 CALL ERRSNS(IDUMMY,IER) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + WRITE(6,1000) + CALL SYS_GETMSG(IER) + RETURN + +1000 FORMAT(' ERROR: Unable to open temporary file + & SYS$LOGIN:BULL.LIS for printing.') +1010 FORMAT(' ERROR: You have not read any message.') +1015 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Following bulletin was not found: ',I) +1050 FORMAT('Description: ',A,/) +1060 FORMAT('From: ',A,/,'Date: ',A) + + END + + + + + SUBROUTINE READ_MSG(READ_COUNT,BULL_READ) +C +C SUBROUTINE READ_MSG +C +C FUNCTION: Reads a specified bulletin. +C +C PARAMETER: +C READ_COUNT - Variable to store the record in the message file +C that READ will read from. Must be set to 0 to indicate +C that it is the first read of the message. If -1, +C READ will search for the last message in the message file +C and read that one. If -2, just display header information. +C BULL_READ - Message number to be read. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /PAGE/ PAGE_LENGTH,REAL_PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + COMMON /HEADER/ HEADER + + COMMON /NEXT/ NEXT + LOGICAL NEXT /.FALSE./ + + DATA SCRATCH_B1/0/ + + CHARACTER TODAY*11,DATETIME*23,BUFFER*(LINE_LENGTH) + CHARACTER HEADLINE*132 + + LOGICAL SINCE,PAGE + + EXTERNAL CLI$_NEGATED + + CALL LIB$ERASE_PAGE(1,1) ! Clear screen + END = 0 ! Nothing outputted on screen + + IF (READ_COUNT.GT.0) GO TO 100 ! Skip init steps if this is + ! not first page of bulletin + + IF (INCMD(:4).EQ.'READ'.OR.INCMD(:4).EQ.'LAST'.OR. + & INCMD(:4).EQ.'BACK'.OR.INCMD(:3).EQ.'CUR'.OR. + & INCMD(:4).EQ.'FIRS') THEN + IF (CLI$PRESENT('HEADER')) THEN + HEADER = .TRUE. + ELSE IF (CLI$PRESENT('HEADER').EQ.%LOC(CLI$_NEGATED)) THEN + HEADER = .FALSE. + END IF + END IF + + SINCE = .FALSE. + NEW = .FALSE. + PAGE = .TRUE. + + IER = 0 + + IF (.NOT.PAGING) PAGE = .FALSE. + IF (INCMD(:4).EQ.'READ') THEN ! If READ command... + IF (CLI$PRESENT('MARKED')) THEN + READ_TAG = 1 + IBSET(0,1) + ELSE IF (CLI$PRESENT('SEEN')) THEN + READ_TAG = 1 + IBSET(0,2) + ELSE IF (CLI$PRESENT('UNMARKED').OR. + & CLI$PRESENT('MARKED').EQ.%LOC(CLI$_NEGATED)) THEN + READ_TAG = 1 + IBSET(0,1) + IBSET(0,3) + ELSE IF (CLI$PRESENT('UNSEEN').OR. + & CLI$PRESENT('SEEN').EQ.%LOC(CLI$_NEGATED)) THEN + READ_TAG = 1 + IBSET(0,2) + IBSET(0,3) + ELSE IF (CLI$PRESENT('ALL')) THEN + READ_TAG = IBSET(0,1) + IBSET(0,2) + IF (REMOTE_SET.EQ.3) THEN + BULL_READ = F_START + ELSE + BULL_READ = 1 + END IF + END IF + IF (READ_TAG) THEN + IF (.NOT.(FOLDER_NUMBER.GE.0.OR.REMOTE_SET.EQ.3)) THEN + WRITE (6,'('' ERROR: Invalid qualifier'', + & '' with remote folder.'')') + READ_TAG = 1 + IBSET(0,2) + IBSET(0,3) + RETURN + END IF + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER1,BULL_POINT) + END IF + + IF (.NOT.CLI$PRESENT('PAGE')) PAGE = .FALSE. + IF (CLI$PRESENT('SINCE')) THEN ! was /SINCE specified? + IER = CLI$GET_VALUE('SINCE',DATETIME) + IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. + IER = SYS$BINTIM('-- 00:00:00.00',TODAY) + CALL GET_MSGKEY(TODAY,MSG_KEY) + ELSE + CALL SYS_BINTIM(DATETIME,MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + END IF + CALL OPEN_BULLDIR_SHARED + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? + NEW = .TRUE. + IF (REMOTE_SET.NE.3) THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.GE.0) THEN + WRITE (6,'('' No new messages are present.'')') + RETURN + ELSE + CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & MSG_KEY) + END IF + CALL OPEN_BULLDIR_SHARED + CALL READDIR_KEYGE(IER) + CALL CLOSE_BULLDIR + ELSE + CALL NEWS_GET_NEWEST_MESSAGE(IER) + IF (IER.EQ.0) THEN + WRITE (6,'('' No new messages are present.'')') + RETURN + END IF + END IF + BULL_READ = IER + IER = IER + 1 + END IF + IF (CLI$PRESENT('SINCE')) THEN + IF (IER.EQ.0) THEN + WRITE (6,'('' No messages past specified date.'')') + RETURN + ELSE + BULL_READ = IER + IER = IER + 1 + END IF + SINCE = .TRUE. + END IF + END IF + + NEXT = .FALSE. + IF (INCMD(:1).EQ.'N'.OR.INCMD.EQ.' ') THEN + NEXT = .TRUE. + ELSE IF (INCMD(:4).EQ.'READ'.AND..NOT.SINCE.AND..NOT.NEW + & .AND..NOT.CLI$PRESENT('BULLETIN_NUMBER') + & .AND..NOT.CLI$PRESENT('ALL')) THEN + NEXT = .TRUE. + END IF + + IF (READ_TAG) THEN + IER = 0 + IF ((INCMD(:4).EQ.'BACK'.AND.REMOTE_SET.EQ.3).OR. + & (INCMD(:4).EQ.'LAST'.AND.BTEST(READ_TAG,3))) THEN + IF (BULL_POINT.EQ.0.OR.INCMD(:4).EQ.'LAST') THEN + MSG_NUM = F_NBULL+1 + ELSE + MSG_NUM = BULL_POINT + END IF + CALL GET_PREVIOUS_TAG(FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + IF (IER1.EQ.0) IER = BULL_READ + 1 + ELSE IF (INCMD(:4).EQ.'BACK') THEN + CALL OPEN_BULLDIR_SHARED + CALL GET_PREVIOUS_TAG(FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + CALL CLOSE_BULLDIR + IF (IER1.EQ.0) IER = BULL_READ + 1 + ELSE IF (INCMD(:4).EQ.'LAST') THEN + CALL OPEN_BULLDIR_SHARED + IF (BULL_POINT.GT.0) THEN + CALL READDIR(BULL_POINT,IER) + IF (IER.NE.BULL_POINT+1) THEN + BULL_POINT = 0 + ELSE + CALL GET_THIS_OR_NEXT_TAG + & (FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + IF (IER1.NE.0) BULL_POINT = 0 + END IF + END IF + IF (BULL_POINT.EQ.0) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + IF (IER1.EQ.0) IER = BULL_READ + 1 + END IF + DO WHILE (IER1.EQ.0) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + IF (IER1.EQ.0) IER = BULL_READ + 1 + END DO + CALL CLOSE_BULLDIR + ELSE IF (INCMD(:4).EQ.'FIRS') THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + IF (IER1.EQ.0) IER = BULL_READ + 1 + ELSE IF (NEXT.OR.SINCE.OR.NEW) THEN + OLD_NEXT = NEXT + NEXT = .FALSE. + IF (NEW) MSG_NUM = BULL_READ + IF (.NOT.OLD_NEXT) THEN + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + ELSE + IF (REMOTE_SET.EQ.3) THEN + MSG_NUM = BULL_POINT + ELSE IF (BULL_POINT.GT.0) THEN + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) + CALL CLOSE_BULLDIR + ELSE + MSG_KEY = BULLDIR_HEADER + MSG_NUM = 0 + END IF + CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + END IF + NEXT = OLD_NEXT + IF (IER1.EQ.0) THEN + IER = BULL_READ + 1 + ELSE + IER = 0 + END IF + END IF + END IF + + IF (.NOT.SINCE.AND.(.NOT.READ_TAG.OR.(.NOT.NEXT.AND. + & INCMD(:4).NE.'LAST'.AND.INCMD(:4).NE.'BACK'.AND. + & INCMD(:4).NE.'FIRS'))) THEN + IF (BULL_READ.GT.0) THEN ! Valid bulletin number? + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_READ,IER) ! Get bulletin directory entry + IF (IER.NE.BULL_READ+1.AND.REMOTE_SET.EQ.3 + & .AND.INCMD(:4).EQ.'READ') THEN + IF (NEW) THEN + NEXT = .TRUE. + CALL READDIR(BULL_READ,IER) + END IF + END IF + IF (REMOTE_SET.NE.3.AND. + & READ_COUNT.EQ.-1.AND.IER.NE.BULL_READ+1) THEN + READ_COUNT = 0 + IF (IER.NE.BULL_READ+1) THEN + CALL READDIR(0,IER) + IF (NBULL.GT.0) THEN + BULL_READ = NBULL + CALL READDIR(BULL_READ,IER) + ELSE + IER = 0 + END IF + END IF + ELSE IF (READ_TAG.AND.IER.EQ.BULL_READ+1) THEN + CALL GET_THIS_TAG(FOLDER_NUMBER,IER1,BULL_READ,DUMMY) + IF (IER1.NE.0) IER = 0 + END IF + CALL CLOSE_BULLDIR + ELSE + IER = 0 + END IF + END IF + + NEXT = .FALSE. + + IF (IER.NE.BULL_READ+1) THEN ! Was bulletin found? + IF (REMOTE_SET.NE.3) THEN + WRITE(6,1030) ! If not, then error out + ELSE + WRITE(6,1040) + END IF + RETURN + END IF + + IF (REMOTE_SET.NE.3) THEN + DIFF = COMPARE_BTIM(MSG_BTIM,LAST_READ_BTIM(1,FOLDER_NUMBER+1)) + IF (DIFF.GT.0) THEN + CALL COPY2(LAST_READ_BTIM(1,FOLDER_NUMBER+1),MSG_BTIM) + END IF + IF (BULL_TAG.AND.BTEST(BULL_TAG,1)) CALL ADD_TAG(IER,2) + ELSE + CALL NEWS_UPDATE_NEWEST_MESSAGE(BULL_READ) + IF (BULL_NEWS_TAG) CALL ADD_TAG(IER,2) + END IF + + BULL_POINT = BULL_READ ! Update bulletin counter + + EDIT = .FALSE. + + PAGE_WIDTH = REAL_PAGE_WIDTH + + IF (INCMD(:1).NE.' '.AND.READIT.EQ.0) THEN + IF (CLI$PRESENT('EDIT')) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + RETURN + END IF + EDIT = .TRUE. + PAGE_WIDTH = LINE_LENGTH + PAGE = .FALSE. + END IF + END IF + + IF (BULL_POINT.GT.F_NBULL) F_NBULL = BULL_POINT + + IF (REMOTE_SET.EQ.3) THEN + WRITE (HEADLINE,'(1X,I,'' of '',I,''-'',I)') + & BULL_POINT,F_START,F_NBULL + DO WHILE (INDEX(HEADLINE,'- ').GT.0) + I = INDEX(HEADLINE,'- ') + HEADLINE(I+1:) = HEADLINE(I+2:) + END DO + ELSE + WRITE (HEADLINE,'(1X,I,'' of '',I)') BULL_POINT,F_NBULL + END IF + DO WHILE (INDEX(HEADLINE,' ').LT.TRIM(HEADLINE)) + I = INDEX(HEADLINE,' ') + HEADLINE(I:) = HEADLINE(I+1:) + END DO + I = TRIM(HEADLINE) + HEADLINE = ' #'//HEADLINE(2:TRIM(HEADLINE)) + FLEN = TRIM(FOLDER_NAME) + HEADLINE(REAL_PAGE_WIDTH-FLEN+1:) = FOLDER_NAME(:FLEN) + IF (READIT.GT.0) THEN + WRITE(6,'(A)') '+'//HEADLINE(:TRIM(HEADLINE)) + ELSE IF (EDIT) THEN + WRITE(3,'(A)') HEADLINE(:TRIM(HEADLINE)) + ELSE + WRITE(6,'(1X,A)') HEADLINE(:TRIM(HEADLINE)) + END IF + + END = 1 ! Outputted 1 line to screen + + IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN + IF (REMOTE_SET.NE.3) THEN + INPUT = 'Date: '//DATE//' '//TIME(:5)//' (DELETED)' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5) + END IF + ELSE IF ((SYSTEM.AND.4).EQ.4) THEN ! Is entry shutdown bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Expires on shutdown' + ELSE IF ((SYSTEM.AND.2).EQ.2) THEN ! Is entry permanent bulletin? + INPUT = 'Date: '//DATE//' '//TIME(:5)//' Permanent' + ELSE + INPUT = 'Date: '//DATE//' '//TIME(:5)// + & ' Expires: '//EXDATE//' '//EXTIME(:5) + END IF + IF ((SYSTEM.AND.1).EQ.1) THEN ! System bulletin? + INPUT = INPUT(:TRIM(INPUT))//' / System' + END IF + IF (EDIT) THEN + WRITE (3,'(A)') INPUT(:TRIM(INPUT)) + ELSE + WRITE (6,'(1X,A)') INPUT(:TRIM(INPUT)) + END IF + + END = END + 1 + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + LINE_OFFSET = 0 + CHAR_OFFSET = 0 + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INPUT = 'From: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + IF (EDIT) THEN + WRITE(3,'(A)') INPUT(:I) + ELSE + WRITE(6,'(1X,A)') INPUT(:I) + END IF + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = 1 + ELSE + IF (EDIT) THEN + WRITE(3,'(''From: '',A)') FROM + ELSE + WRITE(6,'('' From: '',A)') FROM + END IF + END = END + 1 + END IF + IF (INPUT(:6).NE.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + INPUT = 'Subj: '//INPUT(7:) + DO WHILE (TRIM(INPUT).GT.0) + I = MIN(PAGE_WIDTH,TRIM(INPUT)) + IF (EDIT) THEN + WRITE(3,'(A)') INPUT(:I) + ELSE + WRITE(6,'(1X,A)') INPUT(:I) + END IF + INPUT = INPUT(I+1:) + END = END + 1 + END DO + LINE_OFFSET = LINE_OFFSET + 1 + IF (EDIT) WRITE(3,'(1X)') + ELSE + END = END + 1 + IF (EDIT) THEN + WRITE(3,'(''Subj: '',A)') DESCRIP + WRITE(3,'(1X,/,A)') INPUT(:LEN_TEMP) + ELSE + WRITE(6,'('' Subj: '',A)') DESCRIP + IF (LINE_OFFSET.EQ.1) THEN + CHAR_OFFSET = 1 - PAGE_WIDTH + LINE_OFFSET = 2 + END IF + END IF + END IF + IF (LINE_OFFSET.EQ.0) ILEN = LINE_LENGTH + 1 + CALL CLOSE_BULLFIL ! End of bulletin file read + + IF (EDIT) GO TO 200 + + WRITE(6,'(1X)') + + IF (READIT.GT.0) WRITE(6,'(1X)') + END = END + 1 +C +C Each page of the bulletin is buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C bulletin file, and to avoid the possibility of the user holding the screen, +C and thus causing the bulletin file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_B1 points to the header +C of the queue. See BULLSUBS.FOR for more description of the queue. +C + + IF (SCRATCH_B1.NE.0) THEN ! Is queue empty? + SCRATCH_B = SCRATCH_B1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_B,INPUT) + SCRATCH_B1 = SCRATCH_B ! Init header pointer + END IF + + READ_ALREADY = 0 ! Number of lines already read + ! from record. + IF (READ_COUNT.EQ.-2) THEN ! Just output header first read + READ_COUNT = BLOCK + RETURN + ELSE + READ_COUNT = BLOCK ! Init bulletin record counter + END IF + + GO TO 200 + +100 IF (READIT.EQ.0) THEN ! If not 1st page of READ + WRITE(6,'(1X,A,/)') HEADLINE(:TRIM(HEADLINE)) ! Output header info + END = END + 2 ! Increase display counter + END IF + + SCRATCH_B = SCRATCH_B1 ! Init queue pointer to header + +200 DISPLAY = 0 + IF (READIT.GT.0) END = END - 2 ! /READ can output 2 more lines + + CALL OPEN_BULLFIL_SHARED ! Get bulletin file + MORE_LINES = .TRUE. + DO WHILE (ILEN.GT.0.AND.MORE_LINES) + IF (CHAR_OFFSET.EQ.0) THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + LINE_OFFSET = LINE_OFFSET + 1 + END IF + IF (ILEN.LT.0) THEN ! Error, couldn't read record + ILEN = 0 ! Fake end of reading file + MORE_LINES = .FALSE. + ELSE IF (ILEN.GT.0) THEN + IF (EDIT) THEN + WRITE(3,'(A)') INPUT(:ILEN) + ELSE IF (CHAR_OFFSET.EQ.0) THEN + LEN_TEMP = ILEN + CALL CONVERT_TABS(INPUT,LEN_TEMP) + IF (LEN_TEMP.GT.PAGE_WIDTH) THEN + CHAR_OFFSET = 1 + BUFFER = INPUT(:PAGE_WIDTH) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + ELSE + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,INPUT) + END IF + ELSE + CHAR_OFFSET = CHAR_OFFSET + PAGE_WIDTH + IF (LEN_TEMP.LE.CHAR_OFFSET+PAGE_WIDTH-1) THEN + BUFFER = INPUT(CHAR_OFFSET:LEN_TEMP) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + CHAR_OFFSET = 0 + ELSE + BUFFER = INPUT(CHAR_OFFSET:CHAR_OFFSET+PAGE_WIDTH-1) + CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) + END IF + END IF + DISPLAY = DISPLAY + 1 + IF ((DISPLAY.EQ.PAGE_LENGTH-END-4).AND.PAGE) THEN + MORE_LINES = .FALSE. + END IF + END IF + END DO + + CALL CLOSE_BULLFIL ! End of bulletin file read + + IF (EDIT) THEN + CLOSE (UNIT=3) + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + READ_COUNT = 0 ! init bulletin record counter + RETURN + END IF + +C +C Bulletin page is now in temporary memory, so output to terminal. +C Note that if this is a /READ, the first line will have problems with +C the usual FORMAT statement. It will cause a blank line to be outputted +C at the top of the screen. This is because of the input QIO at the +C end of the previous page. The output gets confused and thinks it must +C end the previous line. To prevent that, the first line of a new page +C in a /READ must use a different FORMAT statement to surpress the CR/LF. +C + + SCRATCH_B = SCRATCH_B1 ! Reinit queue pointer to head + DO I=1,DISPLAY ! Output page to terminal + CALL READ_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,BUFFER) ! Get queue record + IF (I.EQ.1.AND.READIT.GT.0) THEN + WRITE(6,'(A)') '+'//BUFFER(:TRIM(BUFFER)) ! (See above comments) + ELSE + WRITE(6,'(1X,A)') BUFFER(:TRIM(BUFFER)) + END IF + END DO + + IF (ILEN.EQ.0) THEN ! End of message? + READ_COUNT = 0 ! init bulletin record counter + ELSE ! Possibly end of message since end of page could be last line + CALL TEST_MORE_RECORDS(BLOCK,LENGTH,IREC) + IF (IREC.EQ.0) THEN ! Last record? + CALL TEST_MORE_LINES(ILEN) ! More lines to read? + IF (ILEN.GT.0) THEN ! Yes, there are still more + IF (READIT.EQ.0) WRITE(6,1070) ! say there is more of bulletin + ELSE ! Yes, last line anyway + READ_COUNT = 0 ! init bulletin record counter + END IF + ELSE IF (READIT.EQ.0) THEN ! Not last record so + WRITE(6,1070) ! say there is more of bulletin + END IF + END IF + + RETURN + +1030 FORMAT(' No more messages.') +1040 FORMAT(' Message not found.') +1070 FORMAT(1X,/,' Press RETURN for more...',/) + +2000 FORMAT(A) + + END + + + + + + + SUBROUTINE READNEW(REDO) +C +C SUBROUTINE READNEW +C +C FUNCTION: Displays new non-system bulletins with prompts between bulletins. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /POINT/ BULL_POINT + + COMMON /READ_DISPLAY/ LINE_OFFSET + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL BULLETIN_SUBCOMMANDS + + CHARACTER INREAD*1,FILE_DEF*80,NUMREAD*6 + + DATA LEN_FILE_DEF /0/, INREAD/0/ + + LOGICAL SLOW,SLOW_TERMINAL + + FIRST_MESSAGE = BULL_POINT + + IF (ICHAR(INREAD).EQ.0) THEN ! If calling READNEW for first time + SLOW = SLOW_TERMINAL() ! Check baud rate of terminal + END IF ! to avoid gobs of output + + LEN_P = 0 ! Tells read subroutine there is + ! no bulletin parameter + +1 WRITE(6,1000) ! Ask if want to read new bulletins + + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0) THEN + INREAD = NUMREAD(:1) + IF (INREAD.EQ.'N'.OR.INREAD.EQ.'Q'.OR.INREAD.EQ.'E') THEN + IF (INREAD.EQ.'Q') THEN + WRITE (6,'(''+uit'',$)') + ELSE IF (INREAD.EQ.'E') THEN + WRITE (6,'(''+xit'',$)') + DO I=1,FLONG ! Just show SYSTEM folders + NEW_MSG(I) = NEW_MSG(I).AND.SYSTEM_FLAG(I) + END DO + DO I=1,FLONG ! Test for new messages in SYSTEM folders + IF (NEW_MSG(I).NE.0) RETURN + END DO + CALL EXIT + ELSE + WRITE (6,'(''+o'',$)') + END IF + RETURN ! If NO, exit + ! Include QUIT to be consistent with next question + ELSE + CALL LIB$ERASE_PAGE(1,1) + END IF + END IF + +3 IF (TEMP_READ.GT.0) THEN + IF (TEMP_READ.LT.FIRST_MESSAGE+1.OR.TEMP_READ.GT.NBULL) THEN + WRITE (6,'('' ERROR: Specified new message not found.'')') + GO TO 1 + ELSE + BULL_POINT = TEMP_READ - 1 + END IF + END IF + + READ_COUNT = 0 ! Initialize display pointer + +5 CALL READ_MSG(READ_COUNT,BULL_POINT+1) ! Read next bulletin + BULL_POINT_READ = BULL_POINT + IF (READ_COUNT.EQ.0) THEN ! Is full bulletin displayed? + CALL OPEN_BULLDIR_SHARED ! If so, see if more new bulls +10 CALL READDIR(BULL_POINT+1,IER_POINT) + IF ((IER_POINT.EQ.BULL_POINT+2).AND. ! If system bulletin (and system + & (SYSTEM.AND.BTEST(FOLDER_FLAG,2))) THEN ! folder) then skip it. + BULL_POINT = BULL_POINT + 1 + GO TO 10 + END IF + CALL CLOSE_BULLDIR + END IF + + GO TO 12 + +11 IF (READ_COUNT.GT.0) THEN + CALL OPEN_BULLDIR_SHARED + CALL OPEN_BULLFIL_SHARED + CALL READDIR(BULL_POINT,IER) + ILEN = LINE_LENGTH+1 + DO I=1,LINE_OFFSET + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + END IF + + BULL_POINT = BULL_POINT_SAVE + LENGTH = LENGTH_SAVE + BLOCK = BLOCK_SAVE + +12 IF (READ_COUNT.EQ.0) THEN ! Prompt user in between + WRITE(6,1020) ! full screens or end of bull. + ELSE + WRITE(6,1030) + END IF + + CALL GET_INPUT_NOECHO(INREAD) + CALL STR$UPCASE(INREAD,INREAD) ! Convert input to upper case + + BLOCK_SAVE = BLOCK + LENGTH_SAVE = LENGTH + BULL_POINT_SAVE = BULL_POINT + + IF (INREAD.EQ.'Q') THEN ! If Q , then QUIT + WRITE (6,'(''+Quit'',$)') + RETURN + ELSE IF (INREAD.EQ.'D') THEN ! If D , then redisplay directory + WRITE (6,'(''+Dir'',$)') + REDO = .TRUE. + RETURN + ELSE IF (INREAD.EQ.'F'.AND..NOT.CAPTIVE()) THEN + ! If F then copy bulletin to file + WRITE (6,'(''+ '')') ! Move cursor from end of prompt line + ! to beginning of next line. + IF (LEN_FILE_DEF.EQ.0) THEN + CALL LIB$SYS_TRNLOG('SYS$LOGIN',ILEN,FILE_DEF) + IER = LIB$FIND_FILE(FILE_DEF//'BULL.DIR', + & BULL_PARAMETER,CONTEXT) + IF (IER) THEN + FILE_DEF = BULL_PARAMETER(:ILEN-1)//'.BULL]' + LEN_FILE_DEF = ILEN + 5 + ELSE + FILE_DEF = 'SYS$LOGIN:' + LEN_FILE_DEF = 10 + END IF + END IF + + LEN_FOLDER = TRIM(FOLDER) + CALL GET_INPUT_PROMPT(BULL_PARAMETER,LEN_P, + & 'Name of file? (Default='//FILE_DEF(:LEN_FILE_DEF)// + & FOLDER(:LEN_FOLDER)//'.LIS) ') + + IF (LEN_P.EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)//FOLDER(:LEN_FOLDER) + & //'.LIS' + LEN_P = LEN_FILE_DEF + LEN_FOLDER + 4 + ELSE + IER = LIB$SYS_TRNLOG(BULL_PARAMETER(:LEN_P),ILEN,INPUT) + IF (IER.NE.1.AND.INDEX(BULL_PARAMETER(:LEN_P),':').EQ.0 + & .AND.INDEX(BULL_PARAMETER(:LEN_P),'[').EQ.0) THEN + BULL_PARAMETER = FILE_DEF(:LEN_FILE_DEF)// + & BULL_PARAMETER(:LEN_P) + LEN_P = LEN_P + LEN_FILE_DEF + END IF + END IF + + BULL_POINT = BULL_POINT_READ + INCMD = 'FILE '//BULL_PARAMETER(:LEN_P) + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + CALL FILE(READ_COUNT) + GO TO 11 + ELSE IF (INREAD.EQ.'P') THEN + WRITE (6,'(''+P'',$)') + BULL_POINT = BULL_POINT_READ + IF (REMOTE_SET.GE.3.OR. + & INDEX(FOLDER_DESCRIP,'<').GT.0) THEN + WRITE(6,1040) + CALL GET_INPUT_NOECHO(INREAD) + CALL STR$UPCASE(INREAD,INREAD) + IF (INREAD.EQ.'P') THEN + WRITE (6,'(''+P'',$)') + INCMD = 'REPLY' + ELSE IF (INREAD.EQ.'U') THEN + WRITE (6,'(''+U'',$)') + INCMD = 'RESPOND' + ELSE IF (INREAD.EQ.'B') THEN + WRITE (6,'(''+B'',$)') + INCMD = 'RESPOND/LIST' + ELSE + GO TO 11 + END IF + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + CALL RESPOND + ELSE + INCMD = 'REPLY' + IER = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + CALL REPLY + END IF + GO TO 11 + ELSE IF (INREAD.EQ.'N'.AND.READ_COUNT.GT.0) THEN + ! If NEXT and last bulletins not finished + READ_COUNT = 0 ! Reset read bulletin counter + CALL OPEN_BULLDIR_SHARED ! Look for NEXT bulletin +20 CALL READDIR(BULL_POINT+1,IER) + IF (IER.NE.BULL_POINT+2) THEN ! If no NEXT bulletin + CALL CLOSE_BULLDIR ! Exit + WRITE(6,1010) + RETURN + ELSE IF (SYSTEM.AND.BTEST(FOLDER_FLAG,2)) THEN + BULL_POINT = BULL_POINT + 1 ! If SYSTEM bulletin, skip it + GO TO 20 ! Look for more bulletins + END IF + CALL CLOSE_BULLDIR + ELSE IF (INREAD.EQ.'R') THEN + WRITE (6,'(''+Read'')') + WRITE (6,'('' Enter message number: '',$)') + CALL GET_INPUT_NUM(NUMREAD,NLEN) ! Get input + CALL STR$UPCASE(NUMREAD,NUMREAD) ! Make input upper case + READ (NUMREAD,'(I)',IOSTAT=IER) TEMP_READ + IF (IER.NE.0.OR.TEMP_READ.LE.0) THEN + WRITE (6,'('' ERROR: Invalid message number specified.'')') + GO TO 12 + ELSE + GO TO 3 + END IF + ELSE IF (IER_POINT.NE.BULL_POINT+2.AND.READ_COUNT.EQ.0) THEN + WRITE(6,1010) + RETURN + END IF + IF (READ_COUNT.EQ.0.AND.SLOW) READ_COUNT = -2 + GO TO 5 + +1000 FORMAT(' Read messages? Type N(No),E(Exit),message + & number, or any other key for yes: ',$) +1010 FORMAT(' No more messages.') +1020 FORMAT(1X,('-'),/,' Type Q(Quit),F(File),D(Dir), + &R(Read msg #),P(Reply) or other for next message: ',$) +1030 FORMAT(1X,('-'),/,' Type Q(Quit),F(File),N(Next), + &D(Dir),R(Read msg #),P(Reply) or other for MORE: ',$) +1040 FORMAT(' Type P to post reply, U to reply to user, + & B to do both, or other to quit: ',$) + + END + + + + + SUBROUTINE SET_DEFAULT_EXPIRE +C +C SUBROUTINE SET_DEFAULT_EXPIRE +C +C FUNCTION: Sets default expiration date. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER EXPIRE*3 + + IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + IER = CLI$GET_VALUE('DEFAULT_EXPIRE',EXPIRE,EX_LEN) + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + ELSE IF (TEMP.LT.-1) THEN + WRITE (6,'('' ERROR: Expiration must be > -1.'')') + ELSE + FOLDER_BBEXPIRE = TEMP + WRITE (6,'('' Default expiration modified.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to set expiration.'')') + END IF + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin10.for b/decus/vax91b/gce91b/net91b/bulletin10.for new file mode 100644 index 0000000..c93bc81 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin10.for @@ -0,0 +1,2186 @@ +C +C BULLETIN10.FOR, Version 6/15/91 +C Purpose: Bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + INTEGER FUNCTION NEWS_READ() + + IMPLICIT INTEGER (A-Z) + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + PARAMETER CR = CHAR(13), LF = CHAR(10) + + COMMON /NEWS_INIT/ END_READ + + NEWS_READ = 1 + + IF (END_READ.EQ.0) THEN + IER = NEWS_READ_PACKET(BUFFER(:1024)) + IF (IER.LE.0) THEN + CALL NEWS_LOGOUT + NEWS_READ = 0 + RETURN + END IF + START_READ = 1 + END_READ = IER + END IF + + IF (END_READ.EQ.0) THEN + NEWS_READ = 0 + RETURN + END IF + + DO WHILE (1) + END_LINE = INDEX(BUFFER(START_READ:END_READ),LF) + IF (END_LINE.GT.0) THEN + SB = START_READ + IF (END_LINE-2.LE.255) THEN + END_LINE = END_LINE + SB - 1 + EB = END_LINE - 2 + ELSE + EB = SB + 254 + IF (INDEX(BUFFER(SB:EB),' ').GT.0) THEN + DO WHILE (BUFFER(EB:EB).NE.' ') + EB = EB - 1 + END DO + END IF + END_LINE = EB + END IF + IF (END_LINE.LT.END_READ) THEN + START_READ = END_LINE + 1 + ELSE + END_READ = 0 + END IF + RETURN + ELSE IF (END_READ-START_READ.EQ.1023) THEN + NEWS_READ = 0 + RETURN + ELSE + BUFFER = BUFFER(START_READ:END_READ) + END_READ = END_READ - START_READ + 1 + IER = NEWS_READ_PACKET(BUFFER(END_READ+1:END_READ+1024)) + IF (IER.LE.0) THEN + NEWS_READ = 0 + RETURN + ELSE + START_READ = 1 + END_READ = END_READ + IER + END IF + END IF + END DO + + RETURN + END + + + + + INTEGER FUNCTION NEWS_WRITE(WRITE) + + IMPLICIT INTEGER (A-Z) + + PARAMETER CR = CHAR(13), LF = CHAR(10) + + COMMON /NEWS_INIT/ END_READ + + CHARACTER*(*) WRITE + + LOGICAL TRY_RECONNECT/.FALSE./ + + END_READ = 0 + + IF (WRITE.EQ.' ') THEN + NEWS_WRITE = NEWS_WRITE_PACKET(CR//LF) + ELSE + NEWS_WRITE = NEWS_WRITE_PACKET(WRITE//CR//LF) + END IF + + IF (.NOT.NEWS_WRITE.AND..NOT.TRY_RECONNECT) THEN + TRY_RECONNECT = .TRUE. + CALL NEWS_RECONNECT(WRITE) + TRY_RECONNECT = .FALSE. + END IF + + RETURN + END + + + + + SUBROUTINE NEWS_RECONNECT(WRITE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + CHARACTER*(*) WRITE + + CHARACTER*6 NUMBER + + CHARACTER*(FOLDER_RECORD) FOLDER2_COM + + CALL NEWS_LOGOUT + + IF (.NOT.NEWS_LOGIN()) RETURN + + IF (FOLDER(:1).GE.'a'.AND.FOLDER(:1).LE.'z') THEN + FOLDER2_COM = FOLDER1_COM + FOLDER1 = FOLDER + FOLDER1_DESCRIP = FOLDER_DESCRIP + CALL NEWS_GROUP(IER) + IF (IER.NE.0) RETURN + FOLDER1_COM = FOLDER2_COM + + IF (.NOT.OTS$CVT_L_TI(BULL_POINT+1,NUMBER,,,)) RETURN + IF (.NOT.NEWS_WRITE('STAT '//NUMBER)) RETURN + IF (.NOT.NEWS_READ()) RETURN + END IF + + IF (.NOT.NEWS_WRITE(WRITE)) RETURN + + RETURN + END + + + + SUBROUTINE NEWS_LOGOUT + + IMPLICIT INTEGER (A-Z) + + COMMON /NEWS_CONNECTED/ NEWS_CONNECTED + + CALL NEWS_DISCONNECT + NEWS_CONNECTED = .FALSE. + + RETURN + END + + + + SUBROUTINE REMOTE_DELETE(SBULL,IMMEDIATE,SUBJ,I,FOLDER1_COM,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /PATH/ PATHNAME,LPATH + CHARACTER*132 PATHNAME + + COMMON /MSGID/ MESSAGE_ID + CHARACTER*255 MESSAGE_ID + + CHARACTER*12 HIGHFROM + + CHARACTER*(*) SUBJ,FOLDER1_COM + + IF (REMOTE_SET.EQ.1) THEN + WRITE(REMOTE_UNIT,'(4A)',IOSTAT=IER) + & 4,SBULL,IMMEDIATE,SUBJ + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + ELSE IF (REMOTE_SET.EQ.3) THEN + CALL STR$UPCASE(HIGHFROM,FROM) + IF (LPATH.EQ.0) CALL GET_PATHNAME + IF (HIGHFROM.EQ.USERNAME.AND. + & MESSAGE_ID(FIRST_INDEX(MESSAGE_ID,'@%'): + & TRIM(MESSAGE_ID)-1).EQ. + & PATHNAME(FIRST_INDEX(PATHNAME,'@%'):LPATH)) THEN + CALL NEWS_POST('cancel',0,IER,'Delete news item.') + ELSE + WRITE (6,'('' ERROR: Not owner of message.'')') + END IF + IER = 0 + END IF + + RETURN + END + + + + + INTEGER FUNCTION FIRST_INDEX(INPUT,FIND) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,FIND + + FIRST_INDEX = 0 + + DO I=1,LEN(FIND) + J = INDEX(INPUT,FIND(I:I)) + IF (J.GT.0.AND.(FIRST_INDEX.EQ.0.OR.J.LT.FIRST_INDEX)) + & FIRST_INDEX = J + END DO + + RETURN + END + + + + SUBROUTINE REMOTE_DIRECTORY_COMMAND(START,END,REVERSE,ALL_DIR,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /XHDR/ XHDR + LOGICAL XHDR /.FALSE./ + + COMMON /POINT/ BULL_POINT + + CHARACTER*6 NUMBER,NUMBER1 + + CHARACTER*1024 TEMP + + DATA QXHDR1 /0/ + + IF (XHDR) THEN + IF (QXHDR1.NE.0) THEN ! Is queue empty? + QXHDR = QXHDR1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(QXHDR,TEMP) + QXHDR1 = QXHDR ! Init header pointer + END IF + END IF + + SYSTEM = 0 + + IF (REMOTE_SET.EQ.1) THEN + IF (REVERSE) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,END,START + ELSE + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,START,END + END IF + ELSE + IER = 2 + NUMDIR = END - START + 1 + IF (START.LT.F_START) THEN + START = F_START + END = START + NUMDIR - 1 + END IF + END IF + + IF (REMOTE_SET.EQ.3.AND.XHDR) THEN + IF (.NOT.OTS$CVT_L_TI(START,NUMBER,,,)) RETURN + IF (.NOT.OTS$CVT_L_TI(END,NUMBER1,,,)) RETURN + DO WHILE (NUMBER1(1:1).EQ.' ') + NUMBER1 = NUMBER1(2:) + END DO + NUMDIR1 = 0 + DO WHILE (NUMDIR1.LT.NUMDIR) + IF (.NOT.NEWS_WRITE('XHDR DATE '//NUMBER//'-'//NUMBER1)) + & RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:2).NE.'22') THEN + IF (NUMDIR1.EQ.0) THEN + IER = 0 + END = START - 1 + RETURN + ELSE + NUMDIR = NUMDIR1 + END IF + ELSE + IF (.NOT.NEWS_READ()) RETURN + IF (NUMDIR1.EQ.0.AND.BUFFER(SB:EB).NE.'.'.AND..NOT. + & OTS$CVT_TI_L(BUFFER(SB:INDEX(BUFFER(SB:EB),' ')+SB-2) + & ,START,,%VAL(1))) RETURN + DO WHILE (BUFFER(SB:EB).NE.'.') + IF (NUMDIR1.LT.NUMDIR) THEN + NUMDIR1 = NUMDIR1 + 1 + TEMP = BUFFER(SB:EB) + CALL WRITE_QUEUE(%VAL(QXHDR),QXHDR,TEMP) + END IF + IF (.NOT.NEWS_READ()) RETURN + END DO + IF (NUMDIR1.EQ.0) THEN + IF (START.LE.F_START) RETURN + START = MAX(F_START,START-NUMDIR) + END = START + NUMDIR - 1 + IF (.NOT.OTS$CVT_L_TI(START,NUMBER,,,)) RETURN + IF (.NOT.OTS$CVT_L_TI(END,NUMBER1,,,)) RETURN + DO WHILE (NUMBER1(1:1).EQ.' ') + NUMBER1 = NUMBER1(2:) + END DO + ELSE IF (NUMDIR1.LT.NUMDIR) THEN + IF (.NOT.NEWS_WRITE('STAT '//TEMP(:INDEX(TEMP,' ')-1))) + & RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (.NOT.NEWS_WRITE('NEXT')) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:2).NE.'22') THEN + NUMDIR = NUMDIR1 + ELSE + NUMBER = BUFFER(SB+4:INDEX(BUFFER(SB+4:),' ')+SB+2) + IF (.NOT.OTS$CVT_TI_L(NUMBER, + & MSG_NUM,,%VAL(1))) RETURN + DO WHILE (NUMBER(LEN(NUMBER):).EQ.' ') + NUMBER = ' '//NUMBER(1:) + END DO + MSG_NUM = MSG_NUM + (NUMDIR - NUMDIR1) - 1 + IF (.NOT.OTS$CVT_L_TI(MSG_NUM,NUMBER1,,,)) RETURN + DO WHILE (NUMBER1(1:1).EQ.' ') + NUMBER1 = NUMBER1(2:) + END DO + END IF + END IF + END IF + END DO + CALL OTS$CVT_L_TI(START,NUMBER,,,) + NUMBER1 = TEMP(:INDEX(TEMP,' ')-1) + END = START + NUMDIR - 1 + DO I=1,2 + IF (I.EQ.1.AND..NOT.NEWS_WRITE + & ('XHDR SUBJECT '//NUMBER//'-'//NUMBER1)) RETURN + IF (I.EQ.2.AND..NOT.NEWS_WRITE + & ('XHDR FROM '//NUMBER//'-'//NUMBER1)) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:2).EQ.'22') THEN + QXHDR = QXHDR1 + IF (.NOT.NEWS_READ()) RETURN + NUMDIR1 = 0 + DO WHILE (BUFFER(SB:EB).NE.'.'.AND.NUMDIR1.LT.NUMDIR) + NUMDIR1 = NUMDIR1 + 1 + CALL READ_QUEUE(%VAL(QXHDR),DUMMY,TEMP) + SB1 = INDEX(BUFFER(SB:EB),' ')+SB-1 + SB1 = FIRST_ALPHA(BUFFER(SB1:EB))+SB1-1 + TEMP(I*256+1:) = BUFFER(SB1:EB) + CALL WRITE_QUEUE(%VAL(QXHDR),QXHDR,TEMP) + IF (.NOT.NEWS_READ()) RETURN + END DO + END IF + END DO + QXHDR = QXHDR1 + IER = 0 + ELSE IF (REMOTE_SET.EQ.3.AND..NOT.XHDR) THEN + IF (.NOT.OTS$CVT_L_TI(START,NUMBER,,,)) RETURN + IF (.NOT.NEWS_WRITE('HEAD '//NUMBER)) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:2).NE.'22') THEN + IF (.NOT.NEWS_WRITE('NEXT')) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (.NOT.OTS$CVT_TI_L(BUFFER(SB+4: + & INDEX(BUFFER(SB+4:),' ')+SB+2),I,,%VAL(1))) RETURN + IF (BUFFER(:2).NE.'22'.OR.I.LT.START) THEN + BUFFER(:3) = '500' + DO WHILE (START.LE.F_NBULL.AND.BUFFER(:2).NE.'22') + START = START + 1 + IF (.NOT.OTS$CVT_L_TI(START,NUMBER,,,)) RETURN + IF (.NOT.NEWS_WRITE('HEAD '//NUMBER)) RETURN + IF (.NOT.NEWS_READ()) RETURN + END DO + IF (BUFFER(:2).NE.'22') THEN + IER = 0 + END = START - 1 + RETURN + END IF + END IF + IF (.NOT.NEWS_WRITE('HEAD')) RETURN + IF (.NOT.NEWS_READ()) RETURN + IER = OTS$CVT_TI_L(BUFFER(SB+4: + & INDEX(BUFFER(SB+4:),' ')+SB+2),START,,%VAL(1)) + END = START + NUMDIR - 1 + END IF + IER = 0 + END IF + + IF (IER.EQ.0) THEN + I = START + DO WHILE (IER.EQ.0.AND.I.LE.END) + IF (REMOTE_SET.EQ.1) THEN + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY + ELSE IF (XHDR) THEN + CALL READ_QUEUE(%VAL(QXHDR),QXHDR,TEMP) + LTEMP = INDEX(TEMP,' ') + CALL OTS$CVT_TI_L(TEMP(:LTEMP-1),MSG_NUM,,%VAL(1)) + CALL NEWS_TIME(TEMP(LTEMP+1:TRIM(TEMP(:256))),MSG_BTIM) + DESCRIP = TEMP(257:512) + CALL GET_FROM(TEMP(512:768),TRIM(TEMP(512:768))) + ELSE + IER = OTS$CVT_TI_L(BUFFER(SB+4: + & INDEX(BUFFER(SB+4:),' ')+SB+2),MSG_NUM,,%VAL(1)) + CALL NEWS_HEADER(IER) + IF (IER.NE.0) RETURN + END IF + CALL WRITE_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) + I = I + 1 + IF (REMOTE_SET.EQ.3.AND..NOT.XHDR.AND.I.LE.END) THEN + IER = 2 + IF (.NOT.NEWS_WRITE('NEXT')) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:3).NE.'223') THEN + END = I - 1 + IER = 0 + RETURN + END IF + IF (.NOT.NEWS_WRITE('HEAD')) RETURN + IF (.NOT.NEWS_READ()) RETURN + IER = 0 + END IF + END DO + END IF + + IF (REMOTE_SET.EQ.3) THEN + IER = 1 + IF (.NOT.OTS$CVT_L_TI(BULL_POINT,NUMBER,,,)) RETURN + IF (.NOT.NEWS_WRITE('STAT '//NUMBER)) RETURN + IF (.NOT.NEWS_READ()) RETURN + IER = 0 + END IF + + RETURN + END + + + + INTEGER FUNCTION NEWS_LOGIN + + IMPLICIT INTEGER (A-Z) + + COMMON /NEWS_CONNECTED/ NEWS_CONNECTED + LOGICAL NEWS_CONNECTED /.FALSE./ + + COMMON /XHDR/ XHDR + LOGICAL XHDR /.FALSE./ + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + IF (.NOT.NEWS_CONNECTED) THEN + NEWS_LOGIN = .FALSE. + NEWS_CONNECTED = NEWS_CONNECT() + IF (.NOT.NEWS_CONNECTED) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (.NOT.NEWS_WRITE('XHDR')) RETURN + IF (.NOT.NEWS_READ()) RETURN + XHDR = BUFFER(:3).NE.'500' + END IF + + NEWS_LOGIN = .TRUE. + + RETURN + END + + + + + SUBROUTINE NEWS_HEADER(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + EX_BTIM(1) = 0 + EX_BTIM(2) = 0 + + DESCRIP = ' ' + FROM = ' ' + + DO WHILE (BUFFER(SB:EB).NE.'.') + IER = NEWS_READ() + IF (.NOT.IER) RETURN + IF (BUFFER(SB:EB).NE.'.') THEN + IF (BUFFER(SB:SB+7).EQ.'Subject:'.AND.EB.GE.SB+9) THEN + SB1 = FIRST_ALPHA(BUFFER(SB+9:EB))+SB+8 + DESCRIP = BUFFER(SB1:EB) + ELSE IF (BUFFER(SB:SB+4).EQ.'Date:'.AND.EB.GE.SB+6) THEN + CALL NEWS_TIME(BUFFER(SB+6:EB),MSG_BTIM) + ELSE IF (BUFFER(SB:SB+7).EQ.'Expires:'.AND.EB.GE.SB+9) THEN + CALL NEWS_TIME(BUFFER(SB+9:EB),EX_BTIM) + ELSE IF (BUFFER(SB:SB+4).EQ.'From:'.AND.EB.GE.SB+6) THEN + SB1 = FIRST_ALPHA(BUFFER(SB+6:EB))+SB+5 + CALL GET_FROM(BUFFER(SB1:EB),EB-SB1+1) + END IF + END IF + END DO + + IER = 0 + + RETURN + END + + + + INTEGER FUNCTION FIRST_ALPHA(INPUT) + + CHARACTER*(*) INPUT + + DO I=1,LEN(INPUT) + IF (ICHAR(INPUT(I:I)).LT.32) INPUT(I:I) = ' ' + END DO + + DO FIRST_ALPHA=1,LEN(INPUT) + IF (ICHAR(INPUT(FIRST_ALPHA:FIRST_ALPHA)).GT.32) RETURN + END DO + + RETURN + END + + + + + SUBROUTINE REMOTE_READ_MESSAGE(BULL_SEARCH,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + CHARACTER*6 NUMBER + + IF (REMOTE_SET.EQ.1) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,BULL_SEARCH + ELSE + IER = 2 + IF (BULL_SEARCH.LT.F_START) BULL_SEARCH = F_START + IF (.NOT.OTS$CVT_L_TI(BULL_SEARCH,NUMBER,,,)) RETURN + IF (.NOT.NEWS_WRITE('HEAD '//NUMBER)) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:2).NE.'22') RETURN + IER = 0 + END IF + + RETURN + END + + + + SUBROUTINE REMOTE_GET_NEWEST_MSG(IN_BTIM,START) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + DIMENSION IN_BTIM(2) + + CHARACTER TIME*20,FIRST*80 + + CHARACTER*6 NUMBER + + IF (REMOTE_SET.EQ.1) THEN + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 12,IN_BTIM(1),IN_BTIM(2) + IF (IER.EQ.0) THEN + READ (REMOTE_UNIT,'(A)',IOSTAT=IER) START + END IF + ELSE IF (READIT.EQ.1) THEN + I = NEWS_FIND_SUBSCRIBE() + START = (LAST_NEWS_READ2(2,I).AND.'3FFF'X) + + & LAST_NEWS_READ(2,I) + 1 + IF (START.GT.F_NBULL) THEN + START = -1 + ELSE + LAST_NEWS_READ2(2,I) = MIN(8191,F_NBULL-LAST_NEWS_READ(2,I)) + & .OR.(LAST_NEWS_READ2(2,I).AND.'C000'X) + END IF + ELSE + START = -1 + IER = SYS$ASCTIM(,TIME,IN_BTIM,) + CALL DATE_TIME(TIME) + SKIP = 0 + DO WHILE (1) + IF (.NOT.NEWS_WRITE('NEWNEWS '//FOLDER_NAME(:TRIM( + & FOLDER_NAME))//' '//TIME)) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:2).EQ.'23') THEN + IF (.NOT.NEWS_READ()) CALL EXIT + DO I=1,SKIP + IF (.NOT.NEWS_READ()) CALL EXIT + END DO + FIRST = BUFFER(SB:EB) + IF (FIRST.EQ.'.') RETURN + DO WHILE (BUFFER(SB:EB).NE.'.') + IF (.NOT.NEWS_READ()) CALL EXIT + END DO + IF (.NOT.NEWS_WRITE('STAT '//FIRST(:TRIM(FIRST)))) + & CALL EXIT + IF (.NOT.NEWS_READ()) CALL EXIT + IF (BUFFER(:2).EQ.'22') THEN + IF (BUFFER(5:INDEX(BUFFER(5:),' ')+3).EQ.'0') THEN + I = F_NBULL + 1 + DO WHILE (I.GE.F_START.AND.(FIRST(:TRIM(FIRST)).NE. + & BUFFER(INDEX(BUFFER,'<'):INDEX(BUFFER,'>')) + & .OR.I.GT.F_NBULL)) + I = I - 1 + IF (.NOT.OTS$CVT_L_TI(I,NUMBER,,,)) RETURN + IF (.NOT.NEWS_WRITE('STAT '//NUMBER)) RETURN + IF (.NOT.NEWS_READ()) RETURN + END DO + IF (I.GE.F_START) START = I + ELSE + IER = OTS$CVT_TI_L(BUFFER(SB+4: + & INDEX(BUFFER(SB+4:),' ')+SB+2),START,,%VAL(1)) + END IF + RETURN + END IF + END IF + SKIP = SKIP + 1 + END DO + END IF + + RETURN + END + + + + SUBROUTINE REMOTE_COPY_BULL(IER) + + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + IF (REMOTE_SET.EQ.1) THEN + WRITE (REMOTE_UNIT,'(A)',IOSTAT=IER) 2 + ELSE + END IF + + RETURN + END + + + + SUBROUTINE REMOTE_WRITE_BULL_FILE(OUTPUT) + + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*(*) OUTPUT + + IF (REMOTE_SET.EQ.1) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 6,OUTPUT + ELSE + END IF + + RETURN + END + + + + SUBROUTINE GET_REMOTE_MESSAGE(IER) +C +C SUBROUTINE GET_REMOTE_MESSAGE +C +C FUNCTION: +C Gets remote message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($RMSDEF)' + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + COMMON /REF/ REFERENCES,LREF + CHARACTER*255 REFERENCES + + COMMON /NEWSGROUPS/ NEWSGROUPS + CHARACTER*255 NEWSGROUPS + + CHARACTER*255 TEMP,FROM_LINE,SUBJECT_LINE + + CHARACTER*10 MSGNUM + + IF (SCRATCH_R1.NE.0) THEN ! Is queue empty? + SCRATCH_R = SCRATCH_R1 ! No, set queue pointer to head + ELSE ! Else if queue is empty + CALL INIT_QUEUE(SCRATCH_R,INPUT) + SCRATCH_R1 = SCRATCH_R ! Init header pointer + END IF + + IF (REMOTE_SET.EQ.3) THEN + MSGNUM = BUFFER(5:INDEX(BUFFER(5:),' ')-1+4) + + SUBJECT_LINE = ' ' + FROM_LINE = ' ' + NEWSGROUPS = ' ' + LREF = 0 + DO WHILE (BUFFER(SB:EB).NE.'.') + IER = NEWS_READ() + IF (.NOT.IER) RETURN + IF (BUFFER(SB:EB).NE.'.') THEN + IF (BUFFER(SB:SB+4).EQ.'From:'.AND.EB.GT.SB+5) THEN + SB1 = FIRST_ALPHA(BUFFER(SB+6:EB))+SB+5 + FROM_LINE = 'From: '//BUFFER(SB1:EB) + ELSE IF (BUFFER(SB:SB+7).EQ.'Subject:'.AND. + & EB.GT.SB+8) THEN + SB1 = FIRST_ALPHA(BUFFER(SB+9:EB))+SB+8 + SUBJECT_LINE = 'Subj: '//BUFFER(SB1:EB) + ELSE IF (BUFFER(SB:SB+10).EQ.'Newsgroups:'.AND. + & EB.GT.SB+11) THEN + SB1 = FIRST_ALPHA(BUFFER(SB+12:EB))+SB+11 + NEWSGROUPS = BUFFER(SB1:EB) + ELSE IF (BUFFER(SB:SB+10).EQ.'References:'.AND. + & EB.GT.SB+11) THEN + IF (LREF.EQ.0) THEN + REFERENCES = BUFFER(SB+12:EB) + ELSE + REFERENCES = BUFFER(SB+12:EB)//' '// + & REFERENCES(:LREF) + END IF + LREF = TRIM(REFERENCES) + ELSE IF (BUFFER(SB:SB+10).EQ.'Message-ID:'.AND. + & EB.GT.SB+11) THEN + IF (LREF.EQ.0) THEN + REFERENCES = BUFFER(SB+12:EB) + ELSE + REFERENCES = REFERENCES(:LREF)//' '// + & BUFFER(SB+12:EB) + END IF + LREF = TRIM(REFERENCES) + END IF + END IF + END DO + + LSUB = TRIM(SUBJECT_LINE) + LFRO = TRIM(FROM_LINE) + END IF + + ILEN = 128 + IER = 0 + LENGTH = 0 + LTEMP = 0 + + DO WHILE (ILEN.GT.0.AND.IER.EQ.0) + IF (REMOTE_SET.EQ.1) THEN + READ (REMOTE_UNIT,'(Q,A)',IOSTAT=IER) ILEN,INPUT + ELSE + IF (ILEN.EQ.128) ILEN = 0 + IF (LTEMP.GT.0) THEN + ILEN = MIN(128,LTEMP) + INPUT = TEMP(:ILEN) + LTEMP = LTEMP - ILEN + END IF + IF (ILEN.LT.128) THEN + IF (LFRO.GT.0) THEN + BUFFER = FROM_LINE + SB = 1 + EB = LFRO + LFRO = 0 + IER = 1 + ELSE IF (LSUB.GT.0) THEN + BUFFER = SUBJECT_LINE + SB = 1 + EB = LSUB + LSUB = 0 + IER = 1 + ELSE + IF (LSUB.EQ.0) THEN + IF (.NOT.NEWS_WRITE('ARTICLE '//MSGNUM)) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:2).NE.'22') THEN + IER = 0 + RETURN + END IF + LSUB = -1 + END IF + IER = NEWS_READ() + END IF + IF (IER.AND.BUFFER(SB:EB).NE.'.') THEN + IER = 0 + LTEMP = MIN(255,EB-SB+1) + IF (LTEMP.GT.0) THEN + TEMP = CHAR(LTEMP)//BUFFER(SB:SB+LTEMP-1) + ELSE + TEMP = CHAR(1)//' ' + LTEMP = 1 + END IF + LTEMP = LTEMP + 1 + LINP = MIN(LTEMP,128-ILEN) + INPUT = INPUT(:ILEN)//TEMP(:LINP) + ILEN = ILEN + LINP + LTEMP = LTEMP - LINP + TEMP = TEMP(LINP+1:) + ELSE IF (IER) THEN + IER = 0 + INPUT = INPUT(:ILEN)//CHAR(0) + ILEN = -128 + ELSE + ILEN = 128 + END IF + ELSE + TEMP = TEMP(129:) + END IF + END IF + IF (IER.NE.0.AND.ILEN.GT.0) THEN + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.RMS$_RER) THEN ! Ignore this error + IER = 0 + ILEN = 0 + ELSE + CALL SYS_GETMSG(IER1) + LENGTH = 0 + IER1 = IER + CALL DISCONNECT_REMOTE + IER = IER1 ! IER is set to 0 by DISCONNECT_REMOTE + END IF + ELSE IF (ABS(ILEN).EQ.128) THEN + CALL WRITE_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,INPUT) + LENGTH = LENGTH + 1 + END IF + END DO + + RETURN + END + + + + + SUBROUTINE REMOTE_REMOVE_FOLDER(IER) + + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + RETURN + END + + + + SUBROUTINE CONNECT_REMOTE_FOLDER(READ_ONLY,IER) +C +C SUBROUTINE CONNECT_REMOTE_FOLDER +C +C FUNCTION: Connects to folder that is located on other DECNET node. +C + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_UNIT /15/ + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /READIT/ READIT + + COMMON /NEWS_INIT/ END_READ + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*12 FOLDER_BBOARD_SAVE,FOLDER_OWNER_SAVE + CHARACTER*25 FOLDER_SAVE + + DIMENSION DUMMY(4) + + IF (FOLDER1(:1).GE.'a'.AND.FOLDER1(:1).LE.'z') THEN + END_READ = 0 + IF (.NOT.NEWS_LOGIN()) THEN + IER = 2 + RETURN + END IF + CALL NEWS_GROUP(IER) + IF (IER.NE.0) RETURN + IF (REMOTE_SET.EQ.1) CLOSE(UNIT=REMOTE_UNIT) + RETURN + END IF + + REMOTE_UNIT = 31 - REMOTE_UNIT + + SAME = .TRUE. + LEN_BBOARD = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN ! Remote folder name different + SAME = .FALSE. ! from local? Yes. + LEN_BBOARD = LEN_BBOARD - 1 + END IF + + OPEN (UNIT=REMOTE_UNIT,STATUS='UNKNOWN',IOSTAT=IER,RECL=256, + & FILE=FOLDER1_BBOARD(3:LEN_BBOARD)//'::"TASK=BULLETIN1"') + + IF (IER.EQ.0) THEN + IF (.NOT.SAME) THEN + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + FOLDER_FILE = FOLDER1_FILE + FOLDER_SAVE = FOLDER1 + FOLDER1 = BULLDIR_HEADER(13:) + END IF + SYSLOG = .FALSE. + IF (READIT.EQ.1) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 1,'SYSTEM?' + READ(REMOTE_UNIT,'(A)',IOSTAT=IER) IER1 + IF (IER1) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 1,FOLDER1//'+' + SYSLOG = .TRUE. + END IF + END IF + IF (.NOT.SYSLOG) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 1,FOLDER1 + END IF + FOLDER_OWNER_SAVE = FOLDER1_OWNER + FOLDER_BBOARD_SAVE = FOLDER1_BBOARD + FOLDER_NUMBER_SAVE = FOLDER1_NUMBER + IF (IER.EQ.0) THEN + IF (SYSLOG) THEN + READ(REMOTE_UNIT,'(7A)',IOSTAT=IER)IER1,READ_ONLY, + & DUMMY(1),DUMMY(2),DUMMY(3),DUMMY(4),FOLDER1_COM + ELSE + READ(REMOTE_UNIT,'(5A)',IOSTAT=IER)IER1,READ_ONLY, + & DUMMY(1),DUMMY(2),FOLDER1_COM + END IF + END IF + IF (.NOT.SAME) FOLDER1 = FOLDER_SAVE + FOLDER1_BBOARD = FOLDER_BBOARD_SAVE + FOLDER1_NUMBER = FOLDER_NUMBER_SAVE + FOLDER1_OWNER = FOLDER_OWNER_SAVE + END IF + + IF (IER.NE.0.OR..NOT.IER1) THEN + CLOSE (UNIT=REMOTE_UNIT) + REMOTE_UNIT = 31 - REMOTE_UNIT + IF (IER.EQ.0.AND.FOLDER_NUMBER_SAVE.GE.0.AND. + & TEST_BULLCP().NE.2) THEN ! Not BULLCP process + IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + & .OR.TEST2(SET_FLAG,FOLDER_NUMBER_SAVE)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER_SAVE) + CALL CLR2(SET_FLAG,FOLDER_NUMBER_SAVE) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + END IF + IER = 2 + ELSE + CLOSE (UNIT=31-REMOTE_UNIT) +C +C If remote folder has returned a last read time for the folder, +C and if in /LOGIN mode, or last selected folder was a different +C folder, or folder specified with "::", then update last read time. +C + IF (((FOLDER_NUMBER.NE.FOLDER1_NUMBER.OR.READIT.EQ.1) + & .AND.(DUMMY(1).NE.0.OR.DUMMY(2).NE.0)) + & .OR.FOLDER1_NUMBER.EQ.-1) THEN + CALL COPY2(LAST_READ_BTIM(1,FOLDER1_NUMBER+1),DUMMY) + IF (SYSLOG) THEN + CALL COPY2(LAST_SYS_BTIM(1,FOLDER1_NUMBER+1),DUMMY(3)) + END IF + END IF + IER = 0 + END IF + + RETURN + END + + + + SUBROUTINE REMOTE_GET_HEADER(BULLETIN_NUM,ICOUNT,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + COMMON /MSGID/ MESSAGE_ID + CHARACTER*255 MESSAGE_ID + + COMMON /NEXT/ NEXT + LOGICAL NEXT /.FALSE./ + + COMMON /NEWGROUP/ NEWGROUP + + CHARACTER*6 NUMBER + + CHARACTER IN_BTIM(2) + + IF (REMOTE_SET.EQ.1) THEN + IF (ICOUNT.GE.0) THEN + WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 8,ICOUNT + ELSE + WRITE (REMOTE_UNIT,'(3A)',IOSTAT=IER) 8,-1,MSG_KEY + END IF + IF (IER.EQ.0) THEN + IF (ICOUNT.EQ.0) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_HEADER + ELSE IF (ICOUNT.EQ.-1) THEN + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER1) IER,BULLDIR_ENTRY + IF (IER1.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE IF (IER.NE.0) THEN + CALL CONVERT_ENTRY_FROMBIN + END IF + RETURN + ELSE + READ (REMOTE_UNIT,'(2A)',IOSTAT=IER) ICOUNT,BULLDIR_ENTRY + END IF + END IF + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE IF (ICOUNT.EQ.1) THEN + CALL CONVERT_HEADER_FROMBIN + ELSE + CALL CONVERT_ENTRY_FROMBIN + END IF + ELSE IF (REMOTE_SET.EQ.3) THEN + IF (ICOUNT.EQ.0) THEN + NBULL = F_NBULL + ICOUNT = 1 + RETURN + ELSE IF (ICOUNT.EQ.-1) THEN + IER = 2 + CALL GET_MSGBTIM(MSG_KEY,IN_BTIM) + CALL REMOTE_GET_NEWEST_MSG(IN_BTIM,START) + IF (START.EQ.-1) RETURN + IF (.NOT.NEWS_WRITE('HEAD')) CALL ERROR_AND_EXIT + IF (.NOT.NEWS_READ()) CALL ERROR_AND_EXIT + ELSE + IER = 2 + IF (NEXT.AND..NOT.NEWGROUP) THEN + IF (.NOT.NEWS_WRITE('NEXT')) CALL ERROR_AND_EXIT + IF (.NOT.NEWS_READ()) CALL ERROR_AND_EXIT + IF (BUFFER(:3).NE.'223') RETURN + IF (.NOT.NEWS_WRITE('HEAD')) CALL ERROR_AND_EXIT + IF (.NOT.NEWS_READ()) CALL ERROR_AND_EXIT + ELSE + IF (ICOUNT.LT.F_START) ICOUNT = F_START + IF (ICOUNT.GT.F_NBULL) ICOUNT = F_NBULL + IF (.NOT.OTS$CVT_L_TI(ICOUNT,NUMBER,,,)) RETURN + IF (.NOT.NEWS_WRITE('HEAD '//NUMBER)) + & CALL ERROR_AND_EXIT + IF (.NOT.NEWS_READ()) CALL ERROR_AND_EXIT + END IF + IF (BUFFER(:2).NE.'22') THEN + DO WHILE (NEXT.AND.NEWGROUP.AND.ICOUNT.GT.F_START) + ICOUNT = ICOUNT - 1 + IF (.NOT.OTS$CVT_L_TI(ICOUNT,NUMBER,,,)) RETURN + IF (.NOT.NEWS_WRITE('HEAD '//NUMBER)) + & CALL ERROR_AND_EXIT + IF (.NOT.NEWS_READ()) CALL ERROR_AND_EXIT + IF (BUFFER(:2).EQ.'22') NEXT = .FALSE. + END DO + IF (INCMD(:4).EQ.'BACK'.AND.ICOUNT.GE.F_START) THEN + IF (.NOT.NEWS_WRITE('LAST')) CALL ERROR_AND_EXIT + IF (.NOT.NEWS_READ()) CALL ERROR_AND_EXIT + IF (BUFFER(:3).NE.'223') RETURN + IF (.NOT.NEWS_WRITE('HEAD')) CALL ERROR_AND_EXIT + IF (.NOT.NEWS_READ()) CALL ERROR_AND_EXIT + ELSE IF (INCMD(:4).NE.'READ'.AND..NOT.NEXT) THEN + IF (.NOT.NEWS_WRITE('NEXT')) CALL ERROR_AND_EXIT + IF (.NOT.NEWS_READ()) CALL ERROR_AND_EXIT + IF (BUFFER(:3).NE.'223') RETURN + IF (.NOT.NEWS_WRITE('HEAD')) CALL ERROR_AND_EXIT + IF (.NOT.NEWS_READ()) CALL ERROR_AND_EXIT + END IF + END IF + IF (BUFFER(:2).NE.'22') RETURN + IER = OTS$CVT_TI_L(BUFFER(5:INDEX(BUFFER(5:),' ')+3), + & ICOUNT,,%VAL(1)) + IF (.NOT.IER) RETURN + START = ICOUNT + BULLETIN_NUM = START + END IF + NEWGROUP = .FALSE. + MESSAGE_ID = BUFFER(INDEX(BUFFER,'<'):INDEX(BUFFER,'>')) + IER = 0 + CALL NEWS_HEADER(IER) + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + CALL CONVERT_ENTRY_FROMBIN + END IF + BLOCK = START + MSG_NUM = START + SYSTEM = 0 + IF (ICOUNT.NE.-1) THEN + ICOUNT = ICOUNT + 1 + ELSE + IER = START + END IF + END IF + + RETURN + END + + + + + + SUBROUTINE GET_MSGBTIM(MSG_KEY,BTIM) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*8 MSG_KEY,INPUT + + INPUT = MSG_KEY + + DO I=1,8 + INPUT(9-I:9-I) = MSG_KEY(I:I) + END DO + + CALL LIB$MOVC3(8,%REF(INPUT),BTIM(1)) + + RETURN + END + + + + SUBROUTINE NEWS_GROUP(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + COMMON /NEWGROUP/ NEWGROUP + + IER = NEWS_WRITE('GROUP '//FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP))) + IF (.NOT.IER) RETURN + + IER = NEWS_READ() + IF (.NOT.IER) RETURN + + IF (BUFFER(:3).EQ.'411') RETURN + + NEWGROUP = .TRUE. + + BUFFER = BUFFER(5:) + + IER = OTS$CVT_TI_L(BUFFER(:INDEX(BUFFER,' ')-1),F1_END,,%VAL(1)) + IF (.NOT.IER) RETURN + BUFFER = BUFFER(INDEX(BUFFER,' ')+1:) + IER = OTS$CVT_TI_L(BUFFER(:INDEX(BUFFER,' ')-1),F1_START,,%VAL(1)) + IF (.NOT.IER) RETURN + BUFFER = BUFFER(INDEX(BUFFER,' ')+1:) + IER = OTS$CVT_TI_L(BUFFER(:INDEX(BUFFER,' ')-1),F1_NBULL,,%VAL(1)) + IF (.NOT.IER) RETURN + BUFFER = BUFFER(INDEX(BUFFER,' ')+1:) + + IER = NEWS_WRITE('STAT') + IF (.NOT.IER) RETURN + + IER = NEWS_READ() + IF (.NOT.IER) RETURN + + IER = OTS$CVT_TI_L(BUFFER(SB+4: + & INDEX(BUFFER(SB+4:),' ')+SB+2),START,,%VAL(1)) + IF (IER.AND.START.GT.F1_START) F1_START = START + + IF (F1_START.EQ.0) F1_NBULL = 0 + + IER = 0 + + RETURN + END + + + + SUBROUTINE NEWS_TIME(INTIME,BTIM) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INTIME + + CHARACTER*20 TIME + + I = 1 + LTIME = TRIM(INTIME) + DO WHILE (I.LE.LTIME.AND.(ICHAR(INTIME(I:I)).LT.ICHAR('0').OR. + & ICHAR(INTIME(I:I)).GT.ICHAR('9'))) + I = I + 1 + END DO + + IF (I.GT.LTIME) THEN + CALL SYS_BINTIM('-',BTIM) + RETURN + END IF + + CALL STR$UPCASE(TIME,INTIME(I:)) + + DO J = 1,2 + I = 1 + DO WHILE (TIME(I:I).NE.' '.AND.I.LT.LEN(TIME)) + I = I + 1 + END DO + TIME(I:I) = '-' + END DO + + IF (I.EQ.LEN(TIME)) RETURN + + IF (TIME(I+3:I+3).EQ.' ') THEN + IF (TIME(I+1:I+1).EQ.'9'.OR.TIME(I+1:I+1).EQ.'8') THEN + TIME = TIME(:I)//'19'//TIME(I+1:) + ELSE + TIME = TIME(:I)//'20'//TIME(I+1:) + END IF + END IF + + I = 1 + DO J = 1,2 + DO WHILE (TIME(I:I).NE.' '.AND.I.LE.LEN(TIME)) + I = I + 1 + END DO + I = I + 1 + END DO + + IF (I-2.GT.LEN(TIME).OR.I-2.LE.0) RETURN + CALL SYS_BINTIM(TIME(:I-2),BTIM) + + RETURN + END + + + + SUBROUTINE NEWS_LIST + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + CHARACTER*23 TODAY + + CALL LIB$DATE_TIME(TODAY) + + IF (.NOT.NEWS_LOGIN()) RETURN + + IF (.NOT.NEWS_WRITE('LIST')) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:3).NE.'215') RETURN + + SPECIAL = SYS_TRNLNM('BULL_SPECIAL_NEWS_UPDATE','DEFINED').OR. + & (INDEX(TODAY,' 03:').NE.0) ! Delete non-existant groups at 3 + + CALL OPEN_BULLNEWS_SHARED ! Open folder file + + NEWS_FOLDER1_BBOARD = '::' + + CALL READ_FOLDER_FILE_KEYNUM_TEMP(1000,IER1) + IF (IER1.NE.0) THEN + NEWS_FOLDER1 = 'a' + NEWS_FOLDER1_NUMBER = 1000 + NEWS_F1_END = 1001 + WRITE (7,IOSTAT=IER) NEWS_FOLDER1_COM + END IF + IF (NEWS_F1_END.LT.1001) NEWS_F1_END = 1001 + NEWS_F_END = NEWS_F1_END + DO WHILE (NEWS_READ().AND.BUFFER(SB:EB).NE.'.') + FLEN = INDEX(BUFFER(SB:),' ') - 1 + NEWS_FOLDER1 = BUFFER(SB:MIN(25,FLEN)+SB-1) + IF (IER1.EQ.0) THEN + CALL READ_FOLDER_FILE_KEYNAME_TEMP(NEWS_FOLDER1,IER) + END IF + SP = FLEN+SB+1 + EP = INDEX(BUFFER(SP:),' ')+SP-2 + IER2 = OTS$CVT_TI_L(BUFFER(SP:EP),NEWS_F1_NBULL,,%VAL(1)) + SP = EP + 2 + EP = INDEX(BUFFER(SP:),' ')+SP-2 + IER2 = OTS$CVT_TI_L(BUFFER(SP:EP),NEWS_F1_START,,%VAL(1)) + IF (NEWS_F1_START.EQ.0) NEWS_F1_NBULL = 0 + CALL SYS_BINTIM('-',NEWS_F1_NEWEST_BTIM) + IF (IER.NE.0.OR.IER1.NE.0) THEN + IF (FLEN.GT.25) THEN + NEWS_FOLDER1_DESCRIP = BUFFER(SB+25:FLEN+SB-1) + ELSE + NEWS_FOLDER1_DESCRIP = ' ' + END IF + IER = 0 + DO WHILE (IER.EQ.0.AND.IER1.EQ.0) + DO WHILE (REC_LOCK(IER)) + READ (7,KEY=NEWS_F_END,KEYID=1,IOSTAT=IER) + END DO + IF (IER.EQ.0) NEWS_F_END = NEWS_F_END + 1 + END DO + NEWS_FOLDER1_NUMBER = NEWS_F_END + WRITE (7,IOSTAT=IER) NEWS_FOLDER1_COM + IF (IER.EQ.0) NEWS_F_END = NEWS_F_END + 1 + ELSE IF (.NOT.SPECIAL.AND.(F1_START.NE.NEWS_F1_START.OR. + & F1_NBULL.NE.NEWS_F1_NBULL)) THEN + REWRITE (7,IOSTAT=IER) NEWS_FOLDER1_COM + END IF + END DO + + CALL READ_FOLDER_FILE_KEYNUM_TEMP(1000,IER1) + NEWS_F1_END = NEWS_F_END + REWRITE (7) NEWS_FOLDER1_COM + + IF (SPECIAL) THEN + CALL READ_FOLDER_FILE_KEYNUM_TEMP(1000,IER) + DO WHILE (IER.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0) THEN + NEWS_F1_NBULL = F1_NBULL + NEWS_F1_START = F1_START + CALL NEWS_GROUP(IER) + IF (IER.EQ.0) THEN + IF ((F1_START.NE.NEWS_F1_START.OR. + & F1_NBULL.NE.NEWS_F1_NBULL) + & .AND.F1_START.GT.0) THEN + CALL SYS_BINTIM('-',F1_NEWEST_BTIM) + CALL REWRITE_FOLDER_FILE_TEMP + END IF + ELSE + DELETE (UNIT=7) + IER = 0 + END IF + END IF + END DO + END IF + + CALL CLOSE_BULLNEWS + + RETURN + END + + + SUBROUTINE LOWERCASE(INPUT) + + CHARACTER*(*) INPUT + + DO I=1,LEN(INPUT) + IF (INPUT(I:I).GE.'A'.AND.INPUT(I:I).LE.'Z') THEN + INPUT(I:I) = CHAR(ICHAR(INPUT(I:I)) - ICHAR('A') + ICHAR('a')) + END IF + END DO + + RETURN + END + + + + SUBROUTINE NEWS_POST(FILENAME,FILEOPEN,IER,SUBJECT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLNEWS.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + COMMON /REF/ REFERENCES,LREF + CHARACTER*255 REFERENCES + + COMMON /PATH/ PATHNAME,LPATH + CHARACTER*132 PATHNAME + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /MSGID/ MESSAGE_ID + CHARACTER*255 MESSAGE_ID + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /NEWSGROUPS/ NEWSGROUPS + CHARACTER*255 NEWSGROUPS + + CHARACTER*(*) FILENAME,SUBJECT + + CHARACTER TODAY*23,MSGID*23,ZONE*5,GROUPS*255 + + DIMENSION NOW(2),GMT(2) + + IER = 1 + + IF (FILENAME.NE.'cancel') THEN + IF (.NOT.FILEOPEN) THEN + OPEN (UNIT=3,FILE=FILENAME,STATUS='OLD',IOSTAT=IER1) + IF (IER1.NE.0) RETURN + END IF + + IER1 = 0 + DO WHILE (IER1.EQ.0) + READ (3,'(A)',IOSTAT=IER1) BUFFER + IF (IER1.NE.0) GO TO 900 + IF (TRIM(BUFFER).GT.0) IER1 = 1 + END DO + + REWIND (UNIT=3) + END IF + + IF (.NOT.NEWS_LOGIN()) GO TO 900 + + IF (LPATH.EQ.0) CALL GET_PATHNAME + + IF (.NOT.NEWS_WRITE('POST')) GO TO 900 + IF (.NOT.NEWS_READ()) GO TO 900 + IF (BUFFER(:3).NE.'340') THEN + WRITE (6,'('' ERROR: Posting not allowed.'')') + GO TO 900 + END IF + + IF (REMOTE_SET.GE.3) THEN + IF (TRIM(NEWSGROUPS).GT.0.AND.INCMD(:2).EQ.'RE') THEN + GROUPS = 'Newsgroups: '//NEWSGROUPS + ELSE IF (REMOTE_SET.EQ.4) THEN + GROUPS = 'Newsgroups: '//FOLDER1_DESCRIP + ELSE + GROUPS = 'Newsgroups: '//FOLDER_DESCRIP + END IF + IF (FILENAME.NE.'cancel') THEN + IF (CLI$PRESENT('GROUPS')) THEN + CALL OPEN_BULLNEWS_SHARED + FLEN = 0 + DO WHILE (CLI$GET_VALUE('GROUPS',FOLDER1_NAME,FLEN) + & .AND.TRIM(GROUPS)+FLEN+1.LE.LEN(GROUPS)) + CALL LOWERCASE(FOLDER1_NAME) + CALL READ_FOLDER_FILE_KEYNAME_TEMP + & (FOLDER1_NAME(:FLEN),IER1) + IF (IER1.EQ.0) GROUPS = GROUPS(:TRIM(GROUPS))// + & ','//FOLDER1_NAME(:TRIM(FOLDER1_NAME)) + END DO + CALL CLOSE_BULLNEWS + END IF + END IF + IF (.NOT.NEWS_WRITE(GROUPS(:TRIM(GROUPS)))) GO TO 900 + END IF + ATSIGN = INDEX(PATHNAME,'@') + PCSIGN = INDEX(PATHNAME,'%') + CALL LOWERCASE(USERNAME) + IF (PCSIGN.GT.0) THEN + IF (.NOT.NEWS_WRITE('Path: '//PATHNAME(ATSIGN+1:LPATH)//'!' + & //PATHNAME(PCSIGN+1:ATSIGN-1)//'!' + & //USERNAME(:TRIM(USERNAME)))) GO TO 900 + ELSE + IF (.NOT.NEWS_WRITE('Path: '//PATHNAME(ATSIGN+1:LPATH)//'!' + & //USERNAME(:TRIM(USERNAME)))) GO TO 900 + END IF + IF (.NOT.NEWS_WRITE('From: '//USERNAME(:TRIM(USERNAME))// + & PATHNAME(:LPATH))) GO TO 900 + CALL STR$UPCASE(USERNAME,USERNAME) + IF (.NOT.NEWS_WRITE('Subject: '//SUBJECT(:TRIM(SUBJECT)))) + & GO TO 900 + + IF (INCMD(:2).EQ.'RE') THEN + IF (.NOT.NEWS_WRITE('References: '//REFERENCES(:LREF))) + & GO TO 900 + END IF + + CALL SYS$ASCTIM(,TODAY(:23),,) + + IF (LZONE.EQ.0) THEN + IF (SYS_TRNLNM_SYSTEM('LISP$TIME_ZONE',ZONE)) THEN + IER = OTS$CVT_TI_L(ZONE(:TRIM(ZONE)),DIFF,,%VAL(1)) + IF (DIFF.LT.0) THEN + PAST = .TRUE. + ZONE = ZONE(2:) + ELSE IF (DIFF.GT.12) THEN + PAST = .TRUE. + DIFF = 24 - DIFF + IER = OTS$CVT_L_TI(DIFF,ZONE(1:2),,,) + IF (ZONE(1:1).EQ.' ') ZONE = ZONE(2:) + ELSE + PAST = .FALSE. + END IF + IER = SYS_BINTIM('0 '//ZONE(:TRIM(ZONE))//':00',GMT) + IER = SYS$GETTIM(NOW) + IF (PAST) THEN + IER = LIB$ADDX(NOW,GMT,GMT) + ELSE + IER = LIB$SUBX(NOW,GMT,GMT) + END IF + IER = SYS$ASCTIM(,TODAY,GMT,) + ZONE = 'GMT' + ELSE IF (.NOT.SYS_TRNLNM_SYSTEM('MULTINET_TIMEZONE',ZONE) + & .AND..NOT.SYS_TRNLNM_SYSTEM('PMDF_TIMEZONE',ZONE)) THEN + ZONE = 'GMT' + END IF + LZONE = TRIM(ZONE) + END IF + + MSGID = TODAY(:2)//TODAY(4:6)//TODAY(10:11)//'.'// + & TODAY(13:14)//TODAY(16:17)//TODAY(19:20)//TODAY(22:23) + IF (MSGID(1:1).EQ.' ') MSGID = MSGID(2:) + IF (.NOT.NEWS_WRITE('Message-ID: <'//MSGID(:TRIM(MSGID))// + & PATHNAME(:LPATH)//'>')) GO TO 900 + + TODAY = TODAY(:2)//' '//TODAY(4:6)//' '//TODAY(10:20) + IF (TODAY(1:1).EQ.' ') TODAY = TODAY(2:) + + IF (LORGAN.EQ.0) THEN + IF (SYS_TRNLNM('BULL_NEWS_ORGANIZATION','DEFINED')) THEN + IER1 = SYS_TRNLNM('BULL_NEWS_ORGANIZATION',ORGANIZATION) + END IF + LORGAN = TRIM(ORGANIZATION) + END IF + + IF (LORGAN.GT.0) THEN + IF (.NOT.NEWS_WRITE('Organization: '//ORGANIZATION(:LORGAN))) + & GO TO 900 + END IF + + IF (.NOT.NEWS_WRITE('Date: '//TODAY(:TRIM(TODAY))//' '// + & ZONE(:LZONE))) GO TO 900 + + IF (FILENAME.EQ.'cancel') THEN + IF (.NOT.NEWS_WRITE('Control: cancel ' + & //MESSAGE_ID(:TRIM(MESSAGE_ID)))) RETURN + IF (.NOT.NEWS_WRITE('.')) RETURN + IF (.NOT.NEWS_READ()) RETURN + IF (BUFFER(:3).EQ.'240') IER = 0 + RETURN + END IF + + IF (.NOT.NEWS_WRITE(' ')) GO TO 900 + + IER1 = 0 + DO WHILE (IER1.EQ.0) + READ (3,'(Q,A)',IOSTAT=IER1) ILEN,BUFFER + IF (BUFFER(:ILEN).EQ.'.') THEN + BUFFER = '..' + ILEN = 2 + END IF + IF (IER1.EQ.0.AND..NOT.NEWS_WRITE(BUFFER(:ILEN))) GO TO 900 + END DO + + IF (.NOT.NEWS_WRITE('.')) GO TO 900 + IF (.NOT.NEWS_READ()) GO TO 900 + IF (BUFFER(:3).EQ.'240') THEN + IER = 0 + ELSE + WRITE (6,'('' ERROR: Server rejected your posting:'')') + WRITE (6,'(1X,A)') BUFFER(SB:EB) + END IF + +900 IF (FILENAME.NE.'cancel'.AND..NOT.FILEOPEN) CLOSE (UNIT=3) + + RETURN + END + + + + SUBROUTINE GET_PATHNAME + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /PATH/ PATHNAME,LPATH + CHARACTER*132 PATHNAME + + IF (NEWS_GETHOSTNAME(PATHNAME).EQ.-1) THEN + IF (.NOT.SYS_TRNLNM_SYSTEM('ARPANET_HOST_NAME',PATHNAME).AND. + & .NOT.SYS_TRNLNM_SYSTEM('INTERNET_HOST_NAME',PATHNAME).AND. + & .NOT.SYS_TRNLNM_SYSTEM('MX_NODE_NAME',PATHNAME)) THEN + WRITE (6,'('' ERROR: Cannot find local host name.'')') + RETURN + END IF + END IF + + IF (ALPHA(PATHNAME(:1))) PATHNAME = '@'//PATHNAME + + CALL LOWERCASE(PATHNAME) + LPATH = TRIM(PATHNAME) + + RETURN + END + + + + LOGICAL FUNCTION TEST_NEWS(NAME) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) NAME + + TEST_NEWS = .FALSE. + + DO I=1,LEN(NAME) + IF (NAME(I:I).NE.'.'.AND. + & (NAME(I:I).LT.'a'.OR.NAME(I:I).GT.'z')) RETURN + END DO + + TEST_NEWS = .TRUE. + + RETURN + END + + + + + SUBROUTINE NEWS2BULL + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /BUFFER/ BUFFER,SB,EB + CHARACTER BUFFER*1280 + + EXTERNAL BULLETIN_SUBCOMMANDS + + CHARACTER TIME*20,FIRST*80,FOLDER_SAVE*25 + + CHARACTER*6 NUMBER + + DIMENSION SAVE_F_NEWEST_BTIM(2) + + CALL ALLPRIV + + CALL NEWS_LIST + + CALL INIT_QUEUE(FOLDER_Q1,FOLDER_COM) + + FOLDER_Q = FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Find folders with news feed + CALL READ_FOLDER_FILE(IER) + IF (IER.EQ.0) THEN + SLIST = INDEX(FOLDER_DESCRIP,'<') + ELIST = INDEX(FOLDER_DESCRIP,'>') + IF (SLIST.GT.0.AND.ELIST.GT.SLIST) THEN + IF (FOLDER_DESCRIP(SLIST+1:SLIST+1).EQ.'@'.OR. + & TEST_NEWS(FOLDER_DESCRIP(SLIST+1:ELIST-1))) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + IF (NUM_FOLDERS.EQ.0.OR..NOT.NEWS_LOGIN()) CALL EXIT + + FOLDER_Q = FOLDER_Q1 + POINT_FOLDER = 0 + FILEOPEN = .FALSE. + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + IF (.NOT.FILEOPEN) THEN + POINT_FOLDER = POINT_FOLDER + 1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + CALL SELECT_FOLDER(.FALSE.,IER) + CALL COPY2(SAVE_F_NEWEST_BTIM,F_NEWEST_BTIM) + FOLDER_SAVE = FOLDER + FOLDER_DESCRIP = FOLDER_DESCRIP(INDEX(FOLDER_DESCRIP,'<')+1:) + FOLDER_DESCRIP = FOLDER_DESCRIP(:INDEX(FOLDER_DESCRIP,'>')-1) + IF (FOLDER_DESCRIP(1:1).EQ.'@'.AND.IER) THEN + OPEN (UNIT=3,FILE=FOLDER_DESCRIP(2:TRIM(FOLDER_DESCRIP)) + & ,STATUS='OLD',IOSTAT=IER1) + IF (IER1.EQ.0) THEN + READ (3,'(A)',IOSTAT=IER1) FOLDER_DESCRIP + IF (IER1.NE.0) CLOSE (UNIT=3) + IF (IER1.EQ.0) FILEOPEN = .TRUE. + END IF + ELSE + IER1 = 0 + END IF + END IF + IF (IER.AND.IER1.EQ.0) THEN + FOLDER_NUMBER = -1 + FOLDER1 = FOLDER_DESCRIP(:TRIM(FOLDER_DESCRIP)) + CALL SELECT_FOLDER(.FALSE.,IER) + IF (IER) THEN + CALL REMOTE_GET_NEWEST_MSG(SAVE_F_NEWEST_BTIM,START) + IF (START.GE.F_START) THEN + CALL OTS$CVT_L_TI(START,NUMBER,,,) + INCMD = 'COPY/ORIGINAL '//FOLDER_SAVE(:TRIM( + & FOLDER_SAVE))//' '//NUMBER//'-LAST' + CALL CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + CALL MOVE(.FALSE.) + END IF + END IF + IF (FILEOPEN) THEN + READ (3,'(A)',IOSTAT=IER1) FOLDER_DESCRIP + IF (IER1.NE.0) CLOSE (UNIT=3) + IF (IER1.NE.0) FILEOPEN = .FALSE. + END IF + END IF + END DO + + CALL EXIT + END + + + + SUBROUTINE DATE_TIME(TIME) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*36 MONTH + DATA MONTH/'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'/ + + CHARACTER*(*) TIME + + NMONTH = (INDEX(MONTH,TIME(4:6))+2)/3 + + IF (TIME(1:1).EQ.' ') TIME(1:1) = '0' + + TIME = TIME(10:11)//CHAR(ICHAR('0')+NMONTH/10)//CHAR(ICHAR('0')+ + & MOD(NMONTH,10))//TIME(1:2)//' '//TIME(13:14)// + & TIME(16:17)//TIME(19:20) + + RETURN + END + + + + SUBROUTINE ALLPRIV + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + PROCPRIV(1) = -1 + PROCPRIV(2) = -1 + NEEDPRIV(1) = -1 + NEEDPRIV(2) = -1 + + RETURN + END + + + + SUBROUTINE NEWS_NEW_FOLDER + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + READ (7,IOSTAT=IER,KEYEQ=1000,KEYID=1) NEWS_FOLDER_COM + + NEWS_FOLDER1 = FOLDER1 + NEWS_FOLDER1_DESCRIP = FOLDER1_DESCRIP(26:) + + DO WHILE (IER.EQ.0) + READ (7,IOSTAT=IER,KEYEQ=NEWS_F_END,KEYID=1) + IF (IER.EQ.0) NEWS_F_END = NEWS_F_END + 1 + END DO + + NEWS_FOLDER1_NUMBER = NEWS_F_END + CALL SYS_BINTIM('-',NEWS_F1_NEWEST_BTIM) + WRITE (7,IOSTAT=IER) NEWS_FOLDER1_COM + + READ (7,KEYEQ=1000,KEYID=1) NEWS_FOLDER1_COM + NEWS_F1_END = NEWS_F_END + REWRITE (7) NEWS_FOLDER1_COM + + RETURN + END + + + + SUBROUTINE SUBSCRIBE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + IF (REMOTE_SET.NE.3) THEN + WRITE (6,'('' ERROR: Selected folder is not a news folder.'')') + RETURN + END IF + + I = 1 + DO WHILE (LAST_NEWS_READ2(1,I).NE.NEWS_FOLDER_NUMBER.AND. + & LAST_NEWS_READ2(1,I).NE.0.AND.I.LE.FOLDER_MAX-1) + I = I + 1 + END DO + + IF (I.GT.FOLDER_MAX-1) THEN + WRITE (6,'('' ERROR: Cannot subscribe. You have '', + & '' reached the news folder limit of '',I,''.'')') + & FOLDER_MAX-1 + RETURN + ELSE IF (LAST_NEWS_READ2(1,I).EQ.NEWS_FOLDER_NUMBER) THEN + WRITE (6,'('' You are already subscribed to '',A,''.'')') + & FOLDER_NAME(:TRIM(FOLDER_NAME)) + RETURN + ELSE + WRITE (6,'('' You are now subscribed to '',A,''.'')') + & FOLDER_NAME(:TRIM(FOLDER_NAME)) + END IF + + LAST_NEWS_READ2(1,I) = NEWS_FOLDER_NUMBER + IF (F_START.LE.F_NBULL) THEN + LAST_NEWS_READ2(2,I) = MIN(8191,F_NBULL-(F_START-1)) + LAST_NEWS_READ(2,I) = F_START - 1 + ELSE + LAST_NEWS_READ2(2,I) = 0 + LAST_NEWS_READ(2,I) = F_NBULL + END IF + + RETURN + END + + + + + + SUBROUTINE UNSUBSCRIBE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + I = NEWS_FIND_SUBSCRIBE() + + IF (I.GT.FOLDER_MAX-1) THEN + WRITE (6,'('' ERROR: You are not subscribed to '',A,''.'')') + & FOLDER_NAME(:TRIM(FOLDER_NAME)) + RETURN + ELSE + WRITE (6,'('' You are now no longer subscribed to '',A,''.'')') + & FOLDER_NAME(:TRIM(FOLDER_NAME)) + END IF + + DO J=I,FOLDER_MAX-2 + CALL COPY2(LAST_NEWS_READ(1,J),LAST_NEWS_READ(1,J+1)) + END DO + + LAST_NEWS_READ(1,FOLDER_MAX-1) = 0 + LAST_NEWS_READ(2,FOLDER_MAX-1) = 0 + + CALL FREE_TAGS(I) + + RETURN + END + + + + SUBROUTINE NEWS_GET_NEWEST_MESSAGE(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + I = NEWS_FIND_SUBSCRIBE() + + IER = LAST_NEWS_READ(2,I) + 1 + + IF (I.GT.FOLDER_MAX-1.OR.IER.GT.F_NBULL) THEN + IER = 0 + RETURN + END IF + + RETURN + END + + + + SUBROUTINE NEWS_UPDATE_NEWEST_MESSAGE(NUMBER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + I = NEWS_FIND_SUBSCRIBE() + + IF (I.GT.FOLDER_MAX-1) RETURN + + IF (NUMBER.GT.LAST_NEWS_READ(2,I)) THEN + LAST_NEWS_READ(2,I) = NUMBER + LAST_NEWS_READ2(2,I) = MIN(8191,F_NBULL-NUMBER) + & .OR.(LAST_NEWS_READ2(2,I).AND.'C000'X) + END IF + + RETURN + END + + + + + + SUBROUTINE NEWS_GET_SUBSCRIBE(SUBNUM,SUBMSG) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + IF (SUBNUM.EQ.0) THEN + COUNT = 0 + SUBMSG = LAST_NEWS_READ(2,1) + RETURN + ELSE IF (SUBNUM.EQ.-1) THEN + DO J=COUNT,FOLDER_MAX-1 + CALL COPY2(LAST_NEWS_READ(1,J),LAST_NEWS_READ(1,J+1)) + END DO + + LAST_NEWS_READ(1,FOLDER_MAX-1) = 0 + LAST_NEWS_READ(2,FOLDER_MAX-1) = 0 + ELSE IF (SUBNUM.GT.0) THEN + COUNT = COUNT + 1 + END IF + + IF (COUNT.LE.FOLDER_MAX-1) THEN + SUBNUM = LAST_NEWS_READ2(1,COUNT) + SUBMSG = LAST_NEWS_READ(2,COUNT) + ELSE + SUBNUM = 0 + END IF + + RETURN + END + + + + + SUBROUTINE NEWS_NEW_NOTIFICATION(MESSAGES) +C +C SUBROUTINE NEW_NOTIFICATION +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /POINT/ BULL_POINT + + COMMON /LOGIN_BTIM/ LOGIN_BTIM_SAVE(2) + + MESSAGES = .FALSE. + + IF (.NOT.SYS_TRNLNM('BULL_NEWS_SERVER','DEFINED')) RETURN + + CALL NEWS_GET_SUBSCRIBE(0,MSGNUM) + IF (MSGNUM.EQ.0) RETURN + + CALL OPEN_BULLNEWS_SHARED + SUBNUM = 1 + + DO WHILE (SUBNUM.GT.0) + IER = 1 + DO WHILE (SUBNUM.NE.0.AND.IER.NE.0) + CALL NEWS_GET_SUBSCRIBE(SUBNUM,MSGNUM) + IF (SUBNUM.NE.0) THEN + CALL READ_FOLDER_FILE_KEYNUM(SUBNUM,IER) + IF (IER.EQ.0.AND. + & MSGNUM.GT.F_NBULL.AND.F_START.LE.F_NBULL) THEN + CALL NEWS_UPDATE_NEWEST_MESSAGE(F_START) + ELSE IF (IER.NE.0) THEN + SUBNUM = -1 + ELSE IF (MSGNUM.GE.F_NBULL.OR.F_NBULL.EQ.0.OR. + & F_START.GT.F_NBULL) THEN + IER = 1 + END IF + END IF + IF (IER.EQ.0.AND.SUBNUM.GT.0) THEN + IF (READIT.EQ.1) THEN + IF (.NOT.TEST_BRIEF_FLAG(NEWS_FOLDER_NUMBER).AND. + & .NOT.TEST_SET_FLAG(NEWS_FOLDER_NUMBER)) THEN + IER = 1 + ELSE IF (.NOT.TEST_BRIEF_FLAG(NEWS_FOLDER_NUMBER).OR. + & .NOT.TEST_SET_FLAG(NEWS_FOLDER_NUMBER).OR. + & NEW_FLAG(2).NE.-1) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + IF (DIFF.GT.0) IER = 1 + END IF + END IF + END IF + END DO + IF (READIT.EQ.0.AND.SUBNUM.GT.0) THEN + WRITE (6,'('' There are new messages in folder '', + & A,''.'',$)') FOLDER_DESCRIP(1:TRIM(FOLDER_DESCRIP)) + MESSAGES = .TRUE. + ELSE IF (SUBNUM.GT.0) THEN + IF (TEST_BRIEF_FLAG(NEWS_FOLDER_NUMBER) + & .AND.TEST_SET_FLAG(NEWS_FOLDER_NUMBER)) THEN + WRITE (6,'('' There are new messages in folder '' + & A,''.'',$)') FOLDER_DESCRIP(1:TRIM(FOLDER_DESCRIP)) + ELSE + CALL CLOSE_BULLNEWS + CALL SELECT_FOLDER(.FALSE.,IER1) + IF (IER1) THEN + CALL LOGIN_FOLDER + IF (BULL_POINT.NE.-1) THEN + IF (.NOT.TEST_BRIEF_FLAG(NEWS_FOLDER_NUMBER)) THEN + SAVE_BULL_POINT = BULL_POINT + REDO = .TRUE. + DO WHILE (REDO) + REDO = .FALSE. + CALL READNEW(REDO) + IF (REDO) CALL REDISPLAY_DIRECTORY + BULL_POINT = SAVE_BULL_POINT + END DO + END IF + END IF + END IF + CALL OPEN_BULLNEWS_SHARED + END IF + END IF + END DO + + CALL CLOSE_BULLNEWS + + RETURN + END + + + + LOGICAL FUNCTION TEST_SET_FLAG(NUMBER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + IF (NUMBER.GE.0.AND.NUMBER.LE.FOLDER_MAX-1) THEN + TEST_SET_FLAG = TEST2(SET_FLAG,NUMBER) + RETURN + END IF + + I = NEWS_FIND_SUBSCRIBE() + + TEST_SET_FLAG = BTEST(LAST_NEWS_READ2(2,I),14) + + RETURN + END + + + + + LOGICAL FUNCTION TEST_BRIEF_FLAG(NUMBER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + IF (NUMBER.GE.0.AND.NUMBER.LE.FOLDER_MAX-1) THEN + TEST_BRIEF_FLAG = TEST2(BRIEF_FLAG,NUMBER) + RETURN + END IF + + I = NEWS_FIND_SUBSCRIBE() + + TEST_BRIEF_FLAG = BTEST(LAST_NEWS_READ2(2,I),15) + + RETURN + END + + + + INTEGER FUNCTION NEWS_FIND_SUBSCRIBE() + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + I = 1 + DO WHILE (LAST_NEWS_READ2(1,I).NE.NEWS_FOLDER_NUMBER + & .AND.I.LE.FOLDER_MAX-1) + I = I + 1 + END DO + + NEWS_FIND_SUBSCRIBE = I + + RETURN + END + + + + + SUBROUTINE NEWS_SET_USER_FLAG(NOTIFY,READNEW,BRIEF) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + I = NEWS_FIND_SUBSCRIBE() + + IF (I.GT.FOLDER_MAX-1) THEN + WRITE (6,'('' ERROR: NEWS FOLDER is not subscribed.'')') + RETURN + END IF + + IF (NOTIFY.EQ.1) THEN + WRITE (6,'('' ERROR: NOTIFY cannot be set for news folder.'')') + RETURN + END IF + + IF (READNEW.EQ.1) LAST_NEWS_READ2(2,I) = IBSET(LAST_NEWS_READ2(2,I),14) + IF (READNEW.EQ.0) LAST_NEWS_READ2(2,I) = IBCLR(LAST_NEWS_READ2(2,I),14) + IF (BRIEF.EQ.1) LAST_NEWS_READ2(2,I) = IBSET(LAST_NEWS_READ2(2,I),15) + IF (BRIEF.EQ.0) LAST_NEWS_READ2(2,I) = IBCLR(LAST_NEWS_READ2(2,I),15) + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin11.for b/decus/vax91b/gce91b/net91b/bulletin11.for new file mode 100644 index 0000000..cab0ef0 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin11.for @@ -0,0 +1,1385 @@ +C +C BULLETIN11.FOR, Version 8/25/91 +C Purpose: Bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + SUBROUTINE TAG(ADD_OR_DEL,TAG_TYPE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + DATA BULL_TAG /.FALSE./,READ_TAG /.FALSE./,BULL_NEWS_TAG /.FALSE./ + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER*12 TAG_KEY + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + IF ((.NOT.BULL_TAG.AND.REMOTE_SET.NE.3) + & .OR.(.NOT.BULL_NEWS_TAG.AND.REMOTE_SET.EQ.3)) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + IF (REMOTE_SET.EQ.3) THEN + IF (NEWS_FIND_SUBSCRIBE().GT.FOLDER_MAX-1) THEN + WRITE (6,'('' ERROR: NEWS group is not subscribed.'')') + RETURN + END IF + END IF + + IF (ADD_OR_DEL.AND. + & INCMD(:4).NE.'MARK'.AND.INCMD(:4).NE.'SEEN') THEN + CALL ADD_TAG(IER,TAG_TYPE) + RETURN + END IF + + IF (INCMD(:4).EQ.'SEEN') THEN + IF (CLI$PRESENT('READ').EQ.%LOC(CLI$_NEGATED)) THEN + READ (13,KEYEQ=TAG_KEY(0,BULLDIR_HEADER,1), + & IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=13) + BULL_TAG = IBCLR(BULL_TAG,1) + RETURN + END IF + END IF + + IF (.NOT.CLI$PRESENT('NUMBER')) THEN + IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + WRITE(6,1010) ! No, then error. + RETURN + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER,TAG_TYPE) + ELSE + CALL DEL_TAG(IER,TAG_TYPE) + IF (IER.NE.0) THEN + IF (TAG_TYPE.EQ.1) THEN + WRITE (6,'('' ERROR: Message was not marked.'')') + ELSE + WRITE (6,'('' ERROR: Message was not seen.'')') + END IF + END IF + END IF + RETURN + END IF + + CALL OPEN_BULLDIR_SHARED + + IER1 = 0 + DO WHILE (CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + & .NE.%LOC(CLI$_ABSENT).AND.IER1.EQ.0) ! Get the specified messages + + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) + + IF (SBULL.LE.0.OR.IER.NE.0.OR.SBULL.GT.F_NBULL) THEN + WRITE (6,'(A)') + & ' ERROR: Specified message number has incorrect format.' + GO TO 100 + END IF + + DO MESSAGE_NUMBER = SBULL,MIN(EBULL,F_NBULL) + + CALL READDIR(MESSAGE_NUMBER,IER) + IF (IER.NE.MESSAGE_NUMBER+1 ! Was message found? + & .AND.REMOTE_SET.NE.3) THEN ! Ignore if news + WRITE(6,1030) MESSAGE_NUMBER ! No + GO TO 100 + ELSE IF (ADD_OR_DEL) THEN + CALL ADD_TAG(IER,TAG_TYPE) + ELSE + CALL DEL_TAG(IER,TAG_TYPE) + END IF + END DO + END DO + +100 IF (REMOTE_SET.EQ.3) CALL READDIR(BULL_POINT,IER) + + CALL CLOSE_BULLDIR + + RETURN + +1010 FORMAT(' ERROR: You have not read any message.') +1030 FORMAT(' ERROR: Message was not found: ',I) + + END + + + + SUBROUTINE ADD_TAG(IER,TAG_TYPE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + CHARACTER*12 TAG_KEY + + IF (REMOTE_SET.NE.3) THEN + IF (TAG_TYPE.EQ.2.AND..NOT.BTEST(BULL_TAG,1)) THEN ! No SEEN tags + WRITE (13,IOSTAT=IER) TAG_KEY(0,BULLDIR_HEADER,1) + BULL_TAG = IBSET(BULL_TAG,1) + END IF + WRITE (13,IOSTAT=IER) TAG_KEY(FOLDER_NUMBER,MSG_KEY,TAG_TYPE) + ELSE + CALL ADD_NEWS_TAG(IER,TAG_TYPE) + RETURN + END IF + + IF (IER.NE.FOR$IOS_INCKEYCHG.AND.IER.NE.0) THEN + WRITE (6,'('' ERROR: Unable to mark message.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + ELSE + IER = 0 + END IF + + RETURN + END + + + + + SUBROUTINE GET_FIRST_NEWS_TAG(IER,MESSAGE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) + + COMMON /NEWS_MARK/ NEWS_MARK + DIMENSION NEWS_MARK(128) + INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC + EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) + EQUIVALENCE (NEWS_MARK2(1),NEWS_NUMBER) + EQUIVALENCE (NEWS_MARK2(2),NEWS_REC) + EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + COMMON /NEXT/ NEXT + + IER = 36 + + SUBNUM = NEWS_FIND_SUBSCRIBE() + + IF (SUBNUM.GT.FOLDER_MAX-1) RETURN + + DO J=1,2 + IF (BTEST(READ_TAG,J)) I = J + END DO + + IF (NEWS_TAG(3,I,SUBNUM).EQ.0) RETURN + + OLD_NEXT = NEXT + + NEXT = .FALSE. + J = F_START - 1 + IER1 = J + DO WHILE (J.LE.F_NBULL.AND.J+1.NE.IER1) + J = J + 1 + CALL READDIR(J,IER1) + END DO + + IF (J+1.NE.IER1) THEN + NEXT = OLD_NEXT + RETURN + END IF + + NEXT = .TRUE. + + DO MESSNUM = NEWS_TAG(1,I,SUBNUM),NEWS_TAG(2,I,SUBNUM) + TEST = TEST_TAG(MESSNUM,%VAL(NEWS_TAG(3,I,SUBNUM)), + & NEWS_TAG(1,I,SUBNUM)) + IF (BTEST(READ_TAG,3)) TEST = .NOT.TEST + IF (TEST) THEN + HEADER = .TRUE. + CALL GET_NEXT_NEWS_TAG(IER,MESSNUM,HEADER,I,SUBNUM) + IF (IER.EQ.0) MESSAGE = MESSNUM + NEXT = OLD_NEXT + RETURN + END IF + END DO + + NEXT = OLD_NEXT + + RETURN + + ENTRY GET_THIS_NEWS_TAG(IER,MESSAGE,TAG_TYPE) + + IER = 36 + + SUBNUM = NEWS_FIND_SUBSCRIBE() + + IF (SUBNUM.GT.FOLDER_MAX-1) RETURN + + TAG_TYPE = 0 + + DO I=1,2 + IF ((BTEST(READ_TAG,I).OR.BTEST(READ_TAG,3)) + & .AND.(NEWS_TAG(3,I,SUBNUM).GT.0).AND. + & (MSG_NUM.LE.NEWS_TAG(2,I,SUBNUM))) THEN + TEST = TEST_TAG(MSG_NUM, + & %VAL(NEWS_TAG(3,I,SUBNUM)),NEWS_TAG(1,I,SUBNUM)) + IF (TEST) THEN + IER = 0 + TAG_TYPE = IBSET(TAG_TYPE,I) + END IF + END IF + END DO + + IF (BTEST(READ_TAG,3)) THEN + IF ((.NOT.BTEST(TAG_TYPE,2).OR..NOT.BTEST(READ_TAG,2)).AND. + & (.NOT.BTEST(TAG_TYPE,1).OR..NOT.BTEST(READ_TAG,1))) THEN + IER = 0 + ELSE + IER = 36 + END IF + END IF + + RETURN + + ENTRY GET_THIS_OR_NEXT_NEWS_TAG(NUM,IER,MESSAGE,TAG_TYPE) + + IER = 36 + + SUBNUM = NEWS_FIND_SUBSCRIBE() + + IF (SUBNUM.GT.FOLDER_MAX-1) RETURN + + HEADER = .FALSE. + + TAG_TYPE = 0 + + DO WHILE (IER.NE.0) + I = 0 + DO J=1,2 + IF (NEWS_TAG(3,J,SUBNUM).GT.0.AND.BTEST(READ_TAG,J)) THEN + IER = 36 + MNUM = MAX(NEWS_TAG(1,J,SUBNUM),NUM) + DO WHILE (IER.NE.0.AND.MNUM.LE.NEWS_TAG(2,J,SUBNUM)) + TEST = TEST_TAG(MNUM,%VAL(NEWS_TAG(3,J,SUBNUM)), + & NEWS_TAG(1,J,SUBNUM)) + IF (BTEST(READ_TAG,3)) TEST = .NOT.TEST + IF (TEST) THEN + IER = 0 + ELSE + MNUM = MNUM + 1 + END IF + END DO + IF (IER.EQ.0) THEN + IF (J.EQ.1) THEN + MESSAGE = MNUM + I = 1 + ELSE IF (I.EQ.0.OR.MESSAGE.GT.MNUM) THEN + MESSAGE = MNUM + I = 2 + END IF + END IF + END IF + END DO + IF (I.EQ.0) RETURN + CALL GET_NEXT_NEWS_TAG(IER,MESSAGE,HEADER,I,SUBNUM) + IF (IER.EQ.0) THEN + IF (.NOT.BTEST(READ_TAG,3)) TAG_TYPE = IBSET(TAG_TYPE,I) + IF (NEWS_TAG(3,3-I,SUBNUM).GT.0.AND. + & MESSAGE.LE.NEWS_TAG(2,3-I,SUBNUM).AND. + & TEST_TAG(MESSAGE,%VAL(NEWS_TAG(3,3-I,SUBNUM)), + & NEWS_TAG(1,3-I,SUBNUM))) THEN + TAG_TYPE = IBSET(TAG_TYPE,3-I) + END IF + RETURN + ELSE IF (.NOT.BTEST(READ_TAG,3-I)) THEN + RETURN + END IF + END DO + + RETURN + END + + + + + SUBROUTINE GET_NEXT_NEWS_TAG(IER,MESSNUM,HEADER,J,SUBNUM) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + COMMON /NEXT/ NEXT + + IER = 36 + + OLD_NEXT = NEXT + + DO WHILE (MESSNUM.LE.NEWS_TAG(2,J,SUBNUM).AND.IER.NE.0) + I = MAX(NEWS_TAG(1,J,SUBNUM),MESSNUM) + DO WHILE (IER.NE.0.AND.I.LE.NEWS_TAG(2,J,SUBNUM)) + TEST = TEST_TAG(I,%VAL(NEWS_TAG(3,J,SUBNUM)), + & NEWS_TAG(1,J,SUBNUM)) + IF (BTEST(READ_TAG,3)) TEST = .NOT.TEST + IF (TEST) THEN + IER = 0 + MESSNUM = I + ELSE + I = I + 1 + END IF + END DO + IF (IER.EQ.0) THEN + SAVE_MESSNUM = MESSNUM + NEXT = .FALSE. + CALL READDIR(MESSNUM,IER1) + IF (IER1.NE.MESSNUM+1) THEN + NEXT = .TRUE. + CALL READDIR(MESSNUM,IER1) + END IF + IF (IER1.NE.MESSNUM+1) THEN + IER = 36 + IF (.NOT.BTEST(READ_TAG,3)) THEN + CALL DEL_NEWS_TAG(J,MESSNUM,SUBNUM) + ELSE + NEXT = OLD_NEXT + RETURN + END IF + IF (BTEST(READ_TAG,1).AND.BTEST(READ_TAG,2)) RETURN + ELSE IF (MESSNUM.NE.SAVE_MESSNUM) THEN + IER = 36 + IF (.NOT.BTEST(READ_TAG,3)) THEN + CALL DEL_NEWS_TAG(J,SAVE_MESSNUM,SUBNUM) + END IF + END IF + ELSE + MESSNUM = NEWS_TAG(2,J,SUBNUM) + 1 + END IF + END DO + + IF (IER.EQ.0.AND.HEADER) THEN + MESSNUM = MESSNUM - 1 + MSG_NUM = MESSNUM + END IF + + NEXT = OLD_NEXT + + RETURN + END + + + + + SUBROUTINE ADD_NEWS_TAG(IER,TAG_TYPE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) + + IER = 0 + + SUBNUM = NEWS_FIND_SUBSCRIBE() + IF (SUBNUM.GT.FOLDER_MAX-1) RETURN + + IF (NEWS_TAG(3,TAG_TYPE,SUBNUM).EQ.0.AND.F_NBULL.GE.F_START) THEN + NEWS_TAG(1,TAG_TYPE,SUBNUM) = F_START + NEWS_TAG(2,TAG_TYPE,SUBNUM) = F_NBULL + CALL LIB$GET_VM((F_NBULL-F_START)/8+1, + & NEWS_TAG(3,TAG_TYPE,SUBNUM)) + CALL ZERO_VM((F_NBULL-F_START)/8+1, + & %VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM))) + ELSE IF (F_NBULL.GT.NEWS_TAG(2,TAG_TYPE,SUBNUM)) THEN + DO I=1,2 + IF (NEWS_TAG(1,I,SUBNUM).GT.0) THEN + CALL LIB$GET_VM((F_NBULL-NEWS_TAG(1,I,SUBNUM))/8+1,TEMP) + CALL ZERO_VM((F_NBULL-NEWS_TAG(1,I,SUBNUM))/8+1, + & %VAL(TEMP)) + CALL LIB$MOVC3((NEWS_TAG(2,I,SUBNUM)- + & NEWS_TAG(1,I,SUBNUM))/8+1, + & %VAL(NEWS_TAG(3,I,SUBNUM)),%VAL(TEMP)) + CALL LIB$FREE_VM((NEWS_TAG(2,I,SUBNUM)- + & NEWS_TAG(1,I,SUBNUM))/8+1, + & NEWS_TAG(3,I,SUBNUM)) + NEWS_TAG(2,I,SUBNUM) = F_NBULL + NEWS_TAG(3,I,SUBNUM) = TEMP + END IF + END DO + END IF + + CALL SET_TAG(MSG_NUM,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)), + & NEWS_TAG(1,TAG_TYPE,SUBNUM)) + NEWS_TAG(4,TAG_TYPE,SUBNUM) = 1 + + RETURN + END + + + + SUBROUTINE SET_TAG(NUM,TAGS,START) + + IMPLICIT INTEGER (A-Z) + + DIMENSION TAGS(1) + + I = (NUM-START)/32 + J = NUM - START - I*32 + + TAGS(I+1) = IBSET(TAGS(I+1),J) + + RETURN + END + + + + SUBROUTINE CLR_TAG(NUM,TAGS,START) + + IMPLICIT INTEGER (A-Z) + + DIMENSION TAGS(1) + + I = (NUM-START)/32 + J = NUM - START - I*32 + + TAGS(I+1) = IBCLR(TAGS(I+1),J) + + RETURN + END + + + + LOGICAL FUNCTION TEST_TAG(NUM,TAGS,START) + + IMPLICIT INTEGER (A-Z) + + DIMENSION TAGS(1) + + I = (NUM-START)/32 + J = NUM - START - I*32 + + TEST_TAG = BTEST(TAGS(I+1),J) + + RETURN + END + + + + SUBROUTINE DEL_TAG(IER,TAG_TYPE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*12 TAG_KEY + + IER = 0 + + IF (REMOTE_SET.EQ.3) THEN + SUBNUM = NEWS_FIND_SUBSCRIBE() + CALL DEL_NEWS_TAG(TAG_TYPE,MSG_NUM,SUBNUM) + RETURN + END IF + + DO WHILE (REC_LOCK(IER1)) + READ (13,KEYEQ=TAG_KEY(FOLDER_NUMBER,MSG_KEY,TAG_TYPE), + & IOSTAT=IER1) + END DO + IF (IER1.NE.0) RETURN + + DELETE (UNIT=13,IOSTAT=IER1) + + RETURN + END + + + + SUBROUTINE DEL_NEWS_TAG(TAG_TYPE,MSG_NUM,SUBNUM) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) + + IF (MSG_NUM.LT.NEWS_TAG(1,TAG_TYPE,SUBNUM).OR. + & MSG_NUM.GT.NEWS_TAG(2,TAG_TYPE,SUBNUM).OR..NOT.TEST_TAG + & (MSG_NUM,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)) + & ,NEWS_TAG(1,TAG_TYPE,SUBNUM))) THEN + RETURN + ELSE + NEWS_TAG(4,TAG_TYPE,SUBNUM) = 1 + CALL CLR_TAG + & (MSG_NUM,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)), + & NEWS_TAG(1,TAG_TYPE,SUBNUM)) + END IF + + RETURN + END + + + + SUBROUTINE OPEN_OLD_TAG + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /NEWS_MARK/ NEWS_MARK + DIMENSION NEWS_MARK(128) + INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC + EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) + EQUIVALENCE (NEWS_MARK2(1),NEWS_NUMBER) + EQUIVALENCE (NEWS_MARK2(2),NEWS_REC) + EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) + + CHARACTER*10 BULL_MARK_DIR + + CHARACTER*12 TAG_KEY + + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + IF (IER) THEN + BULL_MARK_DIR = 'BULL_MARK:' + ELSE + BULL_MARK_DIR = 'SYS$LOGIN:' + END IF + + NTRIES = 0 + + DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) + OPEN (UNIT=13,FILE=BULL_MARK_DIR// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + NTRIES = NTRIES + 1 + END DO + + IF (IER.EQ.0) THEN + BULL_TAG = IBSET(BULL_TAG,0) + DO WHILE (REC_LOCK(IER1)) + READ (13,KEY=TAG_KEY(0,BULLDIR_HEADER,1),IOSTAT=IER1) + END DO + IF (IER1.EQ.0) BULL_TAG = IBSET(BULL_TAG,1) + END IF + + NTRIES = 0 + + IF (IER.EQ.0.OR.IER.EQ.FOR$IOS_FILNOTFOU) THEN + DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) + OPEN (UNIT=23,FILE=BULL_MARK_DIR// + & USERNAME(:TRIM(USERNAME))//'.NEWSMARK',STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:4:INTEGER)) + NTRIES = NTRIES + 1 + END DO + + IF (IER.EQ.0) THEN + IF (BULL_NEWS_TAG) RETURN + BULL_NEWS_TAG = .TRUE. + END IF + END IF + + IF (IER.NE.0.AND.IER.NE.FOR$IOS_FILNOTFOU) THEN + WRITE (6,'('' Unable to open mark file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + RETURN + END IF + + IF (BULL_NEWS_TAG) THEN + OLD_NEWS_NUMBER = 0 + FOLDER_NUMBER_SAVE = NEWS_FOLDER_NUMBER + CALL OPEN_BULLNEWS_SHARED + DO WHILE (IER.EQ.0) + DO WHILE (REC_LOCK(IER)) + READ (23,IOSTAT=IER) NEWS_MARK + END DO + IF (IER.EQ.0) THEN + IF (NEWS_NUMBER.NE.OLD_NEWS_NUMBER) THEN + NEWS_FOLDER_NUMBER = NEWS_NUMBER + SUBNUM = NEWS_FIND_SUBSCRIBE() + IF (SUBNUM.GT.FOLDER_MAX-1) THEN + DELETE (UNIT=23) + ELSE + OLD_NEWS_NUMBER = NEWS_NUMBER + CALL READ_FOLDER_FILE_KEYNUM_TEMP + & (NEWS_FOLDER_NUMBER,IER1) + IF (IER1.NE.0) THEN + SUBNUM = 0 + ELSE + DO I=1,2 + NEWS_TAG(1,I,SUBNUM) = F1_START + NEWS_TAG(2,I,SUBNUM) = F1_NBULL + NEWS_TAG(4,I,SUBNUM) = 0 + CALL LIB$GET_VM((F1_NBULL-F1_START)/8+1, + & NEWS_TAG(3,I,SUBNUM)) + CALL ZERO_VM((F1_NBULL-F1_START)/8+1, + & %VAL(NEWS_TAG(3,I,SUBNUM))) + END DO + END IF + END IF + END IF + IF (NEWS_NUMBER.EQ.OLD_NEWS_NUMBER) THEN + IF (SUBNUM.EQ.0) THEN + DELETE (UNIT=23) + ELSE + IF (NEWS_REC.GT.0) THEN + TAG_TYPE = 1 + ELSE + TAG_TYPE = 2 + END IF + IF (NEWS_FORMAT.EQ.0) THEN ! 16 bit numbers + DO I=5,256 + CALL SET_NEWS(INT(NEWS_MARK2(I)),SUBNUM, + & TAG_TYPE) + END DO + ELSE + DO I=3,128 + CALL SET_NEWS(NEWS_MARK(I),SUBNUM,TAG_TYPE) + END DO + END IF + END IF + END IF + END IF + END DO + NEWS_FOLDER_NUMBER = FOLDER_NUMBER_SAVE + CALL CLOSE_BULLNEWS + END IF + + RETURN + END + + + + SUBROUTINE SET_NEWS(NUM,SUBNUM,TAG_TYPE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) + + IF (NUM.GT.0) THEN + LAST_NUM = NUM + IF (NUM.LT.NEWS_TAG(1,TAG_TYPE,SUBNUM).OR. + & NUM.GT.NEWS_TAG(2,TAG_TYPE,SUBNUM)) RETURN + CALL SET_TAG(NUM,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)), + & NEWS_TAG(1,TAG_TYPE,SUBNUM)) + ELSE IF (NUM.LT.0) THEN + IF (-NUM.LT.NEWS_TAG(1,TAG_TYPE,SUBNUM)) RETURN + DO J=MAX(NEWS_TAG(1,TAG_TYPE,SUBNUM),LAST_NUM+1), + & MIN(NEWS_TAG(2,TAG_TYPE,SUBNUM),-NUM) + CALL SET_TAG(J,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)), + & NEWS_TAG(1,TAG_TYPE,SUBNUM)) + END DO + END IF + + RETURN + END + + + + SUBROUTINE OPEN_NEW_TAG(IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*10 BULL_MARK_DIR + + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + IF (IER) THEN + BULL_MARK_DIR = 'BULL_MARK:' + ELSE + BULL_MARK_DIR = 'SYS$LOGIN:' + END IF + + IER1 = SYS_TRNLNM_SYSTEM('BULL_MARK',BULL_PARAMETER) + IF (.NOT.IER1) THEN + IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) + CALL DISABLE_PRIVS + IER1 = .FALSE. + END IF + IF (REMOTE_SET.NE.3) THEN + MARKUNIT = 13 + OPEN (UNIT=MARKUNIT,FILE=BULL_MARK_DIR// + & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & RECORDSIZE=3, + & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + ELSE + MARKUNIT = 23 + OPEN (UNIT=MARKUNIT,FILE=BULL_MARK_DIR// + & USERNAME(:TRIM(USERNAME))//'.NEWSMARK',STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, + & RECORDSIZE=128, + & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:4:INTEGER)) + END IF + IF (.NOT.IER1) CALL ENABLE_PRIVS + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot create mark file.'')') + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + IER = 0 + ELSE + CALL SYS_GETMSG(IER1) + IER = IER1 + END IF + ELSE + IF (.NOT.IER1) THEN + INQUIRE (UNIT=MARKUNIT,NAME=BULL_PARAMETER) + WRITE (6,'('' Created MARK file: '',A)') + & BULL_PARAMETER(:TRIM(BULL_PARAMETER)) + END IF + IF (MARKUNIT.EQ.13) BULL_TAG = 1 + IF (MARKUNIT.EQ.23) BULL_NEWS_TAG = .TRUE. + IER = 1 + END IF + + RETURN + END + + + + CHARACTER*12 FUNCTION TAG_KEY(FOLDER_NUMBER,MSG_KEY,TAG_TYPE) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) MSG_KEY + + IF (TAG_TYPE.EQ.1) THEN + CALL LIB$MOVC3(4,FOLDER_NUMBER,%REF(TAG_KEY)) + ELSE + CALL LIB$MOVC3(4,-(1+FOLDER_NUMBER),%REF(TAG_KEY)) + END IF + + CALL GET_MSGKEY(%REF(MSG_KEY),TAG_KEY(5:)) + + RETURN + END + + + + + SUBROUTINE GET_FIRST_TAG(FOLDER_NUMBER,IER,MESSAGE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*12 TAG_KEY,INPUT_KEY + + CHARACTER*8 NEXT_MSG_KEY + + IF ((.NOT.BULL_TAG.AND.REMOTE_SET.NE.3) + & .OR.(.NOT.BULL_NEWS_TAG.AND.REMOTE_SET.EQ.3)) THEN + CALL OPEN_NEW_TAG(IER) + IF (.NOT.IER) RETURN + END IF + + IF (REMOTE_SET.EQ.3) THEN + CALL GET_FIRST_NEWS_TAG(IER,MESSAGE) + RETURN + END IF + + IF (BTEST(READ_TAG,3)) THEN + MSG_NUM = 0 + CALL GET_NEXT_UNTAG(FOLDER_NUMBER,IER,MESSAGE,DUMMY) + IF (IER.EQ.0) THEN + MESSAGE = MESSAGE - 1 + MSG_NUM = MESSAGE + MSG_KEY = BULLDIR_HEADER + END IF + RETURN + END IF + + MSG_KEY = BULLDIR_HEADER + + HEADER = .TRUE. + + DO J=1,2 + IF (BTEST(READ_TAG,J)) I = J + END DO + + CALL CONFIRM_TAG(IER,FOLDER_NUMBER,MESSAGE,HEADER,I) + + RETURN + + ENTRY GET_THIS_TAG(FOLDER_NUMBER,IER,MESSAGE,TAG_TYPE) + + IF (REMOTE_SET.EQ.3) THEN + CALL GET_THIS_NEWS_TAG(IER,MESSAGE,TAG_TYPE) + RETURN + END IF + + TAG_TYPE = 0 + + DO I=1,2 + IF (BTEST(READ_TAG,I).OR.BTEST(READ_TAG,3)) THEN + DO WHILE (REC_LOCK(IER)) + READ (13,KEY=TAG_KEY(FOLDER_NUMBER,MSG_KEY,I), + & IOSTAT=IER) INPUT_KEY + END DO + IF (IER.EQ.0) TAG_TYPE = IBSET(TAG_TYPE,I) + END IF + END DO + + IF ((TAG_TYPE.NE.0.AND..NOT.BTEST(READ_TAG,3)).OR. + & (BTEST(READ_TAG,3).AND. + & (.NOT.BTEST(TAG_TYPE,2).OR..NOT.BTEST(READ_TAG,2)).AND. + & (.NOT.BTEST(TAG_TYPE,1).OR..NOT.BTEST(READ_TAG,1)))) THEN + IF (IER.EQ.0) UNLOCK 13 + IER = 0 + MESSAGE = MSG_NUM + ELSE + IER = 36 + END IF + + RETURN + + ENTRY GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE,TAG_TYPE) + + MSG_NUM = MSG_NUM - 1 + + CALL DECREMENT_MSG_KEY + + ENTRY GET_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE,TAG_TYPE) + + IF (REMOTE_SET.EQ.3) THEN + MSG_NUM = ABS(MSG_NUM) + 1 + CALL GET_THIS_OR_NEXT_NEWS_TAG(MSG_NUM,IER,MESSAGE,TAG_TYPE) + RETURN + END IF + + IER = 36 + + HEADER = .FALSE. + + TAG_TYPE = 0 + + IF (BTEST(READ_TAG,3)) THEN + CALL GET_NEXT_UNTAG(FOLDER_NUMBER,IER,MESSAGE,TAG_TYPE) + RETURN + END IF + + DO WHILE (IER.NE.0) + I = 0 + DO J=1,2 + IF (BTEST(READ_TAG,J)) THEN + DO WHILE (REC_LOCK(IER)) + READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY,J), + & IOSTAT=IER) INPUT_KEY + END DO + IF (IER.EQ.0) THEN + CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER) + IF ((J.EQ.1.AND.FOLDER1_NUMBER.NE.FOLDER_NUMBER).OR. + & (J.EQ.2.AND.FOLDER1_NUMBER.NE.-(1+FOLDER_NUMBER))) + & IER = 36 + END IF + IF (IER.EQ.0) THEN + IF (J.EQ.1) THEN + NEXT_MSG_KEY = INPUT_KEY(5:) + I = 1 + ELSE IF (I.EQ.0.OR.COMPARE_MSG_KEY(NEXT_MSG_KEY, + & INPUT_KEY(5:)).GT.0) THEN + I = 2 + END IF + END IF + END IF + END DO + IF (I.EQ.0) RETURN + NEXT_MSG_KEY = MSG_KEY + CALL CONFIRM_TAG(IER,FOLDER_NUMBER,MESSAGE,HEADER,I) + IF (IER.EQ.0) THEN + TAG_TYPE = IBSET(TAG_TYPE,I) + DO WHILE (REC_LOCK(IER)) + READ (13,KEY=TAG_KEY(FOLDER_NUMBER,MSG_KEY,3-I), + & IOSTAT=IER) INPUT_KEY + END DO + IF (IER.EQ.0) TAG_TYPE = IBSET(TAG_TYPE,3-I) + IER = 0 + RETURN + ELSE IF (.NOT.BTEST(READ_TAG,3-I)) THEN + MSG_KEY = NEXT_MSG_KEY + RETURN + ELSE + MSG_KEY = NEXT_MSG_KEY + END IF + END DO + + RETURN + END + + + + SUBROUTINE GET_NEXT_UNTAG(FN,IER,MESSAGE,TAG_TYPE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + INQUIRE (UNIT=2,OPENED=CLOSE_IT) + CLOSE_IT = .NOT.CLOSE_IT + IF (CLOSE_IT) CALL OPEN_BULLDIR_SHARED + + DO MESSAGE = MSG_NUM+1,F_NBULL + CALL READDIR(MESSAGE,IER) + IF (IER.EQ.MESSAGE+1) THEN + CALL GET_THIS_TAG(FN,IER,DUMMY,TAG_TYPE) + IF (IER.EQ.0) THEN + IER = 0 + IF (CLOSE_IT) CALL CLOSE_BULLDIR + RETURN + END IF + END IF + END DO + + IER = 36 + IF (CLOSE_IT) CALL CLOSE_BULLDIR + + RETURN + END + + + + INTEGER FUNCTION COMPARE_MSG_KEY(MSG_KEY1,MSG_KEY2) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*8 MSG_KEY1,MSG_KEY2 + + DIMENSION BTIM1(2),BTIM2(2) + + CALL GET_MSGBTIM(MSG_KEY1,BTIM1) + CALL GET_MSGBTIM(MSG_KEY2,BTIM2) + + COMPARE_MSG_KEY = COMPARE_BTIM(BTIM1,BTIM2) + + RETURN + END + + + + + SUBROUTINE CONFIRM_TAG(IER,FOLDER_NUMBER,MESSAGE,HEADER,J) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + CHARACTER*12 TAG_KEY,INPUT_KEY + + DO WHILE (REC_LOCK(IER)) + READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY,J),IOSTAT=IER) + & INPUT_KEY + END DO + + CLOSE_IT = .FALSE. + + DO WHILE (1) + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),MSG_KEY) + CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER) + END IF + + IF (IER.EQ.0) THEN + IF ((J.EQ.1.AND.FOLDER1_NUMBER.NE.FOLDER_NUMBER).OR. + & (J.EQ.2.AND.FOLDER1_NUMBER.NE.-(1+FOLDER_NUMBER))) + & IER = 36 + END IF + IF (IER.NE.0) THEN + IER = 1 + UNLOCK 13 + IF (CLOSE_IT) CALL CLOSE_BULLDIR + RETURN + ELSE + CALL DECREMENT_MSG_KEY + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + INQUIRE (UNIT=2,OPENED=IER) + IF (.NOT.IER) THEN + CALL OPEN_BULLDIR_SHARED + CLOSE_IT = .TRUE. + END IF + CALL READDIR_KEYGE(IER) + CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),INPUT_KEY(5:)) + IF (IER.NE.0.AND.MSG_KEY.EQ.INPUT_KEY(5:)) THEN + UNLOCK 13 + MESSAGE = MSG_NUM + IF (HEADER) THEN + MESSAGE = MESSAGE - 1 + MSG_NUM = MESSAGE + MSG_KEY = BULLDIR_HEADER + END IF + IER = 0 + IF (CLOSE_IT) CALL CLOSE_BULLDIR + RETURN + ELSE + DELETE (UNIT=13) + IF (BTEST(READ_TAG,1).AND.BTEST(READ_TAG,2)) THEN + IER = 36 + IF (CLOSE_IT) CALL CLOSE_BULLDIR + RETURN + END IF + DO WHILE (REC_LOCK(IER)) + READ (13,IOSTAT=IER) INPUT_KEY + END DO + END IF + END IF + + END DO + + END + + + + SUBROUTINE CLOSE_TAG + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /NEWS_MARK/ NEWS_MARK + DIMENSION NEWS_MARK(128) + INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC + EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) + EQUIVALENCE (NEWS_MARK2(1),NEWS_NUMBER) + EQUIVALENCE (NEWS_MARK2(2),NEWS_REC) + EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) + + TAG_OPENED = .FALSE. + + IF (BULL_NEWS_TAG) THEN + DO I=1,FOLDER_MAX-1 + DO M=1,2 + IF (NEWS_TAG(3,M,I).NE.0.AND.NEWS_TAG(4,M,I).EQ.1) THEN + IF (.NOT.TAG_OPENED) THEN + CALL OPEN_OLD_TAG + TAG_OPENED = .TRUE. + END IF + IF (M.EQ.1) THEN + NEWS_REC = 1 + ELSE + NEWS_REC = -32767 + END IF + NEWS_FORMAT = 0 + IF (NEWS_TAG(2,M,I).GT.32767) NEWS_FORMAT = 1 + LIMIT = 256/(NEWS_FORMAT+1) + NEWS_NUMBER = LAST_NEWS_READ2(1,I) + K = 5-NEWS_FORMAT*2 + SET_LIST = .FALSE. + DO J=NEWS_TAG(1,M,I),NEWS_TAG(2,M,I) + IF (TEST_TAG(J,%VAL(NEWS_TAG(3,M,I)), + & NEWS_TAG(1,M,I))) THEN + IF (.NOT.SET_LIST) THEN + CALL SET_NEWS_MARK(K,J) + LAST_SET = J + K = K + 1 + SET_LIST = .TRUE. + END IF + ELSE IF (SET_LIST) THEN + IF (LAST_SET.NE.J-1) THEN + CALL SET_NEWS_MARK(K,-(J-1)) + K = K + 1 + END IF + SET_LIST = .FALSE. + END IF + IF (J.EQ.NEWS_TAG(2,M,I)) THEN + IF (SET_LIST.AND.LAST_SET.NE.J) THEN + CALL SET_NEWS_MARK(K,-J) + K = K + 1 + END IF + DO L=K,LIMIT + CALL SET_NEWS_MARK(L,0) + END DO + K = LIMIT + 1 + END IF + IF (K.GT.LIMIT) THEN + DO WHILE (REC_LOCK(IER)) + READ (23,KEYEQ=NEWS_MARK(1),IOSTAT=IER) + END DO + IF (IER.NE.0) THEN + WRITE (23,IOSTAT=IER) NEWS_MARK + ELSE + REWRITE (23,IOSTAT=IER) NEWS_MARK + END IF + K = 5-NEWS_FORMAT*2 + NEWS_REC = NEWS_REC + 1 + IF (J.EQ.NEWS_TAG(2,M,I)) THEN + DO WHILE (REC_LOCK(IER)) + READ (23,KEYEQ=NEWS_MARK(1),IOSTAT=IER) + IF (IER.EQ.0) THEN + DELETE (UNIT=23) + NEWS_REC = NEWS_REC + 1 + L = REC_LOCK(IER) + END IF + END DO + END IF + END IF + END DO + END IF + END DO + END DO + CLOSE (UNIT=23) + END IF + + RETURN + END + + + SUBROUTINE SET_NEWS_MARK(I,J) + + IMPLICIT INTEGER (A-Z) + + COMMON /NEWS_MARK/ NEWS_MARK + DIMENSION NEWS_MARK(128) + INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC + EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) + EQUIVALENCE (NEWS_MARK2(1),NEWS_NUMBER) + EQUIVALENCE (NEWS_MARK2(2),NEWS_REC) + EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) + + IF (NEWS_FORMAT.EQ.0) THEN + NEWS_MARK2(I) = J + ELSE + NEWS_MARK(I) = J + END IF + + RETURN + END + + + + SUBROUTINE ZERO_VM(NUM,NEWS_TAG) + + IMPLICIT INTEGER (A-Z) + + LOGICAL*1 NEWS_TAG(1) + + DO I=1,NUM + NEWS_TAG(I) = 0 + END DO + + RETURN + END + + + + + SUBROUTINE FREE_TAGS(ISUB) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) + COMMON /NEWS_MARK/ NEWS_MARK + DIMENSION NEWS_MARK(128) + INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC + EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) + EQUIVALENCE (NEWS_MARK2(1),NEWS_NUMBER) + EQUIVALENCE (NEWS_MARK2(2),NEWS_REC) + EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) + + DO I=1,2 + IF (NEWS_TAG(3,I,ISUB).GT.0) THEN + CALL LIB$FREE_VM( + & (NEWS_TAG(2,I,ISUB)-NEWS_TAG(1,I,ISUB))/8+1,NEWS_TAG(3,I,ISUB)) + NEWS_TAG(3,I,ISUB) = 0 + NEWS_NUMBER = NEWS_FOLDER_NUMBER + NEWS_REC = -32768 + DO WHILE (REC_LOCK(IER)) + READ (23,KEYGT=NEWS_MARK(1),IOSTAT=IER) NEWS_MARK + IF (IER.EQ.0.AND.NEWS_NUMBER.EQ.NEWS_FOLDER_NUMBER) THEN + DELETE (UNIT=23) + L = REC_LOCK(IER) + END IF + END DO + END IF + + DO J=I,FOLDER_MAX-2 + CALL LIB$MOVC3(16,NEWS_TAG(1,I,J+1),NEWS_TAG(1,I,J)) + END DO + + DO J=1,4 + NEWS_TAG(J,I,FOLDER_MAX-1) = 0 + END DO + END DO + + RETURN + END + + + + + SUBROUTINE GET_PREVIOUS_TAG(FN,IER,BULL_READ,TAG_TYPE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*8 PREV_MSG_KEY + + IER = 36 + + IF (REMOTE_SET.EQ.3) THEN + SUBNUM = NEWS_FIND_SUBSCRIBE() + DO WHILE (IER.NE.0.AND.MSG_NUM.GT.F_START) + MSG_NUM = MSG_NUM - 1 + CALL GET_THIS_TAG(FN,IER,MSG_NUM,TAG_TYPE) + IF (IER.EQ.0) THEN + TMP_MSG_NUM = MSG_NUM + CALL READDIR(TMP_MSG_NUM,IER1) + IF (IER1.NE.MSG_NUM+1) THEN + IF (.NOT.BTEST(READ_TAG,3)) THEN + CALL DEL_NEWS_TAG(TAG_TYPE,TMP_MSG_NUM,SUBNUM) + END IF + IER = 36 + END IF + END IF + END DO + BULL_READ = MSG_NUM + ELSE + IF (MSG_NUM.EQ.0) RETURN + SAVE_MSG_NUM = MSG_NUM + PREV_MSG_NUM = MSG_NUM + MSG_NUM = 0 + MSG_KEY = BULLDIR_HEADER + IER = 0 + DO WHILE (IER.EQ.0.AND.MSG_NUM.LT.SAVE_MSG_NUM) + IF (MSG_NUM.GT.0) THEN + PREV_MSG_KEY = MSG_KEY + PREV_MSG_NUM = MSG_NUM + END IF + CALL GET_NEXT_TAG(FN,IER,BULL_READ,TAG_TYPE) + END DO + IF (PREV_MSG_NUM.LT.SAVE_MSG_NUM) THEN + MSG_NUM = PREV_MSG_NUM + MSG_KEY = PREV_MSG_KEY + CALL GET_THIS_OR_NEXT_TAG(FN,IER,BULL_READ,TAG_TYPE) + ELSE + IER = 36 + END IF + END IF + + RETURN + END + + + SUBROUTINE DECREMENT_MSG_KEY + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + I = 1 + DO WHILE (I.LT.9) + ITEST = ICHAR(MSG_KEY(I:I)) + IF (ITEST.GT.0) THEN + MSG_KEY(I:I) = CHAR(ITEST-1) + I = 9 + ELSE + I = I + 1 + END IF + END DO + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin2.for b/decus/vax91b/gce91b/net91b/bulletin2.for new file mode 100644 index 0000000..87861a4 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin2.for @@ -0,0 +1,2147 @@ +C +C BULLETIN2.FOR, Version 6/15/91 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + SUBROUTINE SET_BBOARD(BBOARD) +C +C SUBROUTINE SET_BBOARD +C +C FUNCTION: Set username for BBOARD for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($UAIDEF)' + + EXTERNAL CLI$_ABSENT + + CHARACTER EXPIRE*3,INPUT_BBOARD*12,TODAY*23,RESPONSE*1 + + IF (TRIM(BBOARD_DIRECTORY).EQ.0) THEN + WRITE(6,'('' ERROR: System programmer has disabled BBOARD.'')') + RETURN + END IF + + IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + WRITE (6,'( + & '' ERROR: Cannot set BBOARD for remote folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + + IF (BBOARD) THEN + IER = CLI$GET_VALUE('BB_USERNAME',INPUT_BBOARD,INPUT_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_UAF + & (INPUT_BBOARD,USERB,GROUPB,ACCOUNTB,FLAGS,IER1) + CALL CLOSE_BULLFOLDER + IF (IER1.AND..NOT.BTEST(FLAGS,UAI$V_DISACNT)) THEN ! DISUSER? + WRITE (6,'('' ERROR: '',A, + & '' account needs DISUSER flag set.'')') + & INPUT_BBOARD(:INPUT_LEN) + RETURN + ELSE IF (IER1.AND.BTEST(USERB,31)) THEN + WRITE (6,'('' ERROR: User number of UIC cannot '', + & ''be greater than 7777777777.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_TEMP(IER) + DO WHILE ((FOLDER1_BBOARD.NE.INPUT_BBOARD.OR. + & FOLDER1_NUMBER.EQ.FOLDER_NUMBER).AND.IER.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER) + END DO + IF (FOLDER1_BBOARD.EQ.INPUT_BBOARD.AND. + & FOLDER1_NUMBER.NE.FOLDER_NUMBER) THEN + WRITE (6,'( + & '' ERROR: Account used by other folder.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + IF (.NOT.IER1) THEN + CALL CLOSE_BULLFOLDER + WRITE (6,'('' WARNING: '',A,'' account not in SYSUAF'', + & '' file.'')') INPUT_BBOARD(:INPUT_LEN) + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Is the name a mail forwarding entry? '// + & '(Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + CALL OPEN_BULLFOLDER + USERB = 1 ! Fake userb/groupb, as old method of + GROUPB = 1 ! indicating /SPECIAL used [0,0] + END IF + GROUPB1 = GROUPB + USERB1 = USERB + ACCOUNTB1 = ACCOUNTB + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + GROUPB = GROUPB1 + USERB = USERB1 + ACCOUNTB = ACCOUNTB1 + FOLDER_BBOARD = INPUT_BBOARD + CALL OPEN_BULLUSER + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM(TODAY,BBOARD_BTIM) + REWRITE (4) USER_HEADER + CALL CLOSE_BULLUSER + IF (CLI$PRESENT('SPECIAL')) THEN ! SPECIAL specified? + USERB = IBSET(USERB,31) ! Set bit to show /SPECIAL + IF (CLI$PRESENT('VMSMAIL')) THEN + GROUPB = IBSET(GROUPB,31) ! Set bit to show /VMSMAIL + END IF + END IF + ELSE IF (CLI$PRESENT('SPECIAL')) THEN + USERB = IBSET(0,31) ! Set top bit to show /SPECIAL + GROUPB = 0 + DO I=1,LEN(FOLDER_BBOARD) + FOLDER_BBOARD(I:I) = ' ' + END DO + ELSE IF (FOLDER_BBOARD.EQ.'NONE') THEN + WRITE (6,'('' ERROR: No BBOARD specified for folder.'')') + END IF + + IER = CLI$GET_VALUE('EXPIRATION',EXPIRE,EX_LEN) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + IF (EX_LEN.GT.3) EX_LEN = 3 + READ (EXPIRE,'(I)') TEMP + IF (TEMP.GT.BBEXPIRE_LIMIT.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Expiration cannot be > '', + & I3,'' days.'')') BBEXPIRE_LIMIT + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (TEMP.LE.0) THEN + WRITE (6,'('' ERROR: Expiration must be > 0.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + FOLDER_BBEXPIRE = TEMP + END IF + ELSE IF (.NOT.CLI$PRESENT('EXPIRATION')) THEN + FOLDER_BBEXPIRE = -1 + END IF + ELSE + FOLDER_BBOARD = 'NONE' + END IF + + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + WRITE (6,'('' BBOARD has been modified for folder.'')') + ELSE + WRITE (6,'('' You are not authorized to modify BBOARD.'')') + END IF + + RETURN + END + + + + + + + SUBROUTINE SET_SYSTEM(SYSTEM_SET) +C +C SUBROUTINE SET_SYSTEM +C +C FUNCTION: Set SYSTEM specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' ERROR: Cannot modify GENERAL folder.'')') + ELSE IF (FOLDER_NUMBER.LT.0) THEN + WRITE (6,'('' ERROR: Cannot modify for remote folder.'')') + ELSE IF (SETPRV_PRIV()) THEN + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (SYSTEM_SET) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been set.'')') + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,2) + WRITE (6,'('' SYSTEM designation has been removed.'')') + END IF + CALL REWRITE_FOLDER_FILE + CALL MODIFY_SYSTEM_LIST(0) + CALL CLOSE_BULLFOLDER + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + ELSE + WRITE (6,'('' You are not authorized to modify SYSTEM.'')') + END IF + + RETURN + END + + + + SUBROUTINE MODIFY_SYSTEM_LIST(FILE_OPENED) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + INTEGER SHUTDOWN_BTIM(FLONG),VERSION(FLONG) + + CHARACTER UPDATE*11,UPTIME*8 + + INTEGER UP_BTIM(2) + + IF (.NOT.FILE_OPENED) CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0.OR.VERSION(1).NE.168) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + SHUTDOWN_BTIM(1) = 0 + SHUTDOWN_BTIM(2) = 0 + NODE_NUMBER = 0 + NODE_AREA = 0 + IF (IER.EQ.0) THEN + DO WHILE (TEMP_USER(:7).EQ.'*SYSTEM'.AND.IER.EQ.0) + DELETE (UNIT=4) + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) TEMP_USER + END DO + END DO + IER = 2 + ELSE + VERSION(1) = 168 + END IF + END IF + + IF (VERSION(1).NE.168) THEN + CALL CLOSE_BULLFOLDER + CALL OPEN_BULLFOLDER + NODE_AREA = 0 + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + END DO + IER1 = 0 + DO WHILE (IER1.EQ.0) + CALL READ_FOLDER_FILE_TEMP(IER1) + IF (BTEST(FOLDER1_FLAG,2).AND.IER1.EQ.0) THEN + CALL SET2(SYSTEM_FLAG,FOLDER1_NUMBER) + END IF + END DO + VERSION(1) = 168 + END IF + + IF (BTEST(FOLDER_FLAG,2)) THEN + CALL SET2(SYSTEM_FLAG,FOLDER_NUMBER) + ELSE + CALL CLR2(SYSTEM_FLAG,FOLDER_NUMBER) + END IF + + CALL SYS_BINTIM('-',UP_BTIM) ! Get today's date + DIFF = COMPARE_BTIM(SHUTDOWN_BTIM,UP_BTIM) + IF (DIFF.GE.0) THEN ! Must have been in a time wrap + SHUTDOWN_BTIM(1) = UP_BTIM(1) + SHUTDOWN_BTIM(2) = UP_BTIM(2) + END IF + + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14,BTEST(FOLDER_FLAG,2), + & NODENAME + IF (IER1.NE.0) THEN + CALL DISCONNECT_REMOTE + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + RETURN + END IF + END IF + + CALL GET_UPTIME(UPDATE,UPTIME) + + CALL SYS_BINTIM(UPDATE//' '//UPTIME,UP_BTIM) + + IF (NODE_AREA.EQ.0) THEN + IF (SHUTDOWN_BTIM(1).EQ.0) THEN + DIFF = -1 + ELSE + DIFF = COMPARE_BTIM(SHUTDOWN_BTIM,UP_BTIM) + END IF + IF (DIFF.EQ.-1) THEN + CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + SHUTDOWN_BTIM(1) = UP_BTIM(1) + SHUTDOWN_BTIM(2) = UP_BTIM(2) + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + END IF + ELSE ! Test to make sure NODE_AREA is zero + SEEN_FLAG = 0 ! if all of SHUTDOWN_FLAG is zero + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 + END IF + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,VERSION, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL READ_PERM + + IF (.NOT.FILE_OPENED) CALL CLOSE_BULLUSER + + RETURN + END + + + + SUBROUTINE GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) + CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) + CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist + + IER = SYS$GETSYIW(,,,%VAL(GETSYI_ITMLST),,,) ! Get Info command. +C +C NODE_AREA is set to 0 after shutdown messages are deleted. +C If node is not part of cluster, NODE_AREA will be 0, +C so set it to 1 as a dummy value to cause messages to be deleted. +C + IF (NODE_AREA.EQ.0) NODE_AREA = 1 + + RETURN + END + + + + + SUBROUTINE SET_NODE(NODE_SET) +C +C SUBROUTINE SET_NODE +C +C FUNCTION: Set or reset remote node specification for selected folder. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,FOLDER_SAVE*25 + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) ! Get folder name + FOLDER_SAVE = FOLDER + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + IF (IER.EQ.0) THEN + IF (.NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE (6,'('' ERROR: No privs to modify folder.'')') + IER = 1 + END IF + ELSE + WRITE (6,'('' ERROR: Specified folder not found.'')') + END IF + IF (IER.NE.0) THEN + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + RETURN + END IF + CALL CLOSE_BULLFOLDER + END IF + + IF (FOLDER_NUMBER.EQ.0) THEN + WRITE (6,'('' Cannot set remote node for GENERAL folder.'')') + ELSE IF (FOLDER_NUMBER.LT.0) THEN + WRITE (6,'('' Cannot set remote node for this folder.'')') + ELSE IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + IF (.NOT.NODE_SET) THEN + IF (INDEX(FOLDER_BBOARD,'*').GT.0) THEN + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + CALL OPEN_BULLDIR ! Remove directory file which + CALL CLOSE_BULLDIR_DELETE ! contains remote folder name + REMOTE_SET = REMOTE_SET_SAVE + END IF + FOLDER1_BBOARD = 'NONE' + WRITE (6,'('' Remote node setting has been removed.'')') + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .FALSE. + ELSE + CALL GET_INPUT_PROMPT(RESPONSE,RLEN, + & 'Are you sure you want to make folder '// + & FOLDER(:TRIM(FOLDER))// + & ' remote? (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not modified.'')') + RETURN + END IF + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + IER = CLI$GET_VALUE('NODENAME',FOLDER1_BBOARD,FLEN) + FOLDER1_BBOARD = '::'//FOLDER1_BBOARD(:FLEN) + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'( + & '' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE + WRITE (6,'('' Folder has been converted to remote.'')') + END IF + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + IF (FOLDER.NE.FOLDER1) THEN ! Different remote folder name? + CALL OPEN_BULLDIR ! If so, put name in header + BULLDIR_HEADER(13:) = FOLDER1 ! of directory file. + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:FLEN+2)//'*' + END IF + REMOTE_SET = REMOTE_SET_SAVE + IF (.NOT.CLI$PRESENT('FOLDER')) REMOTE_SET = .TRUE. + END IF + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + IF (.NOT.NODE_SET.AND.FOLDER_BBOARD(:2).EQ.'::' + & .AND.BTEST(FOLDER_FLAG,2)) THEN + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER_BBOARD(3:TRIM(FOLDER_BBOARD)) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Disregister remote SYSTEM folder + WRITE(17,'(2A)',IOSTAT=IER) 14,0 + CLOSE (UNIT=17) + END IF + END IF + FOLDER_BBOARD = FOLDER1_BBOARD + IF (NODE_SET) THEN + F_NBULL = F1_NBULL + F_NEWEST_BTIM(1) = F1_NEWEST_BTIM(1) + F_NEWEST_BTIM(2) = F1_NEWEST_BTIM(2) + F_NEWEST_NOSYS_BTIM(1) = F1_NEWEST_NOSYS_BTIM(1) + F_NEWEST_NOSYS_BTIM(2) = F1_NEWEST_NOSYS_BTIM(2) + FOLDER_FLAG = 0 + F_EXPIRE_LIMIT = F1_EXPIRE_LIMIT + ELSE + F_NBULL = 0 + END IF + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + ELSE + WRITE (6,'('' You are not authorized to modify NODE.'')') + END IF + + IF (CLI$PRESENT('FOLDER')) THEN + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME(FOLDER_SAVE,IER) + CALL CLOSE_BULLFOLDER + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER + END IF + + RETURN + END + + + + + SUBROUTINE RESPOND +C +C SUBROUTINE RESPOND +C +C FUNCTION: Sends a mail message in reply to a posted message. +C +C NOTE: Modify the last SPAWN statement to specify the command +C you use to send mail to sites other than via MAIL. +C If you always use a different command, modify both +C spawn commands. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + DATA EDIT_DEFAULT/.FALSE./ + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + + COMMON /INDESCRIP/ INDESCRIP + CHARACTER*(LINE_LENGTH) INDESCRIP + + CHARACTER FROM_TEST*5,INFROM*(LINE_LENGTH) + + EXTERNAL CLI$_NEGATED,CLI$_ABSENT + + MSG_OWN = .FALSE. + + IF (INCMD(:4).EQ.'REPLY') THEN + BULL_PARAMETER = 'mailing list.' + IF (CLI$PRESENT('ALL')) THEN + BULL_PARAMETER = 'message owner and mailing list.' + MSG_OWN = .TRUE. + END IF + ELSE IF (INCMD(:4).EQ.'RESP') THEN + MSG_OWN = .TRUE. + BULL_PARAMETER = 'message owner.' + IF (CLI$PRESENT('LIST')) + & BULL_PARAMETER = 'message owner and mailing list.' + ELSE + BULL_PARAMETER = 'mailing list.' + END IF + + IF (MSG_OWN.AND.BTEST(CAPTIVE(),1)) THEN + WRITE (6,'('' ERROR: MAIL invalid from DISMAIL account.'')') + RETURN + END IF + + WRITE (6,'('' Sending message to '',A)') + & BULL_PARAMETER(:TRIM(BULL_PARAMETER)) + + IF (INCMD(:4).NE.'POST') THEN + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE(6,'('' ERROR: You have not read any message.'')') + RETURN ! And return + END IF + + CALL OPEN_BULLDIR_SHARED + + CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? + WRITE(6,'('' ERROR: Bulletin was not found.'')') + CALL CLOSE_BULLDIR ! If not, then error out + RETURN + END IF + + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + INDESCRIP = INPUT(7:) + ELSE + INDESCRIP = DESCRIP + END IF + + CALL CLOSE_BULLFIL + + CALL CLOSE_BULLDIR + + IF (STREQ(INDESCRIP(:3),'RE:')) THEN + INDESCRIP = 'RE:'//INDESCRIP(4:) + ELSE + INDESCRIP = 'RE: '//INDESCRIP + END IF + END IF + + IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + IF (LENDES.GT.LEN(INDESCRIP)) THEN + WRITE(6,'('' ERROR: Subject length exceeded.'')') + RETURN + END IF + ELSE IF (INCMD(:4).EQ.'POST') THEN + WRITE(6,'('' Enter subject of message:'')') + CALL GET_LINE(INDESCRIP,LENDES) + IF (LENDES.LE.0) THEN + LENDES = 0 + WRITE(6,'('' ERROR: No subject specified.'')') + RETURN + END IF + ELSE + WRITE (6,'('' Message will have the subject:'')') + WRITE (6,'(1X,A)') INDESCRIP(:MIN(TRIM(INDESCRIP),PAGE_WIDTH)) + END IF + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + EDIT = .TRUE. + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + ELSE + EDIT = .FALSE. + END IF + + TEXT = CLI$PRESENT('EXTRACT') + + LIST = CLI$PRESENT('LIST') + + CALL DISABLE_PRIVS + + ILEN = 0 + + FILESPEC = CLI$GET_VALUE('FILESPEC',INPUT,ILEN) + IF (FILESPEC.NE.%LOC(CLI$_ABSENT)) THEN + OPEN (UNIT=4,FILE=INPUT(:ILEN),STATUS='OLD',READONLY, + & SHARED,IOSTAT=IER,FORM='FORMATTED') + IF (IER.NE.0) FILESPEC = .FALSE. + END IF + + IF (EDIT.AND.(TEXT.OR.FILESPEC)) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 900 + END IF + ELSE IF (TEXT.AND..NOT.EDIT) THEN + WRITE (6,'('' ERROR: Cannot extract text without /EDIT.'')') + GO TO 900 + END IF + + LENFRO = 0 + IF (CLI$GET_VALUE('CC',INPUT,ILEN)) THEN + CALL ADD_PROTOCOL(INPUT,ILEN) + INFROM = INPUT(:ILEN) + LENFRO = ILEN + IF (MSG_OWN) THEN + INFROM = INFROM(:LENFRO)//',' + LENFRO = LENFRO + 1 + END IF + END IF + + IF ((EDIT.AND.TEXT).OR.INCMD(:4).NE.'POST') THEN + CALL ENABLE_PRIVS + CALL OPEN_BULLFIL_SHARED + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + ILEN = TRIM(INPUT) + IF (MSG_OWN) THEN + CALL ADD_PROTOCOL(INPUT(7:),ILEN) + INFROM = INFROM(:LENFRO)//INPUT(7:) + LENFRO = LENFRO + ILEN - 6 + END IF + IF (EDIT.AND.TEXT) THEN + IF (INPUT(ILEN:ILEN).EQ.'"') ILEN = ILEN - 1 + INPUT = INPUT(7:ILEN) + ILEN = ILEN - 6 + IF (INDEX(INPUT,'%"').GT.0) THEN + INPUT = INPUT(INDEX(INPUT,'%"')+2:) + ILEN = TRIM(INPUT) + END IF + WRITE (3,'(A)') 'In a previous article, '// + & INPUT(:ILEN)//' wrote:' + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE IF (MSG_OWN) THEN + CALL ADD_PROTOCOL(FROM,0) + INFROM = INFROM(:LENFRO)//FROM + LENFRO = TRIM(FROM) + LENFRO + END IF + + IF (EDIT.AND.TEXT) THEN + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + IF (CLI$PRESENT('NOINDENT')) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ELSE + WRITE (3,'(A)') '>'//INPUT(:ILEN) + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + IF (FILESPEC) THEN + WRITE (3,'(A)') ' ' + IER = 0 + DO WHILE (IER.EQ.0) + READ (4,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.EQ.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + CLOSE (UNIT=4) + FILESPEC = .FALSE. + END IF + + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + + CALL CLOSE_BULLFIL + CALL DISABLE_PRIVS + END IF + + IF (EDIT.AND.FILESPEC.AND..NOT.TEXT) THEN + IER = 0 + ICOUNT = 0 + DO WHILE (IER.EQ.0) + READ (4,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.EQ.0) THEN + WRITE (3,'(A)') INPUT(:ILEN) + ICOUNT = ICOUNT + 1 + END IF + END DO + CLOSE (UNIT=4) + FILESPEC = .FALSE. + IF (ICOUNT.EQ.0) THEN + CLOSE (UNIT=3,STATUS='DELETE') + ELSE + CLOSE (UNIT=3) + END IF + END IF + + IF (LIST.AND.REMOTE_SET.NE.3) THEN + SLIST = INDEX(FOLDER_DESCRIP,'<') + IF (SLIST.GT.0) THEN + IF (REMOTE_SET.NE.4) THEN + INPUT = FOLDER_DESCRIP(SLIST+1:) + ILEN = INDEX(INPUT,'>') - 1 + IF (ILEN.EQ.-1) ILEN = TRIM(INPUT) + INPUT = INPUT(:ILEN) + CALL ADD_PROTOCOL(INPUT,ILEN) + IF (LENFRO.GT.0.AND.INFROM(LENFRO:LENFRO).NE.',') THEN + INFROM = INFROM(:LENFRO)//',' + LENFRO = LENFRO + 1 + END IF + INFROM = INFROM(:LENFRO)//INPUT(:ILEN) + LENFRO = LENFRO + ILEN + ELSE + FOLDER1_DESCRIP = + & FOLDER_DESCRIP(SLIST+1:TRIM(FOLDER_DESCRIP)-1) + IF (FOLDER1_DESCRIP(1:1).EQ.'@') THEN + WRITE(6,'('' ERROR: Multiple newsgroup feed'', + & '' is present.'')') + GO TO 900 + END IF + END IF + ELSE + WRITE (6,'('' ERROR: No list address'', + & '' found in folder description.'')') + GO TO 900 + END IF + END IF + + I = 1 ! Must change all " to "" in FROM field + DO WHILE (I.LE.LENFRO) + IF (INFROM(I:I).EQ.'"') THEN + INFROM = INFROM(:I)//'"'//INFROM(I+1:) + I = I + 1 + LENFRO = LENFRO + 1 + END IF + I = I + 1 + END DO + + LENDES = TRIM(INDESCRIP) + I = 1 ! Must change all " to "" in SUBJECT field + DO WHILE (I.LE.LENDES) + IF (INDESCRIP(I:I).EQ.'"') THEN + IF (LENDES.EQ.LINE_LENGTH) THEN + INDESCRIP(I:I) = '`' + ELSE + INDESCRIP = INDESCRIP(:I)//'"' + & //INDESCRIP(I+1:) + I = I + 1 + LENDES = LENDES + 1 + END IF + END IF + I = I + 1 + END DO + + STATUS = .TRUE. + + IF (EDIT) THEN + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + CONTEXT = 0 + IER = LIB$FIND_FILE('SYS$LOGIN:BULL.SCR',INPUT,CONTEXT) + IF (TEXT) THEN + VERSION = INDEX(INPUT,';') + 1 + IF (INPUT(VERSION:VERSION).EQ.'1') THEN + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + ELSE + IER = 0 + END IF + ELSE IF (IER) THEN + IER = 0 + END IF + IF (IER.EQ.0) THEN + CALL ADD_SIGNATURE(0,'SYS$LOGIN:BULL.SCR',FOLDER_NAME) + IF (REMOTE_SET.GE.3.AND.LIST) THEN + CALL NEWS_POST('SYS$LOGIN:BULL.SCR',.FALSE.,IER, + & INDESCRIP) + STATUS = IER.EQ.0 + IF (IER.EQ.0) THEN + WRITE (6,'('' Message successfully posted.'')') + END IF + END IF + IF (IER.EQ.0.AND.LENFRO.GT.0) THEN + CALL RESPOND_MAIL('SYS$LOGIN:BULL.SCR',INFROM(:LENFRO), + & INDESCRIP(:LENDES),STATUS) + END IF + END IF + ELSE + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + IF (.NOT.FILESPEC) THEN + WRITE (6,'('' Enter message: End with ctrl-z,'', + & '' cancel with ctrl-c'')') + ILEN = LINE_LENGTH + 1 ! Length of input line + ICOUNT = 0 ! Character count counter + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Input line too long + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput:'')') LINE_LENGTH + ELSE IF (ILEN.GE.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN ! Update counter + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + END IF + END DO + ELSE + IER = 0 + ICOUNT = 0 + DO WHILE (IER.EQ.0) + READ (4,'(Q,A)',IOSTAT=IER) ILEN,INPUT + IF (IER.EQ.0) THEN + ICOUNT = ICOUNT + 1 + WRITE (3,'(A)') INPUT(:ILEN) + END IF + END DO + CLOSE (UNIT=4) + FILESPEC = .FALSE. + END IF + IF (ILEN.EQ.-1.OR.ICOUNT.EQ.0) THEN ! CTRL_C or No lines + CLOSE (UNIT=3) + IER = 1 + ELSE + CALL ADD_SIGNATURE(3,' ',FOLDER_NAME) + REWIND (UNIT=3) + IF (REMOTE_SET.GE.3.AND.LIST) THEN + CALL NEWS_POST('SYS$LOGIN:BULL.SCR',.TRUE.,IER, + & INDESCRIP) + STATUS = IER.EQ.0 + IF (IER.EQ.0) WRITE (6,'('' Message successfully posted.'')') + ELSE + IER = 0 + END IF + CLOSE (UNIT=3) + IF (IER.EQ.0.AND.LENFRO.GT.0) THEN + CALL RESPOND_MAIL('SYS$LOGIN:BULL.SCR',INFROM(:LENFRO), + & INDESCRIP(:LENDES),STATUS) + END IF + END IF + END IF + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No message added.'')') + IF (.NOT.STATUS) THEN + CALL GET_INPUT_PROMPT(INPUT,ILEN,'Do you want to'// + & ' save message? (Y/N with N as default): ') + IF (STREQ(INPUT(:1),'Y')) THEN + CALL LIB$RENAME_FILE('SYS$LOGIN:BULL.SCR', + & 'SYS$LOGIN:BULL.SAV') + WRITE (6,'(A)') ' Message saved in SYS$LOGIN:BULL.SAV.' + END IF + END IF + END IF + +900 CALL ENABLE_PRIVS + IF (FILESPEC) CLOSE (UNIT=4) + CALL LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;*') + + RETURN + END + + + + SUBROUTINE ADD_SIGNATURE(FILEUNIT,FILENAME,FOLDER_NAME) +C +C SUBROUTINE ADD_SIGNATURE +C +C FUNCTION: Adds signature to message being mailed/posted. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) FOLDER_NAME + + CHARACTER*128 BULL_SIGNATURE + DATA BULL_SIGNATURE /'SYS$LOGIN:BULL_SIGNATURE.TXT'/ + + CHARACTER*255 INPUT + + OPEN (UNIT=4,FILE=BULL_SIGNATURE,STATUS='OLD',READONLY, + & SHARED,IOSTAT=IER,FORM='FORMATTED') + + IF (IER.NE.0) THEN + OPEN (UNIT=4,FILE='BULL_SIGNATURE',STATUS='OLD',READONLY, + & SHARED,IOSTAT=IER,FORM='FORMATTED') + END IF + + IF (IER.NE.0) RETURN + + IF (FILEUNIT.EQ.0) THEN + OPEN (UNIT=3,FILE=FILENAME,STATUS='OLD',ACCESS='APPEND', + & IOSTAT=IER,FORM='FORMATTED') + END IF + + ICOUNT = 0 + MATCH = .FALSE. + DO WHILE (IER.EQ.0) + READ (4,'(A)',IOSTAT=IER) INPUT + ILEN = TRIM(INPUT) + DO WHILE (.NOT.MATCH.AND.STREQ(INPUT(:6),'START ').AND.IER.EQ.0) + MATCH = STREQ(INPUT(7:ILEN),FOLDER_NAME(:TRIM(FOLDER_NAME))) + READ (4,'(A)',IOSTAT=IER) INPUT + ILEN = TRIM(INPUT) + IF (.NOT.MATCH) THEN + DO WHILE (.NOT.STREQ(INPUT(:ILEN),'END').AND.IER.EQ.0) + READ (4,'(A)',IOSTAT=IER) INPUT + ILEN = TRIM(INPUT) + END DO + READ (4,'(A)',IOSTAT=IER) INPUT + ILEN = TRIM(INPUT) + END IF + END DO + IF (IER.EQ.0) THEN + IF (MATCH.AND.STREQ(INPUT(:ILEN),'END')) THEN + MATCH = .FALSE. + ELSE + ICOUNT = ICOUNT + 1 + IF (ICOUNT.EQ.1) WRITE (3,'(A)',IOSTAT=IER) ' ' + WRITE (3,'(A)',IOSTAT=IER) INPUT(:ILEN) + END IF + END IF + END DO + + CLOSE (UNIT=4) + IF (FILEUNIT.EQ.0) CLOSE (UNIT=3) + + RETURN + END + + + + + LOGICAL FUNCTION STREQ(INPUT,INPUT1) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,INPUT1 + + STREQ = .FALSE. + + IF (LEN(INPUT).NE.LEN(INPUT1)) RETURN + + DO I=1,LEN(INPUT) + DIFF = ABS(ICHAR(INPUT(I:I))-ICHAR(INPUT1(I:I))) + IF (DIFF.NE.0.AND.DIFF.NE.32) RETURN + END DO + + STREQ = .TRUE. + + RETURN + END + + + + + + + SUBROUTINE RESPOND_MAIL(FILE,SENDTO,SUBJECT,STATUS) +C +C SUBROUTINE RESPOND_MAIL +C +C FUNCTION: Sends mail to address. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER*(*) FILE,SENDTO,SUBJECT + + CHARACTER MAILER*128 + + LISTSERV = INDEX(FOLDER_DESCRIP,'LISTSERV').GT.0 + + IF (LISTSERV) THEN + CALL SETUSER(FOLDER_BBOARD) + IF (SYS_TRNLNM('MX_NODE_NAME',MAILER)) THEN + REPLY_TO = .NOT.SYS_TRNLNM('MX_REPLY_TO',MAILER) + IF (REPLY_TO) IER = LIB$SET_LOGICAL + & ('MX_REPLY_TO',USERNAME(:TRIM(USERNAME))) + ELSE + REPLY_TO = .NOT.SYS_TRNLNM('PMDF_REPLY_TO',MAILER) + IF (REPLY_TO) IER = LIB$SET_LOGICAL + & ('PMDF_REPLY_TO',USERNAME(:TRIM(USERNAME))) + END IF + END IF + + IF (SYS_TRNLNM('BULL_MAILER',MAILER)) THEN + IF (LISTSERV) THEN + IF (SYS_TRNLNM_SYSTEM('BULL_MAILER',MAILER)) THEN + CALL LIB$SPAWN('@'//MAILER(:TRIM(MAILER))// + & ' SYS$LOGIN:BULL.SCR """'//SENDTO//'""" """' + & //SUBJECT//'""" ' + & //USERNAME(:TRIM(USERNAME)),,,,,,STATUS) + END IF + ELSE + CALL LIB$SPAWN('@'//MAILER(:TRIM(MAILER))// + & ' SYS$LOGIN:BULL.SCR """'//SENDTO// + & '""" """'//SUBJECT//'"""',,,,,,STATUS) + END IF + ELSE + CALL LIB$SPAWN('$MAIL SYS$LOGIN:BULL.SCR "'//SENDTO// + & '" /SUBJECT="'//SUBJECT//'"',,,,,,STATUS) + END IF + + IF (LISTSERV) THEN + CALL SETUSER(USERNAME) + IF (REPLY_TO) IER = LIB$DELETE_LOGICAL('PMDF_REPLY_TO') + IF (REPLY_TO) IER = LIB$DELETE_LOGICAL('MX_REPLY_TO') + END IF + + RETURN + END + + + + INTEGER FUNCTION CONFIRM_USER(USERNAME) +C +C FUNCTION CONFIRM_USER +C +C FUNCTION: Confirms that username is valid user. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + CALL OPEN_SYSUAF_SHARED + + READ (8,KEY=USERNAME,IOSTAT=CONFIRM_USER) + + CALL CLOSE_SYSUAF + + RETURN + END + + + + + + SUBROUTINE REPLACE +C +C SUBROUTINE REPLACE +C +C FUNCTION: CHANGE command subroutine. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /EDIT/ EDIT_DEFAULT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER INEXDATE*11,INEXTIME*11 + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH) + CHARACTER*1 ANSWER + + CHARACTER DATE_SAVE*11,TIME_SAVE*11 + + INTEGER TIMADR(2) + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + LOGICAL*1 DOALL + + IF (REMOTE_SET.EQ.3) THEN + WRITE (6,'('' Cannot CHANGE messages in this folder.'')') + RETURN + END IF + +C +C Get the bulletin number to be replaced. +C + + ALL = CLI$PRESENT('ALL') + + IER1 = CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) + IF (IER1.EQ.%LOC(CLI$_ABSENT).AND..NOT.ALL) THEN + IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read + WRITE (6,1005) ! Tell user of the error + RETURN ! and return + END IF + SBULL = BULL_POINT ! Replace the bulletin we are reading + EBULL = SBULL + + CALL OPEN_BULLDIR_SHARED + CALL READDIR(BULL_POINT,IER) ! Get message directory entry + CALL CLOSE_BULLDIR + IF (IER.NE.BULL_POINT+1) THEN ! Was message found? + WRITE(6,'('' ERROR: Specified message was not found.'')') + RETURN + END IF + ELSE + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) ! Get message directory entry + CALL CLOSE_BULLDIR + IF (NBULL.EQ.0) THEN ! Were messages found? + WRITE(6,'('' ERROR: No messages were found.'')') + RETURN + END IF + + IF (IER1.NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER1) + IF (SBULL.LE.0.OR.IER1.NE.0) THEN + WRITE (6,'(A)') + & ' ERROR: Specified message number has incorrect format.' + RETURN + END IF + ALL = .TRUE. + ELSE IF (CLI$PRESENT('ALL')) THEN + SBULL = 1 + EBULL = NBULL + END IF + END IF + + IF (CLI$PRESENT('SYSTEM')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to system.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SYSTEM cannot be set with selected folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('SHUTDOWN')) THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to shutdown.'')') + RETURN + ELSE IF (.NOT.BTEST(FOLDER_FLAG,2).AND.FOLDER_NUMBER.NE.0) THEN + WRITE (6,'( + & '' ERROR: /SHUTDOWN cannot be set with selected folder.'')') + RETURN + ELSE IF (CLI$GET_VALUE('SHUTDOWN',BULL_PARAMETER).NE. + & %LOC(CLI$_ABSENT).AND.REMOTE_SET) THEN + WRITE (6,'('' ERROR: Shutdown node name not'', + & '' permitted for remote folder.'')') + RETURN + END IF + END IF + + IF (CLI$PRESENT('PERMANENT').AND. + & F_EXPIRE_LIMIT.GT.0.AND..NOT. ! Expiration limit present + & FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE (6,'( + & '' ERROR: Not enough privileges to change to permanent.'')') + RETURN + END IF +C +C Check to see if specified bulletin is present, and if the user +C is permitted to replace the bulletin. +C + + CALL OPEN_BULLDIR_SHARED + + SAME_OWNER = .TRUE. + DO I=SBULL,EBULL + CALL READDIR(I,IER) ! Get info for specified messages + IF (USERNAME.NE.FROM) SAME_OWNER = .FALSE. + END DO + CALL READDIR(SBULL,IER) + + CALL CLOSE_BULLDIR + + IF (.NOT.SAME_OWNER) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER) + & .AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1090) ! If not, then error out. + RETURN + ELSE + WRITE (6,1100) ! Make sure user wants to delete it + READ (5,'(A)',IOSTAT=IER) ANSWER ! Get his answer + CALL STR$UPCASE(ANSWER,ANSWER) ! Convert input to uppercase + IF (ANSWER.NE.'Y') RETURN ! If not Yes, then exit + END IF + END IF + +C +C If no switches were given, replace the full bulletin +C + + DOALL = .FALSE. + + TEXT = CLI$PRESENT('TEXT') + + IF ((.NOT.CLI$PRESENT('EXPIRATION')).AND. + & (.NOT.CLI$PRESENT('GENERAL')).AND. + & (.NOT.CLI$PRESENT('SYSTEM')).AND. + & (.NOT.CLI$PRESENT('HEADER')).AND. + & (.NOT.CLI$PRESENT('SUBJECT')).AND. + & (.NOT.TEXT).AND. + & (.NOT.CLI$PRESENT('SHUTDOWN')).AND. + & (.NOT.CLI$PRESENT('PERMANENT'))) THEN + DOALL = .TRUE. + END IF + + IF (SBULL.NE.EBULL.AND.(DOALL.OR.TEXT)) THEN + WRITE (6,'('' ERROR: Cannot change text when replacing'', + & '' more than one messsage.'')') + RETURN + END IF + + CALL DISABLE_CTRL ! Disable CTRL-Y & -C + + PERMANENT = .FALSE. + IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + SYSTEM = 0 + CALL GET_EXPIRED(INPUT,IER) + PERMANENT = BTEST(SYSTEM,1) + IF (.NOT.IER) GO TO 910 + INEXDATE = INPUT(:11) + INEXTIME = INPUT(13:) + END IF + +8 LENDES = 0 + IF (CLI$PRESENT('HEADER').OR.DOALL) THEN + WRITE(6,1050) ! Request header for bulletin + READ(5,'(Q,A)',END=910,ERR=910) LENDES,INDESCRIP + IF (LENDES.EQ.0) GO TO 910 ! If no header, don't add bull + ELSE IF (CLI$PRESENT('SUBJECT')) THEN + IER = CLI$GET_VALUE('SUBJECT',INDESCRIP,LENDES) + END IF + + IF (LENDES.GT.0) THEN + INDESCRIP = 'Subj: '//INDESCRIP + LENDES = MIN(LENDES+6,LEN(INDESCRIP)) + END IF + + IF (SBULL.NE.EBULL) CALL OPEN_BULLDIR + + DO NUMBER=SBULL,EBULL + NUMBER_PARAM = NUMBER + IF (SBULL.NE.EBULL) THEN + CALL READDIR(NUMBER_PARAM,IER) + IF (IER.NE.NUMBER_PARAM+1) THEN ! Couldn't find message + CALL CLOSE_BULLDIR + WRITE(6,'('' ERROR: Message '',I6,'' cannot be found.'')') + & NUMBER_PARAM + WRITE(6,'('' All messages up to that message were modified.'')') + RETURN + END IF + END IF + + REC1 = 0 + + LENFROM = 0 + + IF (LENDES.GT.0.OR.TEXT.OR.DOALL) THEN + OPEN(UNIT=3,FILE='SYS$LOGIN:BULL.SCR',IOSTAT=IER, + & RECL=LINE_LENGTH,STATUS='SCRATCH',CARRIAGECONTROL='LIST') + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + CALL OPEN_BULLFIL_SHARED + + REC1 = 1 + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + INFROM = INPUT(:ILEN) + LENFROM = ILEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + IF (LENDES.EQ.0.AND..NOT.DOALL) THEN + INDESCRIP = INPUT(:ILEN) + LENDES = ILEN + END IF + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + + DO WHILE (ILEN.GT.0) ! Copy bulletin into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + + CALL CLOSE_BULLFIL + + IF (TEXT.OR.DOALL) CLOSE(UNIT=3) + END IF + + IF (TEXT.OR.DOALL) THEN +C +C If file specified in REPLACE command, read file to obtain bulletin. +C Else, read the bulletin from the terminal. +C + + ICOUNT = 0 ! Line count for bulletin + LAST_NOBLANK = 0 ! Last line with data + REC1 = 1 + + IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT).OR. ! If file param in ADD command + & ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! or /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED)))) THEN + + IF ((CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND. ! If /EDIT specified + & (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))) THEN + IF (LEN_P.EQ.0) THEN ! If no file param specified + IF (.NOT.CLI$PRESENT('NEW')) THEN + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='NEW', + & RECL=LINE_LENGTH, + & ERR=920,FORM='FORMATTED',CARRIAGECONTROL='LIST') + CALL OPEN_BULLFIL_SHARED ! Prepare to copy message + ILEN = LINE_LENGTH + 1 + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END IF + DO WHILE (ILEN.GT.0) ! Copy message into file + WRITE (3,'(A)') INPUT(:ILEN) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + END DO + CALL CLOSE_BULLFIL + CLOSE (UNIT=3) ! Bulletin copy completed + END IF + CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ') + ELSE + CALL DISABLE_PRIVS + CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR') + END IF + IER = LIB$DELETE_FILE('SYS$LOGIN:BULL.SCR;-1') + OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD', + & DISPOSE='DELETE',ERR=920,FORM='FORMATTED') + ELSE IF (LEN_P.GT.0) THEN + CALL DISABLE_PRIVS + OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD', + & READONLY,SHARED,ERR=920,FORM='FORMATTED') ! Try opening the file + END IF + + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + + DO WHILE(1) ! Read until end of file to + READ (3,'(Q,A)',END=10) ILEN,INPUT ! get record count + IF (ILEN.GT.LINE_LENGTH) GO TO 950 + CALL STR$TRIM(INPUT,INPUT,ILEN) + IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + ILEN + 1 ! Increment record count + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0) THEN + IF (ICOUNT.GT.0) THEN + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + ELSE ! 1 space for a blank line. + REC1 = REC1 + 1 + END IF + END IF + END DO + ELSE ! If no input file + OPEN (UNIT=3,STATUS='NEW',FILE='SYS$LOGIN:BULL.SCR',ERR=920, + & DISPOSE='DELETE',FORM='FORMATTED',RECL=LINE_LENGTH, + & CARRIAGECONTROL='LIST') ! Scratch file to save bulletin + WRITE (6,1000) ! Request bulletin input from terminal + ILEN = LINE_LENGTH ! Length of input line + DO WHILE (ILEN.GE.0) ! Input until no more input + CALL GET_LINE(INPUT,ILEN) ! Get input line + IF (ILEN.GT.LINE_LENGTH) THEN ! Line too long. + WRITE(6,'('' ERROR: Input line length > '',I, + & ''. Reinput::'')') LINE_LENGTH + ELSE IF (ILEN.GT.0) THEN ! If good input line entered + ICOUNT = ICOUNT + 1 + ILEN ! Increment character count + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + LAST_NOBLANK = ICOUNT + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.0) THEN + WRITE(3,'(A)') INPUT(:ILEN) ! Save line in scratch file + ICOUNT = ICOUNT + 2 ! COPY_BULL writes a line with + END IF ! 1 space for a blank line. + END DO + IF (ILEN.EQ.-1) GO TO 910 ! CTRL_C entered, error out +10 ICOUNT = LAST_NOBLANK + IF (ICOUNT.EQ.0) GO TO 910 ! No lines entered, error out + ENDIF + + END IF + +C +C Add bulletin to bulletin file and directory entry for to directory file. +C + + DATE_SAVE = DATE + TIME_SAVE = TIME + INPUT = DESCRIP + + IF (SBULL.EQ.EBULL) THEN + CALL OPEN_BULLDIR ! Prepare to add dir entry + CALL READDIR(NUMBER_PARAM,IER) ! Get info for message + + IF (IER.NE.NUMBER_PARAM+1.OR.DATE.NE.DATE_SAVE.OR. + & TIME.NE.TIME_SAVE.OR.INPUT.NE.DESCRIP) THEN + ! If message disappeared, try to find it. + IF (IER.NE.NUMBER_PARAM+1) DATE = ' ' + NUMBER_PARAM = 0 + IER = 1 + DO WHILE (IER.EQ.NUMBER_PARAM+1.AND. + & (DATE.NE.DATE_SAVE.OR.TIME.NE.TIME_SAVE.OR.DESCRIP.NE.INPUT)) + NUMBER_PARAM = NUMBER_PARAM + 1 + CALL READDIR(NUMBER_PARAM,IER) + END DO + + IF (IER.NE.NUMBER_PARAM+1) THEN ! Couldn't find message + CALL CLOSE_BULLDIR + CLOSE (UNIT=3,STATUS='SAVE') + WRITE(6,'('' ERROR: Message has been deleted'', + & '' by another user.'')') + IF (DOALL.OR.TEXT) THEN + WRITE (6,'('' New text has been saved in'', + & '' SYS$LOGIN:BULL.SCR.'')') + END IF + GO TO 100 + END IF + END IF + END IF + + CALL READDIR(0,IER) ! Get directory header + + IF (REC1.GT.0) THEN ! If text has been replaced + + CALL OPEN_BULLFIL ! Prepare to add bulletin + + BLOCK = NBLOCK + 1 + BLOCK_SAVE = BLOCK + NEMPTY = NEMPTY + LENGTH + + OBLOCK = BLOCK + IF (LENFROM.GT.0) THEN + CALL STORE_BULL(LENFROM,INFROM(:LENFROM),OBLOCK) + END IF + IF (LENDES.GT.0) THEN + CALL STORE_BULL(LENDES,INDESCRIP(:LENDES),OBLOCK) + END IF + REWIND (UNIT=3) + CALL COPY_BULL(3,REC1,OBLOCK,IER) ! Add the new bulletin + IF (IER.NE.0) THEN ! Error in creating bulletin + WRITE (6,'(A)') ' ERROR: Unable to replace message.' + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + CLOSE (UNIT=3) + GO TO 100 + END IF + + LENGTH_SAVE = OCOUNT - BLOCK + 1 + NBLOCK = NBLOCK + LENGTH_SAVE + + IF (.NOT.REMOTE_SET) CALL WRITEDIR(0,IER) + + CALL CLOSE_BULLFIL + + IF (.NOT.REMOTE_SET) THEN + CALL READDIR(NUMBER_PARAM,IER) ! Get directory entry + LENGTH = LENGTH_SAVE ! Update size + BLOCK = BLOCK_SAVE + CALL WRITEDIR(NUMBER_PARAM,IER) ! Write new directory entry + END IF + ELSE + CALL READDIR(NUMBER_PARAM,IER) + END IF + + IF (.NOT.REMOTE_SET) THEN + + IF (LENDES.GT.0.OR.DOALL) THEN + DESCRIP=INDESCRIP(7:59) ! Update description header + END IF + CALL UPDATE_DIR_HEADER((CLI$PRESENT('EXPIRATION').OR.DOALL).AND. + & .NOT.PERMANENT,CLI$PRESENT('PERMANENT').OR.PERMANENT, + & CLI$PRESENT('SHUTDOWN'),INEXDATE,INEXTIME) + IF (CLI$PRESENT('SYSTEM')) THEN + SYSTEM = IBSET(SYSTEM,0) + ELSE IF (CLI$PRESENT('GENERAL')) THEN + SYSTEM = IBCLR(SYSTEM,0) + END IF + CALL WRITEDIR(NUMBER_PARAM,IER) + ELSE + MSGTYPE = 0 + IF (CLI$PRESENT('SYSTEM').OR. + & (BTEST(SYSTEM,0).AND..NOT.CLI$PRESENT('GENERAL'))) THEN + MSGTYPE = IBSET(MSGTYPE,0) + END IF + IF (CLI$PRESENT('PERMANENT').OR.PERMANENT) THEN + MSGTYPE = IBSET(MSGTYPE,1) + ELSE IF (CLI$PRESENT('SHUTDOWN')) THEN + MSGTYPE = IBSET(MSGTYPE,2) + ELSE IF ((CLI$PRESENT('EXPIRATION').OR.DOALL) + & .AND..NOT.PERMANENT) THEN + MSGTYPE = IBSET(MSGTYPE,3) + END IF + IF (LENDES.EQ.0.AND..NOT.DOALL) INDESCRIP(7:) = DESCRIP + IF (CLI$PRESENT('EXPIRATION').OR.DOALL) THEN + EXDATE = INEXDATE + EXTIME = INEXTIME + END IF + WRITE (REMOTE_UNIT,'(7A)',IOSTAT=IER) + & 10,DESCRIP,NUMBER_PARAM,INDESCRIP(7:59),MSGTYPE, + & EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + END DO + + CALL CLOSE_BULLDIR ! Totally finished with replace + + CLOSE (UNIT=3) + +100 CALL ENABLE_CTRL ! Enable CTRL-Y & -C + RETURN + +910 WRITE(6,1010) + CLOSE (UNIT=3,ERR=100) + GOTO 100 + +920 WRITE(6,1020) + CALL ENABLE_PRIVS ! Reset SYSPRV privileges + GOTO 100 + +950 WRITE (6,1030) LINE_LENGTH + CLOSE (UNIT=3) + GO TO 100 + +1000 FORMAT (' Enter message: End with ctrl-z, cancel with ctrl-c') +1005 FORMAT (' ERROR: You are not reading any message.') +1010 FORMAT (' No message was replaced.') +1015 FORMAT (' ERROR: Specified message was not found.') +1020 FORMAT (' ERROR: Unable to open specified file.') +1030 FORMAT (' ERROR: Line length in file exceeds '',I,'' characters.') +1050 FORMAT (' Enter description header.') +1090 FORMAT(' ERROR: Specified message is not owned by you.') +1100 FORMAT(' Message(s) is not owned by you.', + & ' Are you sure you want to replace it? ',$) +2020 FORMAT(1X,A) + + END + + + + SUBROUTINE UPDATE_DIR_HEADER(EXPIRE,PERM,SHUT,INEXDATE,INEXTIME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + EXTERNAL CLI$_ABSENT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER TODAY*23,INEXDATE*11,INEXTIME*11 + + IF (EXPIRE) THEN + SYSTEM = IBCLR(SYSTEM,1) + SYSTEM = IBCLR(SYSTEM,2) + EXDATE=INEXDATE ! Update expiration date + EXTIME=INEXTIME + DIFF = COMPARE_DATE(EXDATE,NEWEST_EXDATE) ! Compare expiration + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,NEWEST_EXTIME) + IF (DIFF.LT.0) THEN ! If it's oldest expiration bull + NEWEST_EXDATE = EXDATE ! Update the header in + NEWEST_EXTIME = EXTIME ! the directory file + CALL WRITEDIR(0,IER) + END IF + ELSE IF (PERM.AND.(.NOT.BTEST(SYSTEM,1))) THEN + IF (BTEST(SYSTEM,2)) THEN + SYSTEM = IBCLR(SYSTEM,2) + SHUTDOWN = SHUTDOWN - 1 + CALL WRITEDIR(0,IER) + END IF + SYSTEM = IBSET(SYSTEM,1) + EXDATE = '5-NOV-2000' + EXTIME = '00:00:00.00' + ELSE IF (SHUT.AND.(.NOT.BTEST(SYSTEM,2))) THEN + SYSTEM = IBSET(SYSTEM,2) + SYSTEM = IBCLR(SYSTEM,1) + EXDATE = '5-NOV-2000' + NODE_AREA = 0 + IF (INCMD(:4).EQ.'REPL') THEN + IF (CLI$GET_VALUE('SHUTDOWN',NODE_NAME) + & .NE.%LOC(CLI$_ABSENT)) THEN + CALL GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,NODE_NAME) + IF (NODE_AREA.EQ.0) THEN + WRITE (6,'('' ERROR: Shutdown node name ignored.'', + & '' Invalid node name specified.'')') + END IF + END IF + END IF + IF (NODE_AREA.EQ.0) 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) + SHUTDOWN = SHUTDOWN + 1 + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + SHUTDOWN_DATE = TODAY(:11) + SHUTDOWN_TIME = TODAY(13:) + CALL WRITEDIR(0,IER) + END IF + + RETURN + END + + + + + SUBROUTINE SEARCH(READ_COUNT) +C +C SUBROUTINE SEARCH +C +C FUNCTION: Search for bulletin with specified string +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + CHARACTER*132 SEARCH_STRING + + EXTERNAL CLI$_ABSENT + + IF (INCMD.NE.'SEAR') NFOLDER = 1 + + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL INIT_QUEUE(SCRATCH_F1,FOLDER1_NAME) + SCRATCH_F = SCRATCH_F1 + NFOLDER = 0 + END IF + + DO WHILE (CLI$GET_VALUE('SELECT_FOLDER',FOLDER1_NAME) + & .NE.%LOC(CLI$_ABSENT)) ! Get the specified folders + IF (TRIM(FOLDER1_NAME).EQ.0) FOLDER1_NAME = FOLDER_NAME + NFOLDER = NFOLDER + 1 + CALL WRITE_QUEUE(%VAL(SCRATCH_F),SCRATCH_F,FOLDER1_NAME) + END DO + + IF (CLI$PRESENT('SELECT_FOLDER')) SCRATCH_F = SCRATCH_F1 + + START_BULL = BULL_POINT + + IF (CLI$PRESENT('START')) THEN ! Starting message specified + CALL CLI$GET_VALUE('START',BULL_PARAMETER,LEN_P) + DECODE(LEN_P,'(I)',BULL_PARAMETER) START_BULL + IF (.NOT.CLI$PRESENT('REPLY')) START_BULL = START_BULL - 1 + END IF + + IER = CLI$GET_VALUE('SEARCH_STRING',SEARCH_STRING,SEARCH_LEN) + + IF (NFOLDER.GT.0) FOUND = 0 + + DO WHILE (NFOLDER.GT.0.AND.FOUND.LE.0) + IF (.NOT.CLI$PRESENT('SELECT_FOLDER').OR. + & SCRATCH_F.NE.SCRATCH_F1) + & CALL GET_SEARCH(FOUND,SEARCH_STRING,START_BULL, + & CLI$PRESENT('REVERSE'),CLI$PRESENT('SUBJECT'), + & CLI$PRESENT('REPLY'),.TRUE.,CLI$PRESENT('START')) + IF (FOUND.EQ.-1) THEN + NFOLDER = 0 + ELSE IF (FOUND.LE.0) THEN + IF (.NOT.CLI$PRESENT('SELECT_FOLDER').OR. + & SCRATCH_F.NE.SCRATCH_F1) NFOLDER = NFOLDER - 1 + IF (NFOLDER.GT.0) THEN + CALL READ_QUEUE(%VAL(SCRATCH_F),SCRATCH_F,FOLDER1_NAME) + OLD_FOLDER_NUMBER = FOLDER_NUMBER + FOLDER_NUMBER = -1 + IER = 0 + DO WHILE (.NOT.IER.AND.NFOLDER.GT.0) + FOLDER1 = FOLDER1_NAME + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) THEN + FOLDER_NUMBER = OLD_FOLDER_NUMBER + WRITE (6,'('' ERROR: Cannot find folder '',A, + & ''.'')') FOLDER1_NAME(:TRIM(FOLDER1_NAME)) + CALL GET_INPUT_PROMPT(FOLDER1_NAME,ILEN, + & 'Type new folder name or hit RETURN to continue: ') + IF (ILEN.LE.0.AND.NFOLDER.GT.0) THEN + NFOLDER = NFOLDER - 1 + CALL READ_QUEUE(%VAL(SCRATCH_F),SCRATCH_F, + & FOLDER1_NAME) + END IF + END IF + END DO + END IF + END IF + END DO + + IF (FOUND.GT.0) THEN + BULL_POINT = FOUND - 1 + CALL READ_MSG(READ_COUNT,BULL_POINT+1) ! Read next bulletin + ELSE IF (FOUND.EQ.0) THEN + WRITE (6,'('' No messages found with given search string.'')') + ELSE IF (FOUND.EQ.-2) THEN + WRITE (6,'('' ERROR: No more messages.'')') + END IF + + RETURN + END + + + + + SUBROUTINE GET_SEARCH(FOUND,SEARCH_STRING,START_BULL,REVERSE, + & SUBJECT,REPLY,FILES,START) +C +C SUBROUTINE GET_SEARCH +C +C FUNCTION: Search for bulletin with specified string +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /NEXT/ NEXT + + CHARACTER*(*) SEARCH_STRING + + CHARACTER*132 SAVE_STRING + DATA SAVE_STRING/' '/ + + CHARACTER*53 DESCRIP1 + + FOUND = -1 + + CALL DISABLE_CTRL + + CALL DECLARE_CTRLC_AST + + IF (TRIM(SEARCH_STRING).EQ.0) THEN + IER1 = .FALSE. + ELSE + IER1 = .TRUE. + END IF + + IF (.NOT.IER1.AND..NOT.REPLY.AND. + & (SUBJECT.OR.SEARCH_MODE.NE.1)) THEN + ! If no search string entered + SEARCH_STRING = SAVE_STRING ! use saved search string + IF (TRIM(SAVE_STRING).EQ.0) THEN + WRITE (6,'('' No search string present.'')') + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + RETURN + END IF + IF (STEP_BULL.EQ.-1) START_BULL = START_BULL - 2 + ELSE IF (.NOT.IER1.AND.SEARCH_MODE.EQ.1) THEN + SEARCH_STRING = SAVE_STRING ! use saved search string + END IF + + IF (FILES) CALL OPEN_BULLDIR_SHARED + + CALL READDIR(0,IER) + + OLD_SEARCH_MODE = SEARCH_MODE + IF (IER1) THEN ! If string entered + IF (SUBJECT) THEN + SEARCH_MODE = 3 + ELSE + SEARCH_MODE = 2 + END IF + ELSE IF (SUBJECT.AND.SEARCH_MODE.NE.3) THEN + SEARCH_MODE = 3 + ELSE IF (REPLY) THEN + CALL READDIR(START_BULL,IER) + IF (START_BULL+1.NE.IER) THEN + WRITE (6,'('' ERROR: No message being read.'')') + IF (FILES) CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + RETURN + ELSE + SEARCH_MODE = 1 + SEARCH_STRING = DESCRIP + IF (REVERSE) START_BULL = START_BULL - 2 + END IF + END IF + + SAVE_STRING = SEARCH_STRING + SEARCH_LEN = TRIM(SAVE_STRING) + + CALL STR$UPCASE(SEARCH_STRING,SEARCH_STRING) ! Make upper case + + IF (IER1.OR.SEARCH_MODE.NE.OLD_SEARCH_MODE.OR. + & REVERSE.OR.REPLY) THEN + IF (.NOT.START.AND.SEARCH_MODE.NE.1) THEN + START_BULL = 0 ! If starting message not specified, use first + IF (REVERSE) START_BULL = NBULL - 1 ! or last + END IF + IF (REVERSE) THEN + END_BULL = 1 + STEP_BULL = -1 + ELSE + END_BULL = NBULL + STEP_BULL = 1 + END IF + END IF + + IF ((START_BULL+1.GT.NBULL.AND.STEP_BULL.EQ.1).OR. + & (START_BULL+1.EQ.0)) THEN + FOUND = -2 + IF (FILES) CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + RETURN + END IF + + IF (FILES) CALL OPEN_BULLFIL_SHARED + + SAVE_BULL_SEARCH = 0 + DO BULL_SEARCH = START_BULL+1, END_BULL, STEP_BULL + CALL READDIR(BULL_SEARCH,IER) ! Get bulletin directory entry + IF (READ_TAG) THEN + IF (STEP_BULL.EQ.-1) THEN + CALL GET_THIS_TAG(FOLDER_NUMBER,IER,BULL_SEARCH,DUMMY) + IF (IER.NE.0) THEN + CALL GET_PREVIOUS_TAG(FOLDER_NUMBER,IER, + & BULL_SEARCH,DUMMY) + END IF + ELSE + CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER, + & BULL_SEARCH,DUMMY) + END IF + IF (IER.EQ.0) THEN + IER = BULL_SEARCH + 1 + ELSE + GO TO 800 + END IF + END IF + IF (REMOTE_SET.EQ.3.AND.SAVE_BULL_SEARCH.EQ.BULL_SEARCH) GO TO 800 + SAVE_BULL_SEARCH = BULL_SEARCH + IF (IER.EQ.BULL_SEARCH+1.AND.SEARCH_MODE.NE.2) THEN + CALL STR$UPCASE(DESCRIP1,DESCRIP) ! Make upper case + IF ((SEARCH_MODE.EQ.3.AND. + & INDEX(DESCRIP1,SEARCH_STRING(:SEARCH_LEN)).GT.0).OR. + & (SEARCH_MODE.EQ.1.AND.(DESCRIP1.EQ.SEARCH_STRING.OR. + & INDEX(SEARCH_STRING,DESCRIP1(5:)).EQ.1))) THEN + FOUND = BULL_SEARCH + GO TO 900 + ELSE IF (FLAG.EQ.1) THEN + WRITE (6,'('' Search aborted.'')') + GO TO 900 + END IF + END IF + IF (IER.EQ.BULL_SEARCH+1.AND.SEARCH_MODE.EQ.2) THEN + IF (REMOTE_SET) THEN + CALL REMOTE_READ_MESSAGE(BULL_SEARCH,IER) + IF (IER.GT.0) THEN + CALL DISCONNECT_REMOTE + GO TO 900 + ELSE + CALL GET_REMOTE_MESSAGE(IER) + IF (IER.GT.0) GO TO 900 + END IF + END IF + ILEN = LINE_LENGTH + 1 + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + CALL STR$UPCASE(INPUT,INPUT) ! Make upper case + IF (INDEX(INPUT,SEARCH_STRING(:SEARCH_LEN)).GT.0) THEN + FOUND = BULL_SEARCH + GO TO 900 + ELSE IF (FLAG.EQ.1) THEN + WRITE (6,'('' Search aborted.'')') + GO TO 900 + END IF + END DO + END IF + END DO + +800 FOUND = 0 + +900 IF (FILES) CALL CLOSE_BULLFIL ! End of bulletin file read + IF (FILES) CALL CLOSE_BULLDIR + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + + RETURN + END + + + + + SUBROUTINE UNDELETE +C +C SUBROUTINE UNDELETE +C +C FUNCTION: Undeletes deleted message. +C + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + EXTERNAL CLI$_ABSENT + + IF (REMOTE_SET.EQ.3) THEN + WRITE (6,'('' Cannot UNDELETE messages in this folder.'')') + RETURN + END IF +C +C Get the bulletin number to be undeleted. +C + + IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? + DECODE(LEN_P,5,BULL_PARAMETER,ERR=920) BULL_DELETE ! Yes +5 FORMAT(I) + ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? + GO TO 910 ! No, then error. + ELSE + BULL_DELETE = BULL_POINT ! Delete the file we are reading + END IF + + IF (BULL_DELETE.LE.0) GO TO 920 + +C +C Check to see if specified bulletin is present, and if the user +C is permitted to delete the bulletin. +C + + CALL OPEN_BULLDIR + + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + + IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, + IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges or + & (.NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER) + & .AND.FOLDER_SET)) THEN ! folder owner? + WRITE(6,1040) ! Then error out. + GO TO 100 + ELSE + CALL READDIR(BULL_DELETE,IER) ! Get info for specified bulletin + IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? + WRITE(6,1030) ! If not, then error out + GOTO 100 + END IF + END IF + END IF + + IF ((SYSTEM.AND.7).LE.1) THEN ! General or System message + EXDATE = EXDATE(:7)//'19'//EXDATE(10:) + ELSE ! Permanent or Shutdown + IF (EXDATE(2:2).EQ.'-') THEN + EXDATE = EXDATE(:6)//'20'//EXDATE(9:) + ELSE + EXDATE = EXDATE(:7)//'20'//EXDATE(10:) + END IF + END IF + + IF (.NOT.REMOTE_SET) THEN + CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date + WRITE (6,'('' Message was undeleted.'')') + ELSE + WRITE (REMOTE_UNIT,'(5A)',IOSTAT=IER) + & 11,BULL_DELETE,DESCRIP,EXDATE,EXTIME + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.NE.LEN(FOLDER1_COM)) THEN + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + ELSE + WRITE (6,'('' Message was undeleted.'')') + END IF + ELSE + CALL DISCONNECT_REMOTE + END IF + END IF + +100 CALL CLOSE_BULLDIR + +900 RETURN + +910 WRITE(6,1010) + GO TO 900 + +920 WRITE(6,1020) + GO TO 900 + +1010 FORMAT(' ERROR: You are not reading any message.') +1020 FORMAT(' ERROR: Specified message number has incorrect format.') +1030 FORMAT(' ERROR: Specified message was not found.') +1040 FORMAT(' ERROR: Message was not undeleted. Not owned by you.') + + END + + + + SUBROUTINE ADD_PROTOCOL(INPUT,ILEN) + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLNEWS.INC' + + CHARACTER*20 MAIL_PROTOCOL + + CHARACTER*(*) INPUT + + DATA LMAIL/0/ + + IF (LMAIL.EQ.-1) RETURN + + IF (INDEX(INPUT,'@').EQ.0.OR.INDEX(INPUT,'%"').GT.0) RETURN + + IF (LMAIL.EQ.0) THEN + IF (.NOT.SYS_TRNLNM('BULL_NEWS_MAILER',MAIL_PROTOCOL)) THEN + MAIL_PROTOCOL = MAILER + END IF + LMAIL = TRIM(MAIL_PROTOCOL) + IF (LMAIL.GT.0.AND.MAIL_PROTOCOL(LMAIL:LMAIL).NE.'%') THEN + MAIL_PROTOCOL = MAIL_PROTOCOL(:LMAIL)//'%' + LMAIL = LMAIL + 1 + END IF + IF (LMAIL.EQ.0) THEN + LMAIL = -1 + RETURN + END IF + END IF + + INPUT = MAIL_PROTOCOL(:LMAIL)//'"'//INPUT(:TRIM(INPUT))//'"' + + IF (ILEN.NE.0) ILEN = ILEN + LMAIL + 2 + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin3.for b/decus/vax91b/gce91b/net91b/bulletin3.for new file mode 100644 index 0000000..73cde8b --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin3.for @@ -0,0 +1,1921 @@ +C +C BULLETIN3.FOR, Version 5/3/91 +C Purpose: Contains subroutines for the bulletin board utility program. +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + SUBROUTINE UPDATE +C +C SUBROUTINE UPDATE +C +C FUNCTION: Searches for bulletins that have expired and deletes them. +C +C NOTE: Assumes directory file is already opened. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER*107 DIRLINE + + CHARACTER*11 TEMP_DATE,TEMP_EXDATE,TEMP_NOSYSDATE + CHARACTER*11 TEMP_TIME,TEMP_EXTIME,TEMP_NOSYSTIME + + IF (REMOTE_SET.AND. + & NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + + IF (TEST_BULLCP().OR.REMOTE_SET) RETURN + ! BULLCP cleans up expired bulletins + + ENTRY UPDATE_ALWAYS ! Entry to skip BULLCP test + + TEMP_EXDATE = '5-NOV-2000' ! If a bulletin gets deleted, and there are + TEMP_EXTIME = '00:00:00.00' ! are no more bulletins, this is the value + ! assigned to the latest expiration date + + TEMP_DATE = '5-NOV-1956' ! Storage for computing newest + TEMP_TIME = '00:00:00.00' ! bulletin date if deletion occurs + + TEMP_NOSYSDATE = '5-NOV-1956' ! Storage for computing newest + TEMP_NOSYSTIME = '00:00:00.00' ! non-system bulletin date + + BULL_ENTRY = 1 ! Init bulletin pointer + UPDATE_DONE = 0 ! Flag showing bull has been deleted + + NEW_SHUTDOWN = 0 + OLD_SHUTDOWN = SHUTDOWN + + DO WHILE (1) + CALL READDIR(BULL_ENTRY,IER) ! Get next directory entry + IF (IER.EQ.BULL_ENTRY) GO TO 100 ! ERROR: Not found + IF ((SYSTEM.AND.7).LE.3.OR.(OLD_SHUTDOWN.EQ.0 + ! If not shutdown, or time + & .AND.(SYSTEM.AND.4).EQ.4)) THEN ! to delete shutdowns? + IF ((SYSTEM.AND.4).EQ.4) THEN ! Shutdown bulletin? + IF (NODE_AREA.GT.0) THEN + EXTIME(3:4) = EXTIME(4:5) + READ (EXTIME(1:4),'(I4)') NODE_NUMBER_MSG + EXTIME(9:10) = EXTIME(10:11) + READ (EXTIME(7:10),'(I4)') NODE_AREA_MSG + IF (NODE_NUMBER_MSG.EQ.NODE_NUMBER.AND. + & NODE_AREA_MSG.EQ.NODE_AREA) THEN + DIFF = 0 + ELSE + DIFF = 1 + END IF + ELSE + DIFF = COMPARE_DATE(EXDATE,' ') + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,' ') + END IF + IF (DIFF.GT.0) NEW_SHUTDOWN = NEW_SHUTDOWN + 1 + ELSE + DIFF = COMPARE_DATE(EXDATE,' ') ! Has expiration date passed? + IF (DIFF.EQ.0) DIFF = COMPARE_TIME(EXTIME,' ') + END IF + IF (DIFF.LE.0) THEN ! If so then delete bulletin + CALL DELETE_ENTRY(BULL_ENTRY) ! Delete bulletin entry + IF (UPDATE_DONE.EQ.0) THEN ! If this is first deleted file + UPDATE_DONE = BULL_ENTRY ! store it to use for reordering + END IF ! directory file. + ELSE IF ((SYSTEM.AND.7).LE.3) THEN ! Expiration date hasn't passed + ! If a bulletin is deleted, we'll have to update the latest + ! expiration date. The following does that. + DIFF = COMPARE_DATE(EXDATE,TEMP_EXDATE) + IF (DIFF.LT.0.OR.(DIFF.EQ.0.AND. + & COMPARE_TIME(EXTIME,TEMP_EXTIME).LT.0)) THEN + TEMP_EXDATE = EXDATE ! If this is the latest exp + TEMP_EXTIME = EXTIME ! date seen so far, save it. + END IF + TEMP_DATE = DATE ! Keep date after search + TEMP_TIME = TIME ! we have the last message date + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + ELSE + TEMP_DATE = DATE + TEMP_TIME = TIME + IF (.NOT.BTEST(SYSTEM,0)) THEN + TEMP_NOSYSDATE = DATE + TEMP_NOSYSTIME = TIME + END IF + END IF + BULL_ENTRY = BULL_ENTRY + 1 + END DO + +100 IF (UPDATE_DONE.GT.0) THEN ! Reorder directory file + CALL CLEANUP_DIRFILE(UPDATE_DONE) ! due to deleted entries + END IF + + DATE = NEWEST_DATE + TIME = NEWEST_TIME + CALL READDIR(0,IER) + SHUTDOWN = NEW_SHUTDOWN + NEWEST_EXDATE = TEMP_EXDATE + DIFF = COMPARE_DATE(NEWEST_EXDATE,' ') + IF (DIFF.GT.20*356) NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = TEMP_EXTIME + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL WRITEDIR(0,IER) + SYSTEM = 0 ! Updating last non-system date/time + NEWEST_DATE = TEMP_NOSYSDATE + NEWEST_TIME = TEMP_NOSYSTIME + CALL UPDATE_FOLDER + SYSTEM = 1 ! Now update latest date/time + NEWEST_DATE = TEMP_DATE + NEWEST_TIME = TEMP_TIME + CALL UPDATE_FOLDER + + IF (NODE_AREA.GT.0.AND.BTEST(FOLDER_FLAG,2)) THEN ! Shutdowns deleted? + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) ! Save that info + END IF + +C +C If newest message date has been changed, must change it in BULLUSER.DAT +C and also see if it affects notification of new messages to users +C + IF (TEMP_DATE.NE.DATE.OR.TEMP_TIME.NE.TIME) THEN + CALL UPDATE_LOGIN(.FALSE.) + END IF + + RETURN + + END + + + + SUBROUTINE UPDATE_READ(USERFILE_OPEN) +C +C SUBROUTINE UPDATE_READ +C +C FUNCTION: +C Store the latest date that user has used the BULLETIN facility. +C If new bulletins have been added, alert user of the fact. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($PRVDEF)' + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2),READ_BTIM_SAVE(2) + + LOGICAL MODIFY_SYSTEM /.TRUE./ + +C +C Update user's latest read time in his entry in BULLUSER.DAT. +C + IF (.NOT.USERFILE_OPEN) THEN + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + END IF + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.NE.0) THEN ! If header not present, exit + IF (.NOT.USERFILE_OPEN) CALL CLOSE_BULLUSER + RETURN + ELSE IF (USERPRIV(1).EQ.-1.AND.USERPRIV(2).EQ.-1) THEN + ! If header present, but no + DO I=1,FLONG ! SET_FLAG and NOTIFY_FLAG + SET_FLAG_DEF(I) = 0 ! information, write default + NOTIFY_FLAG_DEF(I) = 0 ! flags. + BRIEF_FLAG_DEF(I) = 0 + END DO + SET_FLAG_DEF(1) = 1 + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + + CALL SYS$ASCTIM(,TODAY,,) ! Get today's time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + UNLOCK 4 + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) + + IF (IER1.EQ.0) THEN ! If entry found, update it + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + REWRITE (4) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + ELSE ! If no entry create a new entry + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + LOGIN_BTIM(1) = TODAY_BTIM(1) + LOGIN_BTIM(2) = TODAY_BTIM(2) + READ_BTIM(1) = TODAY_BTIM(1) + READ_BTIM(2) = TODAY_BTIM(2) + CALL WRITE_USER_FILE_NEW(IER) + END IF + + IF (MODIFY_SYSTEM) THEN + CALL MODIFY_SYSTEM_LIST(1) + MODIFY_SYSTEM = .FALSE. + END IF + + IF (.NOT.USERFILE_OPEN) THEN + CALL CLOSE_BULLUSER ! All finished with BULLUSER + END IF + + RETURN ! to go home... + + END + + + + + SUBROUTINE FIND_NEWEST_BULL +C +C SUBROUTINE FIND_NEWEST_BULL +C +C If new bulletins have been added, alert user of the fact and +C set the next bulletin to be read to the first new bulletin. +C +C OUTPUTS: +C BULL_POINT - If -1, no new bulletins to read, else there are. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /POINT/ BULL_POINT + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INTEGER DIR_BTIM(2) + +C +C Now see if bulletins have been added since the user's previous +C read time. If they have, then search for the first new bulletin. +C Ignore new bulletins that are owned by the user or system notices +C that have not been added since the user has logged in. +C + BULL_POINT = -1 ! Init bulletin pointer + + CALL OPEN_BULLDIR_SHARED ! Yep, so get directory file + CALL READDIR(0,IER) ! Get # bulletins from header + IF (IER.EQ.1) THEN + CALL GET_NEWEST_MSG(LAST_READ_BTIM(1,FOLDER_NUMBER+1),START) + IF (START.LE.0) THEN + BULL_POINT = START + CALL CLOSE_BULLDIR + RETURN + END IF + DO WHILE (START.LE.NBULL.AND.(FROM.EQ.USERNAME.OR.SYSTEM)) + IF (FROM.NE.USERNAME) THEN ! Ignore bull if owner is user + IF (SYSTEM) THEN ! If system bulletin + CALL SYS_BINTIM(DATE//' '//TIME,DIR_BTIM) + DIFF = COMPARE_BTIM(LOGIN_BTIM,DIR_BTIM) + IF (DIFF.GT.0) THEN + START = START + 1 + CALL READDIR(START,IER) + ELSE ! SYSTEM bulletin was not seen + SYSTEM = 0 ! so force exit to read it. + END IF + END IF + ELSE + START = START + 1 + CALL READDIR(START,IER) + IF (IER.NE.START+1) START = NBULL + 1 + END IF + END DO + IF (START.LE.NBULL) BULL_POINT = START - 1 + END IF + + CALL CLOSE_BULLDIR + + RETURN + END + + + + SUBROUTINE GET_EXPIRED(EXPDAT,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 EXPDAT + CHARACTER*23 TODAY + + DIMENSION EXTIME(2),NOW(2) + + EXTERNAL CLI$_ABSENT + + IER = SYS$ASCTIM(,TODAY,,) ! Get today's date + + IERC = CLI$GET_VALUE('EXPIRATION',EXPDAT,ILEN) + + PROMPT = .TRUE. + +5 IF (PROMPT) THEN + IF (IERC.NE.%LOC(CLI$_ABSENT)) THEN ! Was value specified? + PROMPT = .FALSE. + ELSE + DEFAULT_EXPIRE = FOLDER_BBEXPIRE + IF ((DEFAULT_EXPIRE.GT.F_EXPIRE_LIMIT.OR.DEFAULT_EXPIRE + & .EQ.0).AND.F_EXPIRE_LIMIT.GT.0.AND..NOT. + & FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + DEFAULT_EXPIRE = F_EXPIRE_LIMIT + END IF + IF (BTEST(FOLDER_FLAG,3)) THEN ! NOPROMPT was set + IF (DEFAULT_EXPIRE.LE.0) THEN ! If no expiration date + SYSTEM = SYSTEM.OR.2 ! make permanent + EXPDAT = '5-NOV-2000 00:00:00.00' + ELSE ! Else set expiration + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + ELSE + IF (DEFAULT_EXPIRE.EQ.0) THEN ! Get expiration date + WRITE(6,1030) TODAY(:INDEX(TODAY,'.')-4) + ELSE IF (DEFAULT_EXPIRE.EQ.-1) THEN + WRITE(6,1031) TODAY(:INDEX(TODAY,'.')-4) + ELSE + WRITE(6,1032) TODAY(:INDEX(TODAY,'.')-4), + & DEFAULT_EXPIRE + END IF + WRITE (6,1035) + CALL GET_LINE(EXPDAT,ILEN) ! Get EXPDAT line + IF (ILEN.EQ.0.AND.DEFAULT_EXPIRE.NE.0) THEN + IF (DEFAULT_EXPIRE.EQ.-1) THEN + EXPDAT = '5-NOV-2000 00:00:00.00' + SYSTEM = IBSET(SYSTEM,1) ! Indicate permanent message + ELSE + CALL GET_EXDATE(EXPDAT,DEFAULT_EXPIRE) + EXPDAT = EXPDAT(:TRIM(EXPDAT))//' 00:00:00.00' + END IF + ILEN = TRIM(EXPDAT) + END IF + END IF + END IF + ELSE + RETURN + END IF + + IF (ILEN.LE.0) THEN + IER = 0 + RETURN + END IF + + EXPDAT = EXPDAT(:ILEN) ! Change trailing zeros 2 spaces + + IF (INDEX(EXPDAT,'-').EQ.0.AND.INDEX(EXPDAT,':').GT.0.AND. + & INDEX(EXPDAT(:ILEN),' ').EQ.0) THEN ! Only time specified? + EXPDAT = TODAY(:INDEX(TODAY(2:),' ')+1)//EXPDAT ! Add date + ELSE IF (INDEX(EXPDAT(6:),'-').EQ.0.AND. ! Date specified + & INDEX(EXPDAT,'-').GT.0) THEN ! but no year? + SPACE = INDEX(EXPDAT,' ') - 1 ! Add year + IF (SPACE.EQ.-1) SPACE = TRIM(EXPDAT) + YEAR = INDEX(TODAY(6:),'-') + EXPDAT = EXPDAT(:SPACE)//TODAY(5+YEAR:9+YEAR)//EXPDAT(SPACE+1:) + END IF + + CALL STR$UPCASE(EXPDAT,EXPDAT) ! Convert to upper case + IER = SYS_BINTIM(EXPDAT,EXTIME) + IF (IER.NE.1) THEN ! If not able to do so + WRITE(6,1040) ! tell user is wrong + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + IF (TIMLEN.EQ.16) THEN + CALL SYS$GETTIM(NOW) + CALL LIB$SUBX(NOW,EXTIME,EXTIME) + IER = SYS$ASCTIM(TIMLEN,EXPDAT,EXTIME,) + END IF + + IF (EXPDAT(2:2).EQ.'-') EXPDAT = '0'//EXPDAT + IER = COMPARE_DATE(EXPDAT(:11),TODAY(:11)) ! Compare date with today's + IF (IER.GT.F_EXPIRE_LIMIT.AND.F_EXPIRE_LIMIT.GT.0.AND. + & .NOT.FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + WRITE(6,1050) F_EXPIRE_LIMIT ! Expiration date > limit + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + IF (IER.EQ.0) IER = COMPARE_TIME(EXPDAT(13:),TODAY(13:)) + IF (IER.LE.0) THEN ! If expiration date not future + WRITE(6,1045) ! tell user + IER = 0 ! Set error for return value + GO TO 5 ! Re-request date (if prompting) + END IF + + IF (PROMPT) THEN + IF (BTEST(SYSTEM,1)) THEN ! Permanent message + WRITE (6,'('' Message will be permanent.'')') + ELSE + WRITE (6,'('' Expiration date will be '',A,''.'')') + & EXPDAT(:TRIM(EXPDAT)) + END IF + END IF + + IER = 1 + + RETURN + +1030 FORMAT(' It is ',A,'. Specify when message expires.') +1031 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is permanent.') +1032 FORMAT(' It is ',A,'. Specify when message expires.', + & ' Default is ',I3,' days.') +1035 Format(' Enter absolute time: [dd-mmm-yyyy] hh:mm:ss ', + & 'or delta time: dddd hh:mm:ss') +1040 FORMAT(' ERROR: Invalid date format specified.') +1045 FORMAT(' ERROR: Specified time has already passed.') +1050 FORMAT(' ERROR: Specified expiration period too large.' + & ' Limit is ',I3,' days.') + + END + + + SUBROUTINE MAILEDIT(INFILE,OUTFILE) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SSDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL BULLETIN_SUBCOMMANDS + + CHARACTER*(*) INFILE,OUTFILE + + CHARACTER*80 MAIL_EDIT,OUT + DATA MAIL_EDIT /' '/ + + CHARACTER*132 INPUT + + CHARACTER*255 SPAWN_COMMAND + + IF (CAPTIVE()) THEN + WRITE (6,'('' ERROR: /EDIT not allowed from CAPTIVE account.'')') + RETURN + END IF + + IF (MAIL_EDIT.EQ.' ') THEN + IF (.NOT.SYS_TRNLNM('MAIL$EDIT',MAIL_EDIT)) THEN + OPEN (UNIT=10,FILE='VMSMAIL_PROFILE', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL_PROFILE.DATA', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + IF (IER.EQ.0) THEN + DO WHILE (REC_LOCK(IER)) + READ(10,'(A)',KEY=USERNAME,IOSTAT=IER) INPUT + END DO + CLOSE (UNIT=10) + IF (IER.EQ.0) THEN + INPUT = INPUT(32:) + DO WHILE (TRIM(INPUT).GT.0) + IF (ICHAR(INPUT(1:1)).EQ.8) THEN + MAIL_EDIT = 'CALLABLE_'//INPUT(5:4+ICHAR(INPUT(3:3))) + INPUT = ' ' + ELSE + INPUT = INPUT(ICHAR(INPUT(3:3))+5:) + END IF + END DO + END IF + END IF + END IF + CALL STR$UPCASE(MAIL_EDIT,MAIL_EDIT) + END IF + + OUT = OUTFILE + IF (TRIM(OUT).EQ.0) THEN + OUT = INFILE + END IF + + CALL DISABLE_PRIVS + CALL DECLARE_CTRLC_AST + IF (TRIM(MAIL_EDIT).GT.0 + & .AND.INDEX(MAIL_EDIT,'CALLABLE_').EQ.0) THEN + IF (OUT.EQ.INFILE) THEN + SPAWN_COMMAND = '$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' "" '//OUT(:TRIM(OUT)) + ELSE + SPAWN_COMMAND = '$@'//MAIL_EDIT(:TRIM(MAIL_EDIT)) + & //' '//INFILE//' '//OUT(:TRIM(OUT)) + END IF + CALL LIB$SPAWN(SPAWN_COMMAND) + ELSE IF (INDEX(MAIL_EDIT,'TPU').GT.0) THEN + CONTEXT = 0 + IER1 = LIB$FIND_FILE(INFILE,INPUT,CONTEXT) + IF (.NOT.IER1) THEN + CALL TPU$EDIT(' ',OUT) + ELSE + CALL TPU$EDIT(INFILE,OUT) + END IF + IER1 = CLI$DCL_PARSE(INCMD,BULLETIN_SUBCOMMANDS) + ! TPU does CLI$ stuff which wipes our parsed command line + ELSE + CALL EDT$EDIT(INFILE,OUT) + END IF + CALL CANCEL_CTRLC_AST + CALL ENABLE_PRIVS + + RETURN + END + + + + + + SUBROUTINE CREATE_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE '($SSDEF)' + + INCLUDE '($PQLDEF)' + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /REALPROC/ REALPROCPRIV(2) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + EXTERNAL CLI$_ABSENT + + DIMENSION IMAGEPRIV(2) + + CHARACTER IMAGENAME*132,ANSWER*1 + + STRUCTURE /QUOTA_ITMLST/ + BYTE ITEM + INTEGER VALUE + END STRUCTURE + + RECORD /QUOTA_ITMLST/ QUOTA(3) + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: You do not have the privileges '', + & ''to execute the command.'')') + CALL EXIT + END IF + + JUST_STOP = CLI$PRESENT('STOP') + + IF (JUST_STOP.AND..NOT.BTEST(REALPROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: You need SETPRV to execute /STOP.'')') + CALL EXIT + ELSE IF (.NOT.JUST_STOP.AND. + & .NOT.BTEST(REALPROCPRIV(1),PRV$V_SYSNAM)) THEN + CALL SYS$SETPRV(,,,IMAGEPRIV) + IF (.NOT.BTEST(IMAGEPRIV(1),PRV$V_SYSNAM)) THEN + WRITE (6,'('' ERROR: This new version of BULLETIN'', + & '' needs to be installed with SYSNAM.'')') + CALL EXIT + END IF + END IF + + IF (TEST_BULLCP()) THEN + IF (.NOT.JUST_STOP) THEN + WRITE (6,'('' BULLCP process running. + & Do you wish to kill it and restart a new one? '',$)') + READ (5,'(A)') ANSWER + IF (ANSWER.NE.'Y'.AND.ANSWER.NE.'y') CALL EXIT + END IF + + CALL DELPRC('BULLCP',IER) + + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + CALL EXIT + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP process has been terminated.'')') + CALL EXIT + END IF + ELSE IF (JUST_STOP) THEN + WRITE (6,'('' BULLCP is not presently running.'')') + CALL EXIT + END IF + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(FOLDER_DIRECTORY) + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) +C +C Generate a new BULLCP.COM each time. This is done in case the BULLETIN +C executeable is moved, or a new version of BULLETIN is being installed that +C has changes to BULLCP.COM. (It's also a security risk to execute the old +C copy, as someone might have been able to write into that directory and +C replace BULLCP.COM, and the command procedure is executed under the +C SYSTEM account, so it has all privileges.) +C + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$SET NOON' + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$LOOP:' + WRITE(11,'(A)') '$PURGE '//FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$OUTPUT ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.LOG' + WRITE(11,'(A)') '$DEF/USER SYS$ERROR ' + & //FOLDER_DIRECTORY(:LEN_B)//'BULLCP.ERR' + WRITE(11,'(A)') '$B/BULLCP' + WRITE(11,'(A)') '$WAIT 00:01:00' + WRITE(11,'(A)') '$GOTO LOOP' ! File open timed out + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + I = 1 + IER = CLI$GET_VALUE('PGFLQUOTA',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + DECODE(LEN_P,'(I)',BULL_PARAMETER) PGFLQUOTA + QUOTA(I).ITEM = PQL$_PGFLQUOTA + QUOTA(I).VALUE = PGFLQUOTA + I = I + 1 + END IF + IER = CLI$GET_VALUE('WSEXTENT',BULL_PARAMETER,LEN_P) + IF (IER.NE.%LOC(CLI$_ABSENT)) THEN + DECODE(LEN_P,'(I)',BULL_PARAMETER) WSEXTENT + QUOTA(I).ITEM = PQL$_WSEXTENT + QUOTA(I).VALUE = WSEXTENT + I = I + 1 + END IF + QUOTA(I).ITEM = PQL$_LISTEND + QUOTA(I).VALUE = 0 + + IER = 0 + DO WHILE (IER.EQ.0.OR.(IER.EQ.SS$_DUPLNAM.AND.PID.GT.0)) + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT',FOLDER_DIRECTORY(:LEN_B) + & //'BULLCP.COM','NL:',,,QUOTA,'BULLCP',%VAL(4), + & ,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + END DO + + IF (IER) THEN + OPEN(UNIT=11,FILE=FOLDER_DIRECTORY(:LEN_B)//'BULLCP.COM;-1', + & STATUS='OLD',IOSTAT=IER1) + IF (IER1.EQ.0) CLOSE(UNIT=11,STATUS='DELETE',IOSTAT=IER1) + END IF + + IF (.NOT.IER) THEN + CALL SYS_GETMSG(IER) + ELSE + IF (CONFIRM_USER('DECNET').NE.0) THEN + WRITE (6,'('' WARNING: Account with username DECNET'', + & '' does not exist.'')') + WRITE (6,'('' BULLCP will be owned by present account.'')') + END IF + WRITE (6,'('' Successfully created BULLCP detached process.'')') + END IF + CALL EXIT + + END + + + + + + + SUBROUTINE FIND_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + DATA BULLCP /0/ + + IER = SYS_TRNLNM('BULL_BULLCP','DEFINED') + IF (IER) BULLCP = 1 + + RETURN + END + + + + + LOGICAL FUNCTION TEST_BULLCP + + IMPLICIT INTEGER (A-Z) + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + TEST_BULLCP = BULLCP + + RETURN + END + + + + + SUBROUTINE RUN_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + CHARACTER*23 OLD_TIME,NEW_TIME + + IF (TEST_BULLCP()) CALL EXIT ! BULLCP already running, so exit. + + CALL LIB$DATE_TIME(OLD_TIME) + + BULLCP = 2 ! Enable process to do BULLCP functions + + IER = SYS$CREMBX(%VAL(1),CHAN,,,,,'BULL_BULLCP') + IF (.NOT.IER) THEN ! Can't create mailbox, so exit. + CALL SYS_GETMSG(IER) + CALL EXIT + END IF + + IER = SYS$DELMBX(%VAL(CHAN)) ! If process dies, mailbox is deleted. + + CALL REGISTER_BULLCP + + CALL SET_REMOTE_SYSTEM + + CALL START_DECNET + + CALL SYS$SETAST(%VAL(0)) + + UPDATEBBOARD = 1 + IF (SYS_TRNLNM('BULL_BBOARD_UPDATE',BULL_PARAMETER)) THEN + LEN_P = TRIM(BULL_PARAMETER) + DECODE(LEN_P,'(I)',BULL_PARAMETER,IOSTAT=IER) + & UPDATEBBOARD + IF (IER.EQ.0) UPDATEBBOARD = (UPDATEBBOARD+14) / 15 + END IF + + UPDATENEWS = 4 + IF (SYS_TRNLNM('BULL_NEWS_UPDATE',BULL_PARAMETER)) THEN + LEN_P = TRIM(BULL_PARAMETER) + DECODE(LEN_P,'(I)',BULL_PARAMETER,IOSTAT=IER) + & UPDATENEWS + IF (IER.EQ.0) UPDATENEWS = (UPDATENEWS+14) / 15 + END IF + + CALL SYS$SETAST(%VAL(1)) + + BBOARD_LOOP = 0 + NEWS_LOOP = 0 + + DO WHILE (1) ! Loop once every 15 minutes + CALL SYS$SETAST(%VAL(0)) + CALL LIB$DATE_TIME(NEW_TIME) + CALL GET_PROXY_ACCOUNTS ! Proxy info for incoming connections + CALL SYS$SETAST(%VAL(1)) + + IF (BBOARD_LOOP.EQ.0) CALL BBOARD ! Look for BBOARD messages. + + BBOARD_LOOP = BBOARD_LOOP + 1 + IF (BBOARD_LOOP.EQ.UPDATEBBOARD) BBOARD_LOOP = 0 + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).NE.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) ! Select folder + IF (IER) THEN + CALL DELETE_EXPIRED ! Delete expired messages + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Do empty block + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! cleanup at 3 a.m. + IF (NEMPTY.GT.200) THEN + CALL CLEANUP_BULLFILE ! Cleanup empty blocks + END IF + END IF + END IF + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + + CALL SYS$SETAST(%VAL(0)) + IF (SYS_TRNLNM('BULL_NEWS_SERVER','DEFINED').AND. + & NEWS_LOOP.EQ.0) CALL CREATE_PROCESS('BULLCP NEWS') + CALL SYS$SETAST(%VAL(1)) + + NEWS_LOOP = NEWS_LOOP + 1 + IF (NEWS_LOOP.EQ.UPDATENEWS) NEWS_LOOP = 0 + + IF (INDEX(NEW_TIME,' 03:').NE.0.AND. ! Cleanup deleted users from + & INDEX(OLD_TIME,' 03:').EQ.0) THEN ! data files at 3 a.m. + CALL SYS$SETAST(%VAL(0)) + CALL TOTAL_CLEANUP_LOGIN + CALL SYS$SETAST(%VAL(1)) + END IF + + OLD_TIME = NEW_TIME + CALL HIBER('15') ! Wait for 15 minutes +C +C Look at remote folders and update local info to reflect new messages. +C Do here after waiting in case problem with connecting to remote folder +C which requires killing process. +C + + FOLDER_Q = FOLDER_Q1 + POINT_FOLDER = 0 + DO WHILE (POINT_FOLDER.LT.NUM_FOLDERS) + POINT_FOLDER = POINT_FOLDER + 1 + CALL SYS$SETAST(%VAL(0)) + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (FOLDER_BBOARD(:2).EQ.'::') THEN + CALL SELECT_FOLDER(.FALSE.,IER) + END IF + CALL SYS$SETAST(%VAL(1)) + END DO + CALL SYS$SETAST(%VAL(0)) + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + CALL REGISTER_BULLCP + CALL SYS$SETAST(%VAL(1)) + END DO + + RETURN + END + + + + + + SUBROUTINE SET_REMOTE_SYSTEM + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER NODENAME*8 + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + CALL OPEN_BULLFOLDER_SHARED + + IER = 0 + DO WHILE (IER.EQ.0) + CALL READ_FOLDER_FILE(IER) + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER_FLAG,2) + & .AND.IER.EQ.0) THEN + CALL SELECT_FOLDER(.FALSE.,IER1) + IF (IER1) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER1) 14, + & BTEST(FOLDER_FLAG,2),NODENAME + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER + + FOLDER_NUMBER = 0 ! Reset to GENERAL folder + CALL SELECT_FOLDER(.FALSE.,IER) + + RETURN + END + + + + + SUBROUTINE REGISTER_BULLCP + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + SYSTEM_FLAG(I) = 0 + SHUTDOWN_FLAG(I) = 0 + END DO + CALL SET2(SYSTEM_FLAG,0) + NODE_AREA = 0 + END IF + + CALL LIB$SYS_TRNLOG('SYS$NODE',,NODENAME) + NODENAME = NODENAME(2:INDEX(NODENAME,':')-1) + + DO I=1,FLONG + SHUTDOWN_FLAG(I) = SYSTEM_FLAG(I) + END DO + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE UPDATE_SHUTDOWN(FOLDER_NUMBER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INTEGER SHUTDOWN_BTIM(FLONG) + + EQUIVALENCE (SHUTDOWN_BTIM,BRIEF_FLAG) + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),NODENAME + CHARACTER NODENAME*8 + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL OPEN_BULLUSER + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*SYSTEM',IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END DO + + CALL CLR2(SHUTDOWN_FLAG,FOLDER_NUMBER) + + SEEN_FLAG = 0 + DO I=1,FLONG + IF (SHUTDOWN_FLAG(I).NE.0) SEEN_FLAG = 1 + END DO + IF (SEEN_FLAG.EQ.0) NODE_AREA = 0 ! All done with that node + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) + & '*SYSTEM ',NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + ELSE + REWRITE (4,IOSTAT=IER) + & TEMP_USER,NODENAME,NODE_NUMBER,NODE_AREA,NEW_FLAG, + & SYSTEM_FLAG,SHUTDOWN_BTIM,SHUTDOWN_FLAG + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE HIBER(MIN) +C +C SUBROUTINE HIBER +C +C FUNCTION: Waits for specified time period in minutes. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,MIN*2 + DATA TIMBUF/'0 00:00:00.00'/ + + TIMBUF(6:7) = MIN + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SCHDWK(,,TIMADR,) ! Set timer. + IER=SYS$HIBER() + + RETURN + END + + + + SUBROUTINE WAIT_SEC(PARAM) +C +C SUBROUTINE WAIT_SEC +C +C FUNCTION: Waits for specified time period in seconds. +C + IMPLICIT INTEGER (A-Z) + INTEGER TIMADR(2) ! Buffer containing time + ! in desired system format. + CHARACTER TIMBUF*13,PARAM*2 + DATA TIMBUF/'0 00:00:00.00'/ + DATA WAIT_EF /0/ + + IF (WAIT_EF.EQ.0) CALL LIB$GET_EF(WAIT_EF) + + TIMBUF(9:10) = PARAM + + IER=SYS$BINTIM(TIMBUF,TIMADR) + IER=SYS$SETIMR(%VAL(WAIT_EF),TIMADR,,%VAL(3)) ! Set timer. + IER=SYS$WAITFR(%VAL(WAIT_EF)) ! Wait for EFN to be set. + + RETURN + END + + + + + SUBROUTINE DELETE_EXPIRED + +C +C SUBROUTINE DELETE_EXPIRED +C +C FUNCTION: +C +C Delete any expired bulletins (normal or shutdown ones). +C (NOTE: If bulletin files don't exist, they get created now by +C OPEN_FILE_SHARED. Also, if new format has been defined for files, +C they get converted now. The directory file has had it's record size +C lengthened in the past to include more info, and the bulletin file +C was lengthened from 80 to 81 characters to include byte which indicated +C start of bulletin message. However, that scheme was removed and +C was replaced with a 128 byte record compressed format). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CHARACTER UPTIME_DATE*11,UPTIME_TIME*11 + + CALL OPEN_BULLDIR_SHARED ! Open directory file + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + CALL CLOSE_BULLFIL + CALL READDIR(0,IER) ! Get directory header + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired bulls? + IF (IER.GT.20*356) IER = -1 ! Check if latest expiration date valid. + IF (IER.EQ.0) IER = COMPARE_TIME(NEWEST_EXTIME,' ') + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)).AND. + & TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown messages exist and need to be checked? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER1.LE.0) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Reopen without sharing + CALL UPDATE ! Need to update + END IF + ELSE ! If header not there, then first time running BULLETIN + CALL OPEN_BULLUSER ! Create user file to be able to set + CALL CLOSE_BULLUSER ! defaults, privileges, etc. + END IF + CALL CLOSE_BULLDIR + + RETURN + END + + + + + SUBROUTINE BBOARD +C +C SUBROUTINE BBOARD +C +C FUNCTION: Converts mail to BBOARD into non-system bulletins. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($RMSDEF)' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + CHARACTER*11 INEXDATE + CHARACTER INDESCRIP*(LINE_LENGTH),INFROM*(LINE_LENGTH),INTO*76 + CHARACTER ACCOUNT_SAVE*8,USERNAME_SAVE*12 + CHARACTER F_BBOARD*64,BBOARD_NAME*64 + + DIMENSION NEW_MAIL(FOLDER_MAX) + + DATA SPAWN_EF/0/,HEADER_Q1/0/ + + CALL SYS$SETAST(%VAL(0)) + + IF (SPAWN_EF.EQ.0) CALL LIB$GET_EF(SPAWN_EF) + + CALL DISABLE_CTRL + + CALL INIT_QUEUE(HEADER_Q1,INPUT) + + CALL INIT_QUEUE(FOLDER_Q1,FOLDER_COM) + + FOLDER_Q = FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + CALL READ_FOLDER_FILE(IER) + IF (IER.EQ.0) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + CALL SYS$SETAST(%VAL(1)) + + CALL SYS$SETAST(%VAL(0)) + CALL CHECK_MAIL(NEW_MAIL) + CALL SYS$SETAST(%VAL(1)) + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + + NBBOARD_FOLDERS = 0 + + POINT_FOLDER = 0 + +1 POINT_FOLDER = POINT_FOLDER + 1 + IF (POINT_FOLDER.GT.NUM_FOLDERS) GO TO 900 + + CALL SYS$SETAST(%VAL(0)) + + FOLDER_Q_SAVE = FOLDER_Q + + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (FOLDER_BBOARD.EQ.'NONE'.OR. + & FOLDER_BBOARD(:2).EQ.'::') GO TO 1 + + NBBOARD_FOLDERS = NBBOARD_FOLDERS + 1 + + IF (.NOT.NEW_MAIL(POINT_FOLDER)) GO TO 1 +C +C The process is set to the BBOARD uic and username in order to create +C a spawned process that is able to read the BBOARD mail (a real kludge). +C + + CALL GETUSER(USERNAME_SAVE) ! Get present username + CALL GETACC(ACCOUNT_SAVE) ! Get present account + CALL GETUIC(GROUP_SAVE,USER_SAVE) ! Get present uic + + IF (TRIM(FOLDER_BBOARD).GT.0) THEN ! BBOARD name present? + IER = SETUSER(FOLDER_BBOARD,USERNAME_SAVE)! Set to BBOARD username + IF (IER.EQ.2) GO TO 910 ! Can't set username. New VMS version? + CALL SETACC(ACCOUNTB) ! Set to BBOARD account + CALL SETUIC(IBCLR(GROUPB,31),IBCLR(USERB,31)) ! Set to BBOARD uic + END IF + + LEN_B = TRIM(BBOARD_DIRECTORY) + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.TXT;*') + ! Delete old TXT files left due to errors + + IF (.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)) THEN + ! If normal BBOARD user + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + IF (((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'READ_BOARD.COM', + & STATUS='NEW',ERR=910,CARRIAGECONTROL='LIST') + WRITE(11,'(A)') '$ SET PROTECT=(W:RWED)/DEFAULT' + WRITE(11,'(A)') '$ SET PROC/PRIV=SYSPRV' + WRITE(11,'(A)') + & '$ DEFINE/USER EXTRACT_FILE '//BBOARD_DIRECTORY(:LEN_B)// + & '''F$GETJPI("","USERNAME")''' + WRITE(11,'(A)') '$ MAIL' + WRITE(11,'(A)') 'SELECT MAIL' + WRITE(11,'(A)') 'READ' + WRITE(11,'(A)') 'EXTRACT/ALL/APPEND EXTRACT_FILE' + WRITE(11,'(A)') 'DELETE/ALL' + WRITE(11,'(A)') 'READ/NEW' + WRITE(11,'(A)') 'EXTRACT/ALL/APPEND EXTRACT_FILE' + WRITE(11,'(A)') 'DELETE/ALL' + WRITE(11,'(A)') 'SELECT/NEW' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B) + & //'READ_BOARD.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + ELSE + CONTEXT = 0 + IER = LIB$FIND_FILE(BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.COM',INPUT,CONTEXT) + IF (IER) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & FOLDER_BBOARD(:TRIM(FOLDER_BBOARD))//'.COM','NL:', + & 'NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + IF (.NOT.IER.OR.((STATUS.AND.'1FFFF'X).EQ.RMS$_FNF) .OR. + & ((STATUS .AND. '1FFF0'X).EQ. (RMS$_SPL .AND. '1FFF0'X))) THEN + IER = LIB$SPAWN('$@'//BBOARD_DIRECTORY(:LEN_B)// + & 'BOARD_SPECIAL.COM','NL:','NL:',1,,,STATUS,SPAWN_EF) + CALL SYS$SETAST(%VAL(1)) + IF (IER) CALL SYS$WAITFR(%VAL(SPAWN_EF)) + CALL SYS$SETAST(%VAL(0)) + END IF + END IF + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),FOLDER_Q,FOLDER_COM) + + NBULL = F_NBULL + + CALL SETACC(ACCOUNT_SAVE) ! Reset to original account + CALL SETUSER(USERNAME_SAVE) ! Reset to original username + CALL SETUIC(GROUP_SAVE,USER_SAVE) ! Reset to original uic + + OPEN (UNIT=14,FILE=BBOARD_DIRECTORY(:LEN_B)//FOLDER_BBOARD + & (:TRIM(FOLDER_BBOARD))//'.TXT',STATUS='OLD',ERR=100) + READ (14,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read first line + CALL SYS$SETAST(%VAL(1)) + +5 CALL SYS$SETAST(%VAL(0)) + + CALL READ_QUEUE(%VAL(FOLDER_Q_SAVE),IDUMMY,FOLDER_COM) + + DO WHILE (LEN_INPUT.GT.0) + IF (INPUT(:5).EQ.'From:') THEN + INFROM = INPUT(7:) ! Store username + ELSE IF (INPUT(:5).EQ.'Subj:') THEN + INDESCRIP = INPUT(7:) ! Store subject + ELSE IF (INPUT(:3).EQ.'To:') THEN + INTO = INPUT(5:) ! Store address + END IF + READ (14,'(Q,A)',END=100) LEN_INPUT,INPUT ! Read next line from mail + END DO + + INTO = INTO(:TRIM(INTO)) + CALL STR$TRIM(INTO,INTO) + CALL STR$UPCASE(INTO,INTO) + FLEN = TRIM(FOLDER1_BBOARD) + HEADER_Q = 0 + IF (.NOT.DETECT_BBOARD(INTO,FOLDER1_BBOARD(:FLEN))) THEN + HEADER_Q = HEADER_Q1 + IER = 0 + NHEAD = 0 + CALL STRIP_HEADER(' ',0,STRIP) + STRIP = .TRUE. + DO WHILE (IER.EQ.0.AND.STRIP) + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (IER.EQ.0) THEN + CALL STRIP_HEADER(INPUT,LEN_INPUT,STRIP) + CALL WRITE_QUEUE(%VAL(HEADER_Q),HEADER_Q,INPUT) + NHEAD = NHEAD + 1 + END IF + END DO + + FOUND = .FALSE. + J = 0 + DO WHILE (J.LT.2.AND..NOT.FOUND) + J = J + 1 + POINT_FOLDER1 = 0 + FOLDER_Q2 = FOLDER_Q1 + FOUND = .FALSE. + DO WHILE (.NOT.FOUND.AND.POINT_FOLDER1.LT.NUM_FOLDERS) + FOLDER_Q2_SAVE = FOLDER_Q2 + CALL READ_QUEUE(%VAL(FOLDER_Q2),FOLDER_Q2,FOLDER1_COM) + POINT_FOLDER1 = POINT_FOLDER1 + 1 + IF (POINT_FOLDER1.LE.NUM_FOLDERS.AND. + & FOLDER1_BBOARD(:2).NE.'::'.AND. + & FOLDER1_BBOARD.NE.'NONE') THEN + IF (J.EQ.1) THEN + F_BBOARD = FOLDER1_BBOARD + ELSE + F_BBOARD = BBOARD_NAME(FOLDER1_BBOARD,FOLDER1_DESCRIP) + END IF + IF (J.EQ.1.OR.F_BBOARD.NE.FOLDER1_BBOARD) THEN + FLEN = TRIM(F_BBOARD) + FOUND = DETECT_BBOARD(INTO,F_BBOARD(:FLEN)) + IF (.NOT.FOUND.AND.NHEAD.GT.1) THEN + HEADER_Q = HEADER_Q1 + I = 1 + DO WHILE (I.LT.NHEAD.AND..NOT.FOUND) + CALL READ_QUEUE(%VAL(HEADER_Q),HEADER_Q,INPUT) + FOUND = DETECT_BBOARD(INPUT,F_BBOARD(:FLEN)) + I = I + 1 + END DO + END IF + END IF + END IF + END DO + END DO + IF (FOUND) THEN + FOLDER_COM = FOLDER1_COM + FOLDER_Q_SAVE = FOLDER_Q2_SAVE + END IF + END IF + + IF (NHEAD.EQ.0) THEN + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT ! Read first line + ELSE + HEADER_Q = HEADER_Q1 + CALL READ_QUEUE(%VAL(HEADER_Q),HEADER_Q,INPUT) + LEN_INPUT = TRIM(INPUT) + NHEAD = NHEAD - 1 + END IF + + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12).AND.IER.EQ.0) + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (INPUT(:5).EQ.'From:') GO TO 5 + END DO ! If line is just form feed, the message is empty + IF (IER.NE.0) GO TO 100 ! If end of file, exit + + EFROM = 2 + I = TRIM(INFROM) + DO WHILE (EFROM.GT.0.AND.I.GT.0) ! Strip off the date + IF (INFROM(I:I).EQ.' ') EFROM = EFROM - 1 ! From the "From:" line + I = I - 1 + END DO + IF (I.GT.0) INFROM = INFROM(:I) + + CALL INIT_MESSAGE_ADD_BBOARD(INFROM,INDESCRIP,IER) + + ISTART = 0 + NBLANK = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Move text to bulletin file + IF (LEN_INPUT.EQ.0) THEN + IF (ISTART.EQ.1) THEN + NBLANK = NBLANK + 1 + END IF + ELSE + ISTART = 1 + DO I=1,NBLANK + CALL WRITE_MESSAGE_LINE(' ') + END DO + NBLANK = 0 + CALL WRITE_MESSAGE_LINE(INPUT) + END IF + IF (NHEAD.EQ.0) THEN + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + ELSE + CALL READ_QUEUE(%VAL(HEADER_Q),HEADER_Q,INPUT) + LEN_INPUT = TRIM(INPUT) + NHEAD = NHEAD - 1 + END IF + IF (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12)) THEN + DO WHILE (LEN_INPUT.EQ.1.AND.INPUT(:1).EQ.CHAR(12) + & .AND.IER.EQ.0) + READ (14,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + END DO + IF (IER.EQ.0.AND.INPUT(:5).EQ.'From:') THEN + IER = 1 + ELSE + NBLANK = NBLANK + 1 + END IF + END IF + END DO + + CALL FINISH_MESSAGE_ADD ! Totally finished with add + + CALL SYS$SETAST(%VAL(1)) + + GO TO 5 ! See if there is more mail + +100 CLOSE (UNIT=14,STATUS='DELETE') ! Close the input file + CALL SYS$SETAST(%VAL(1)) + GO TO 1 + +900 CALL SYS$SETAST(%VAL(0)) + + FOLDER_NUMBER = 0 + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNUM(0,IER) + CALL CLOSE_BULLFOLDER + CALL ENABLE_CTRL + FOLDER_SET = .FALSE. + + IF (NBBOARD_FOLDERS.EQ.0) THEN + CALL OPEN_BULLUSER + CALL READ_USER_FILE_HEADER(IER) + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',BBOARD_BTIM) + REWRITE (4) USER_HEADER ! Rewrite header + CALL CLOSE_BULLUSER + END IF + CALL SYS$SETAST(%VAL(1)) + + CALL SYS$SETAST(%VAL(0)) + IF (SYS_TRNLNM('BULL_NEWS_SERVER','DEFINED').AND. + & .NOT.TEST_BULLCP().AND.TEST_BULLCP().NE.2) CALL NEWS2BULL + CALL SYS$SETAST(%VAL(1)) + + RETURN + +910 WRITE (6,1010) + GO TO 100 + +930 CLOSE (UNIT=14) + CALL CLOSE_BULLFIL + CALL CLOSE_BULLDIR + WRITE (6,1030) + GO TO 100 + +1010 FORMAT(' ERROR:Install program with CMKRNL privileges or relink.') +1030 FORMAT(' ERROR:Alert system programmer. Data file problems.') + + END + + + + + LOGICAL FUNCTION DETECT_BBOARD(INPUT,BBOARD) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,BBOARD + + DETECT_BBOARD = .TRUE. + + LEN_BBOARD = LEN(BBOARD) - 1 + + DO I=1,TRIM(INPUT)-LEN_BBOARD + IF (.NOT.STREQ(INPUT(:4),'Subj').AND. + & STREQ(INPUT(I:I+LEN_BBOARD),BBOARD).AND. + & (I.EQ.1.OR..NOT.ALPHA(INPUT(I-1:I-1))).AND. + & (I.EQ.LEN(INPUT)-LEN_BBOARD.OR. + & INDEX(' .@%!',INPUT(I+LEN_BBOARD+1:I+LEN_BBOARD+1)).GT.0)) + & RETURN + END DO + + DETECT_BBOARD = .FALSE. + + RETURN + END + + + + LOGICAL FUNCTION ALPHA(IN) + + CHARACTER*1 IN + + ALPHA = (ICHAR(IN).GE.ICHAR('A').AND.ICHAR(IN).LE.ICHAR('Z')) + & .OR.(ICHAR(IN).GE.ICHAR('a').AND.ICHAR(IN).LE.ICHAR('z')) + + RETURN + END + + + + CHARACTER*(*) FUNCTION BBOARD_NAME(FOLDER_BBOARD,FOLDER_DESCRIP) + + CHARACTER*(*) FOLDER_BBOARD,FOLDER_DESCRIP + + BBOARD_NAME = FOLDER_BBOARD + + I = INDEX(FOLDER_DESCRIP,'<') + IF (I.EQ.0) RETURN + + BBOARD_NAME = FOLDER_DESCRIP(I+1:) + + I = INDEX(BBOARD_NAME,'%"') + IF (I.GT.0) BBOARD_NAME = BBOARD_NAME(I+2:) + + I = INDEX(BBOARD_NAME,'!') + DO WHILE (I.GT.0) + BBOARD_NAME = BBOARD_NAME(I+1:) + I = INDEX(BBOARD_NAME,'!') + END DO + + I = INDEX(BBOARD_NAME,'>') + IF (I.GT.0) BBOARD_NAME = BBOARD_NAME(:I-1) + I = INDEX(BBOARD_NAME,'@') + IF (I.GT.0) BBOARD_NAME = BBOARD_NAME(:I-1) + I = INDEX(BBOARD_NAME,'%') + IF (I.GT.0) BBOARD_NAME = BBOARD_NAME(:I-1) + + RETURN + END + + + + + SUBROUTINE CREATE_PROCESS(COMMAND) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRCDEF)' + + INCLUDE 'BULLFILES.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + CHARACTER*132 IMAGENAME + + CHARACTER*(*) COMMAND + + CALL GETIMAGE(IMAGENAME,ILEN) + + LEN_B = TRIM(BBOARD_DIRECTORY) + + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='OLD',IOSTAT=IER) + IF (IER.EQ.0) CLOSE(UNIT=11,STATUS='DELETE') + + CALL SYS$SETDFPROT('AA00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD:RW,GROUP:RW) + OPEN(UNIT=11,FILE=BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM', + & STATUS='NEW',IOSTAT=IER,CARRIAGECONTROL='LIST') + IF (IER.NE.0) RETURN + WRITE(11,'(A)') '$B:=$'//IMAGENAME(:ILEN) + WRITE(11,'(A)') '$ON ERROR THEN GOTO EXIT' + WRITE(11,'(A)') '$ON SEVERE THEN GOTO EXIT' + WRITE(11,'(A)') '$ON WARNING THEN GOTO EXIT' + WRITE(11,'(A)') '$B/'//'''F$PROCESS()''' + WRITE(11,'(A)') '$EXIT:' + WRITE(11,'(A)') '$LOGOUT' + CLOSE(UNIT=11) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + DEL = .FALSE. + IER = .FALSE. + + DO WHILE (.NOT.IER) + IER = SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT', + & BBOARD_DIRECTORY(:LEN_B)//'BULL_COMMAND.COM','NL:',, + & PROCPRIV,,COMMAND(:TRIM(COMMAND)) + & ,%VAL(4),,,%VAL(PRC$M_NOUAF+PRC$M_DETACH)) + IF (.NOT.IER.AND..NOT.DEL) THEN + CALL DELPRC('BULLCP NEWS',DEL) + IER = .NOT.DEL + ELSE + IER = .TRUE. + END IF + END DO + + RETURN + END + + + + SUBROUTINE GETUIC(GRP,MEM) +C +C SUBROUTINE GETUIC(UIC) +C +C FUNCTION: +C To get UIC of process submitting the job. +C OUTPUT: +C GRP - Group number of UIC +C MEM - Member number of UIC +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(4,JPI$_GRP,%LOC(GRP)) + CALL ADD_2_ITMLST(4,JPI$_MEM,%LOC(MEM)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + SUBROUTINE GET_UPTIME(UPTIME_DATE,UPTIME_TIME) +C +C SUBROUTINE GET_UPTIME +C +C FUNCTION: Gets time of last reboot. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($SYIDEF)' + + INTEGER UPTIME(2) + CHARACTER*(*) UPTIME_TIME,UPTIME_DATE + CHARACTER ASCSINCE*23 + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(8,SYI$_BOOTTIME,%LOC(UPTIME)) + CALL END_ITMLST(GETSYI_ITMLST) + + IER = SYS$GETSYI(,,,%VAL(GETSYI_ITMLST),,,) + + CALL SYS$ASCTIM(,ASCSINCE,UPTIME,) + + UPTIME_DATE = ASCSINCE(:11) + UPTIME_TIME = ASCSINCE(13:) + + RETURN + END + + + + INTEGER FUNCTION GET_L_VAL(I) + INTEGER I + GET_L_VAL = I + RETURN + END + + + + SUBROUTINE CHECK_MAIL(NEW_MAIL) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + COMMON /KNOWN_FOLDERS/ FOLDER_Q1,NUM_FOLDERS + DATA FOLDER_Q1/0/ + + DIMENSION NEW_MAIL(1) + + CHARACTER INPUT*132 + + INTEGER*2 COUNT + + FOLDER_Q = FOLDER_Q1 ! so reinit queue pointer + + OPEN (UNIT=10,FILE='VMSMAIL_PROFILE', + & DEFAULTFILE='SYS$SYSTEM:VMSMAIL_PROFILE.DATA', + & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) + + DO I=1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + IF (((.NOT.BTEST(USERB,31).AND.(USERB.NE.0.OR.GROUPB.NE.0)).OR. + & BTEST(GROUPB,31)).AND.FOLDER_BBOARD(:2).NE.'::'.AND. + & FOLDER_BBOARD.NE.'NONE') THEN ! If normal BBOARD or /VMSMAIL + DO WHILE (REC_LOCK(IER1)) + READ(10,'(A)',KEY=FOLDER_BBOARD,IOSTAT=IER1) INPUT + END DO + COUNT = 0 + IF (IER1.EQ.0) THEN + INPUT = INPUT(32:) + DO WHILE (TRIM(INPUT).GT.0) + IF (ICHAR(INPUT(1:1)).EQ.1) THEN + CALL LIB$MOVC3(2,%REF(INPUT(5:)),COUNT) + INPUT = ' ' + ELSE + INPUT = INPUT(ICHAR(INPUT(3:3))+5:) + END IF + END DO + END IF + IF (IER1.EQ.0.AND.(COUNT.GT.0.OR.IER.NE.0)) THEN + NEW_MAIL(I) = .TRUE. + ELSE + NEW_MAIL(I) = .FALSE. + END IF + ELSE + NEW_MAIL(I) = .TRUE. + END IF + END DO + + CLOSE (10) + + RETURN + END + + + + SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C SUBROUTINE GETIMAGE(IMAGNAME,ILEN) +C +C FUNCTION: +C To get image name of process. +C OUTPUT: +C IMAGNAME - Image name of process +C ILEN - Length of imagename +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CHARACTER*(*) IMAGNAME + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST_WITH_RET(LEN(IMAGNAME),JPI$_IMAGNAME, + & %LOC(IMAGNAME),%LOC(ILEN)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get Info command. + + RETURN + END + + + + + SUBROUTINE GET_NEWEST_MSG(IN_BTIM,START) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + DIMENSION IN_BTIM(2) + + IF (REMOTE_SET) THEN + CALL REMOTE_GET_NEWEST_MSG(IN_BTIM,START) + ELSE + CALL GET_MSGKEY(IN_BTIM,MSG_KEY) + CALL READDIR_KEYGE(START) + IF (START.EQ.0) THEN + START = -1 + END IF + END IF + + RETURN + END + + + + SUBROUTINE NOTIFY_REMOTE_USERS(IN_BTIM) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + DIMENSION IN_BTIM(2) + + CALL GET_MSGKEY(IN_BTIM,MSG_KEY) + CALL READDIR_KEYGE(START) + + IF (START.EQ.0) RETURN + + CALL OPEN_BULLUSER_SHARED + + IER = START + 1 + DO WHILE (START+1.EQ.IER) + IF (.NOT.BTEST(SYSTEM,3)) CALL NOTIFY_USERS(0) + START = START + 1 + CALL READDIR(START,IER) + END DO + + CALL CLOSE_BULLDIR + + RETURN + END + + + + + + SUBROUTINE READ_NOTIFY + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG) + + CALL OPEN_BULLUSER_SHARED + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*NOTIFY',IOSTAT=IER) TEMP_USER,NOTIFY_REMOTE + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + NOTIFY_REMOTE(I) = 0 + END DO + WRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + END IF + + CALL CLOSE_BULLDIR + + RETURN + END + + + + SUBROUTINE DELPRC(DELNAM,IER) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + + CHARACTER*(*) DELNAM + + CHARACTER PRCNAM*15 + + WILDCARD = -1 + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(PRCNAM),JPI$_PRCNAM,%LOC(PRCNAM)) + CALL ADD_2_ITMLST(4,JPI$_PID,%LOC(PID)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + IER = 1 + DO WHILE (IER.AND.PRCNAM(:LEN(DELNAM)).NE.DELNAM) + ! Get next interactive process + IER = SYS$GETJPIW(,WILDCARD,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + IF (IER.AND.PID.NE.0) IER = SYS$DELPRC(PID,) + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin4.for b/decus/vax91b/gce91b/net91b/bulletin4.for new file mode 100644 index 0000000..4cc2794 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin4.for @@ -0,0 +1,1807 @@ +C +C BULLETIN4.FOR, Version 5/4/91 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C +C +C SUBROUTINE ITMLST_SUBS +C +C FUNCTION: +C A set of routines to easily create item lists. It allows one +C to easily create item lists without the need for declaring arrays +C or itemlist size. Thus, the code can be easily changed to add or +C delete item list codes. +C +C Here is an example of how to use the routines (prints file to a queue): +C +C CALL INIT_ITMLST ! Initialize item list +C ! Now add items to list +C CALL ADD_2_ITMLST(LEN,SJC$_FILE_SPECIFICATION,%LOC(FILENAME)) +C CALL ADD_2_ITMLST(9,SJC$_QUEUE,%LOC(QUEUE)) +C CALL END_ITMLST(SNDJBC_ITMLST) ! Get address of itemlist +C IER = SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SNDJBC_ITMLST),IOSB,,) +C + SUBROUTINE ITMLST_SUBS + + IMPLICIT INTEGER (A-Z) + + DATA SAVE_ITMLST_ADDRESS/0/,NUM_ITEMS/0/,QUEUE_HEADER/0/ + + ENTRY INIT_ITMLST + + IF (QUEUE_HEADER.EQ.0) THEN ! First time INIT_ITMLST ever called? + CALL LIB$GET_VM(8,QUEUE_HEADER) ! Yes, create queue header pointer + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER)) ! Zero out header + CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER+4)) ! Zero out header + ELSE IF (SAVE_ITMLST_ADDRESS.GT.0) THEN ! Clean out old item list + CALL LIB$FREE_VM((NUM_ITEMS+1)*12,SAVE_ITMLST_ADDRESS) + NUM_ITEMS = 0 ! Release old itemlist memory + SAVE_ITMLST_ADDRESS = 0 + ELSE ! ITMLST calls cannot be nested. + WRITE (6,'('' ERROR: INIT_ITMLST called before previous'',$)') + WRITE (6,'(''+ ITMLST terminated with END_ITMLST.'')') + CALL EXIT + END IF + + RETURN + + + ENTRY ADD_2_ITMLST(BUFLEN,CODE,BUFADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR,0) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY ADD_2_ITMLST_WITH_RET(BUFLEN,CODE,BUFADR,RETADR) +C +C ITMLST entries are initially stored in a queue. Each queue entry +C needs 8 bytes for pointer + 12 bytes for itemlist info. +C + CALL LIB$GET_VM(20,INPUT_ITMLST) ! Get memory for entry + + CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR, + & RETADR) + ! Store data in itemlist format + CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER)) + ! Insert entry into queue + NUM_ITEMS = NUM_ITEMS + 1 ! Increment item count + + RETURN + + + ENTRY END_ITMLST(ITMLST_ADDRESS) + + CALL LIB$GET_VM((NUM_ITEMS+1)*12,ITMLST_ADDRESS) + ! Get memory for itemlist + SAVE_ITMLST_ADDRESS = ITMLST_ADDRESS ! Save address to remove memory + + DO I=1,NUM_ITEMS ! Place entries into itemlist + CALL LIB$REMQHI(%VAL(QUEUE_HEADER),INPUT_ITMLST) + CALL LIB$MOVC3(12,%VAL(INPUT_ITMLST+8), + & %VAL(ITMLST_ADDRESS+(I-1)*12)) + CALL LIB$FREE_VM(20,INPUT_ITMLST) + END DO + + CALL LIB$MOVC3(4,0,%VAL(ITMLST_ADDRESS+NUM_ITEMS*12)) + ! Place terminating 0 at end of itemlist + + RETURN + END + + + + SUBROUTINE STORE_ITMLST_ENTRY(INPUT_ITMLST,BUFLEN,CODE,BUFADR, + & RETADR) + + IMPLICIT INTEGER (A-Z) + + STRUCTURE /ITMLST/ + UNION + MAP + INTEGER*2 BUFLEN,CODE + INTEGER BUFADR,RETADR + END MAP + END UNION + END STRUCTURE + + RECORD /ITMLST/ INPUT_ITMLST(1) + + INPUT_ITMLST(1).BUFLEN = BUFLEN + INPUT_ITMLST(1).CODE = CODE + INPUT_ITMLST(1).BUFADR = BUFADR + INPUT_ITMLST(1).RETADR = RETADR + + RETURN + END + + + SUBROUTINE CLEANUP_LOGIN +C +C SUBROUTINE CLEANUP_LOGIN +C +C FUNCTION: Removes entry in user file of user that no longer exist. +C It creates empty space for new user. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 LOGIN_USER + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2) + + MARK = SYS_TRNLNM_SYSTEM('BULL_MARK','DEFINED') + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + CALL OPEN_SYSUAF_SHARED + + LOGIN_USER = USERNAME + READ (4,IOSTAT=IER1,KEYGT=USERNAME) USER_ENTRY ! Look forward one + TEMP_USER = USERNAME + USERNAME = LOGIN_USER + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=TEMP_USER,IOSTAT=IER) TEMP_USER ! See if user exists + END DO + + IF (IER.NE.0.AND.IER1.EQ.0.AND.TEMP_USER.NE.USER_HEADER_KEY) THEN + ! If no UAF entry and last login was + ! more than 6 months old, delete entry + IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN + DELETE(UNIT=4) ! Delete non-existant user + CALL OPEN_BULLINF + READ (9,KEY=TEMP_USER,IOSTAT=IER) + IF (IER.EQ.0) DELETE(UNIT=9) + LU = TRIM(TEMP_USER) + IF (MARK) CALL LIB$DELETE_FILE('BULL_MARK:'// + & TEMP_USER(:LU)//'.*MARK;*') + TEMP_USER(LU:LU) = CHAR(ICHAR(TEMP_USER(LU:LU)).OR.128) + READ (9,KEY=TEMP_USER,IOSTAT=IER) + IF (IER.EQ.0) DELETE(UNIT=9) + IF (LU.GT.1) THEN + TEMP_USER(LU-1:LU-1) = + & CHAR(128.OR.ICHAR(TEMP_USER(LU-1:LU-1))) + ELSE + TEMP_USER(2:2) = CHAR(128.OR.ICHAR(TEMP_USER(2:2))) + END IF + READ (9,KEY=TEMP_USER,IOSTAT=IER) + IF (IER.EQ.0) DELETE(UNIT=9) + CALL CLOSE_BULLINF + END IF + END IF + + CALL CLOSE_SYSUAF ! All done... + + RETURN + END + + + SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C SUBROUTINE TOTAL_CLEANUP_LOGIN +C +C FUNCTION: Removes all entries in user file of usesr that no longer exist +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG) + + CHARACTER TODAY*23 + + DIMENSION TODAY_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + CALL SYS_BINTIM(TODAY,TODAY_BTIM) + + MARK = SYS_TRNLNM_SYSTEM('BULL_MARK','DEFINED') + + CALL OPEN_SYSUAF_SHARED + CALL OPEN_BULLUSER + CALL OPEN_BULLINF + + TEMP_USER = USERNAME + + IER = 0 + + DO WHILE (IER.EQ.0) ! Clean out BULLUSER.DAT + READ (4,IOSTAT=IER) USER_ENTRY + IF (IER.EQ.0.AND.USERNAME(:1).NE.'*'.AND. + & USERNAME(:1).NE.':'.AND. + & USERNAME.NE.USER_HEADER_KEY) THEN ! See if user exists + DO WHILE (REC_LOCK(IER)) + READ (8,KEY=USERNAME,IOSTAT=IER) + END DO + IF (IER.NE.0) THEN ! If no UAF entry and last login was + ! more than 6 months old, delete entry + IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN + DELETE (UNIT=4) + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=9) + LU = TRIM(USERNAME) + IF (MARK) CALL LIB$DELETE_FILE('BULL_MARK:'// + & USERNAME(:LU)//'.*MARK;*') + USERNAME(LU:LU) = CHAR(ICHAR(USERNAME(LU:LU)).OR.128) + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=9) + IF (LU.GT.1) THEN + USERNAME(LU-1:LU-1) = + & CHAR(128.OR.ICHAR(USERNAME(LU-1:LU-1))) + ELSE + USERNAME(2:2) = CHAR(128.OR.ICHAR(USERNAME(2:2))) + END IF + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) DELETE (UNIT=9) + END IF + IER = 0 + ELSE + DO I=0,FOLDER_MAX-1 + IF (TEST2(NOTIFY_FLAG,I)) THEN + CALL SET2(NOTIFY_REMOTE,I) + END IF + END DO + END IF + END IF + END DO + + CALL CLOSE_SYSUAF ! All done... + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*NOTIFY',IOSTAT=IER) TEMP_USER + END DO + + IF (IER.NE.0) THEN + WRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + ELSE + REWRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + END IF + + READ (9,KEYGT=' ',IOSTAT=IER) USERNAME + + DO WHILE (IER.EQ.0) ! Clean out BULLINF.DAT + LU = TRIM(USERNAME) + USERNAME(LU:LU) = CHAR(ICHAR(USERNAME(LU:LU)).AND.127) + IF (LU.GT.1) THEN + USERNAME(LU-1:LU-1) = + & CHAR(127.AND.ICHAR(USERNAME(LU-1:LU-1))) + ELSE + USERNAME(2:2) = CHAR(127.AND.ICHAR(USERNAME(2:2))) + END IF + READ (4,KEYEQ=USERNAME,IOSTAT=IER) + IF (IER.NE.0) DELETE (UNIT=9) + READ (9,IOSTAT=IER) USERNAME + END DO + + CALL CLOSE_BULLINF + CALL CLOSE_BULLUSER + + USERNAME = TEMP_USER + + RETURN + END + + + SUBROUTINE COPY_BULL(INLUN,IBLOCK,OBLOCK,IER) +C +C SUBROUTINE COPY_BULL +C +C FUNCTION: To copy data to the bulletin file. +C +C INPUT: +C INLUN - Input logical unit number +C IBLOCK - Input block number in input file to start at +C OBLOCK - Output block number in output file to start at +C +C OUTPUT: +C IER - If error in writing to bulletin, IER will be <> 0. +C +C NOTES: Input file is accessed using sequential access. This is +C to allow files which have variable records to be read. The +C bulletin file is assumed to be opened on logical unit 1. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /LAST_RECORD_WRITTEN/ OCOUNT + + INCLUDE 'BULLDIR.INC' + + IF (REMOTE_SET) THEN + CALL REMOTE_COPY_BULL(IER) + IF (IER.NE.0) CALL ERROR_AND_EXIT + END IF + + DO I=1,IBLOCK-1 + READ(INLUN,'(A)') + END DO + + OCOUNT = OBLOCK + ICOUNT = IBLOCK + + NBLANK = 0 + LENGTH = 0 + DO WHILE (1) + ILEN = 0 + DO WHILE (ILEN.EQ.0) + READ(INLUN,'(Q,A)',END=100) ILEN,INPUT + ILEN = MIN(ILEN,TRIM(INPUT),LINE_LENGTH) + IF (ILEN.GT.1.AND.ICHAR(INPUT(ILEN:ILEN)).EQ.10) THEN + INPUT(ILEN-1:ILEN-1) = CHAR(32) ! Remove imbedded + INPUT(ILEN:ILEN) = CHAR(32) ! CR/LFs at end of file. + ILEN = ILEN - 2 + END IF + IF (ILEN.GT.0) THEN + IF (ICOUNT.EQ.IBLOCK) THEN + IF (INPUT(:6).EQ.'From: ') THEN + INPUT(:4) = 'FROM' + END IF + END IF + ICOUNT = ICOUNT + 1 + ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.IBLOCK) THEN + NBLANK = NBLANK + 1 + END IF + END DO + IF (NBLANK.GT.0) THEN + DO I=1,NBLANK + CALL STORE_BULL(1,' ',OCOUNT) + END DO + LENGTH = LENGTH + NBLANK*2 + NBLANK = 0 + END IF + CALL STORE_BULL(ILEN,INPUT,OCOUNT) + LENGTH = LENGTH + ILEN + 1 + END DO + +100 LENGTH = (LENGTH+127)/128 + IF (LENGTH.EQ.0) THEN + IER = 1 + ELSE + IER = 0 + END IF + + CALL FLUSH_BULL(OCOUNT) + + RETURN + END + + + + SUBROUTINE STORE_BULL(ILEN,INPUT,OCOUNT) + + IMPLICIT INTEGER (A-Z) + + PARAMETER BRECLEN=128 + + CHARACTER INPUT*(*),OUTPUT*256 + + DATA POINT/0/ + + IF (ILEN+POINT+1.GT.BRECLEN) THEN + IF (POINT.EQ.BRECLEN) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)) + OUTPUT = CHAR(ILEN)//INPUT + POINT = ILEN + 1 + ELSE IF (POINT.EQ.BRECLEN-1) THEN + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN)) + OUTPUT = INPUT + POINT = ILEN + ELSE + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN) + & //INPUT(:BRECLEN-1-POINT)) + OUTPUT = INPUT(BRECLEN-POINT:) + POINT = ILEN - (BRECLEN-1-POINT) + END IF + OCOUNT = OCOUNT + 1 + DO WHILE (POINT.GE.BRECLEN) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + OCOUNT = OCOUNT + 1 + OUTPUT = OUTPUT(BRECLEN+1:) + POINT = POINT - BRECLEN + END DO + ELSE + OUTPUT(POINT+1:) = CHAR(ILEN)//INPUT(:ILEN) + POINT = POINT + ILEN + 1 + END IF + + RETURN + + ENTRY FLUSH_BULL(OCOUNT) + + IF (POINT.LT.BRECLEN) OUTPUT(POINT+1:POINT+1) = CHAR(0) + CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN)) + POINT = 0 + + RETURN + + END + + + SUBROUTINE WRITE_BULL_FILE(OCOUNT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*(*) OUTPUT + + IF (REMOTE_SET) THEN + CALL REMOTE_WRITE_BULL_FILE(OUTPUT) + ELSE + WRITE (1'OCOUNT) OUTPUT + END IF + + RETURN + END + + + SUBROUTINE GET_BULL_LINE(SBLOCK,BLENGTH,BUFFER,ILEN) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) BUFFER + + COMMON /HEADER/ HEADER + LOGICAL HEADER /.TRUE./ + + COMMON /DATE/ DATE_LINE + CHARACTER*(LINE_LENGTH) DATE_LINE + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + CALL STRIP_HEADER(BUFFER,0,IER) + STRIP = .NOT.HEADER + IBLOCK = SBLOCK ! Initialize pointers. + BULL_HEADER = .TRUE. + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 + MSG_SENT = .FALSE. + ELSE ! Else set ILEN to zero + ILEN = 0 ! to request next line + END IF + + IF (MSG_SENT) THEN + BUFFER = ' ' + ILEN = 1 + MSG_SENT = .FALSE. + RETURN + END IF + + DO WHILE (1) + DO WHILE (ILEN.EQ.0) ! Read until line created + CALL GET_BULL(IBLOCK,BUFFER,ILEN) + IF (ILEN.LE.0) IBLOCK = IBLOCK + 1 ! Need to read new record. + IF (IBLOCK.GE.SBLOCK+BLENGTH) RETURN ! No more records. + END DO + + IF (STRIP) THEN + IF (BULL_HEADER) THEN + IF (BUFFER(:5).EQ.'From:'.OR.BUFFER(:5).EQ.'Subj:') THEN + RETURN + ELSE IF (BUFFER(:13).EQ.'Message sent:') THEN + MSG_SENT = .TRUE. + RETURN + ELSE + BULL_HEADER = .FALSE. + END IF + END IF + IF (DATE_LINE.NE.' ') DATE_LINE = ' ' + CALL STRIP_HEADER(BUFFER,ILEN,STRIP) + IF (DATE_LINE.NE.' ') THEN + BUFFER = DATE_LINE + ILEN = TRIM(DATE_LINE) + MSG_SENT = .TRUE. + RETURN + END IF + IF (STRIP.OR.(.NOT.STRIP.AND.TRIM(BUFFER).EQ.0)) ILEN = 0 + ELSE + RETURN + END IF + END DO + + RETURN + + ENTRY TEST_MORE_RECORDS(SBLOCK,BLENGTH,IREC) + + IREC = (SBLOCK+BLENGTH-1) - IBLOCK + + RETURN + END + + + SUBROUTINE GET_BULL(IBLOCK,BUFFER,ILEN) +C +C SUBROUTINE GET_BULL +C +C FUNCTION: Outputs line from folder file. +C +C INPUT: +C IBLOCK - Input block number in input file to read from. +C +C OUTPUT: +C BUFFER - Character string containing output line. +C ILEN - Length of character string. If 0, signifies that +C new record needs to be read, -1 signifies error. +C +C NOTE: Since message file is stored as a fixed length (128) record file, +C but message lines are variable, message lines may span one or +C more record. This routine takes a record and outputs as many +C lines as it can from the record. When no more lines can be +C outputted, it returns ILEN=0 requesting the calling program to +C increment the record counter. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1 + DATA SCRATCH_R1 /0/ + + PARAMETER BRECLEN=128 + + CHARACTER BUFFER*(*),TEMP*(BRECLEN), LEFT*(LINE_LENGTH) + + DATA POINT /1/, LEFT_LEN /0/ + + IF (ILEN.GT.LINE_LENGTH) THEN ! First read? + POINT = 1 ! Initialize pointers. + LEFT_LEN = 0 + END IF + + IF (POINT.EQ.1) THEN ! Need to read new line? + IF (INCMD(:4).EQ.'MOVE'.OR.INCMD(:4).EQ.'COPY') THEN + DO WHILE (REC_LOCK(IER)) ! Read from file + READ (11'IBLOCK,IOSTAT=IER) TEMP + END DO + ELSE IF (REMOTE_SET) THEN ! Remote folder? + IF (IBLOCK.EQ.BLOCK) SCRATCH_R = SCRATCH_R1 ! Read lines + CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,TEMP) ! from queue + ELSE ! Local folder + DO WHILE (REC_LOCK(IER)) ! Read from file + READ (1'IBLOCK,IOSTAT=IER) TEMP + END DO + END IF + ELSE IF (POINT.EQ.BRECLEN+1) THEN ! Read all of line + ILEN = 0 ! so indicate need to read + POINT = 1 ! new line to calling routine. + RETURN + END IF + + IF (IER.GT.0) THEN ! Error in reading file. + ILEN = -1 ! ILEN = -1 signifies error + POINT = 1 + LEFT_LEN = 0 + RETURN + END IF + + IF (LEFT_LEN.GT.0) THEN ! Part of line is left from + ILEN = ICHAR(LEFT(:1)) ! previous record read. + IF (LEFT_LEN.LE.BRECLEN) THEN ! Rest of it is in next record. + BUFFER = LEFT(2:ILEN-LEFT_LEN+1)//TEMP(:LEFT_LEN) ! Output line. + POINT = LEFT_LEN + 1 ! Update pointers. + LEFT_LEN = 0 + ELSE ! Rest of line is longer than + LEFT(ILEN-LEFT_LEN+2:) = TEMP ! a record, so store record + LEFT_LEN = LEFT_LEN - BRECLEN ! and request another read. + ILEN = 0 ! Request new record read. + END IF + ELSE ! Else nothing left over. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Get line length + IF (ILEN.GT.BRECLEN-POINT) THEN ! If it extends to next record + LEFT = TEMP(POINT:) ! Store it in leftover buffer + LEFT_LEN = ILEN - (BRECLEN-POINT) ! Store leftover length + ILEN = 0 ! Request new record read + POINT = 1 ! Update record pointer. + ELSE IF (ILEN.EQ.0) THEN ! Empty line signifies + POINT = 1 ! end of message. + ELSE ! Else message line fully read + BUFFER = TEMP(POINT+1:POINT+ILEN) ! So output it + POINT = POINT+ILEN+1 ! and update pointer. + END IF + END IF + + RETURN + + ENTRY TEST_MORE_LINES(ILEN) ! Test for more lines in record. + ! Returns length of next line. + IF (POINT.EQ.BRECLEN+1) THEN ! If pointer greater than + ILEN = 0 ! record, no more lines. + ELSE ! Else there is another line. + ILEN = ICHAR(TEMP(POINT:POINT)) ! Output it's length. + END IF + + RETURN + + END + + + + + + + + SUBROUTINE DELETE_ENTRY(BULL_ENTRY) +C +C SUBROUTINE DELETE_ENTRY +C +C FUNCTION: +C To delete a directory entry. +C +C INPUTS: +C BULL_ENTRY - Bulletin entry number to delete +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (NBULL.GT.0) THEN + CALL READDIR(0,IER) + NBULL = -NBULL + CALL WRITEDIR(0,IER) + END IF + + IF (BTEST(FOLDER_FLAG,1)) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',IOSTAT=IER,STATUS='OLD', + & RECL=LINE_LENGTH,CARRIAGECONTROL='LIST',ACCESS='APPEND') + IF (IER.NE.0) THEN + OPEN(UNIT=3,FILE=FOLDER_FILE//'.LOG',ERR=900, + & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') + ELSE + WRITE (3,'(A)') CHAR(12) + END IF + + CALL OPEN_BULLFIL + + ILEN = LINE_LENGTH + 1 + + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN + WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + ELSE + WRITE(3,1060) FROM,DATE//' '//TIME(:8) + END IF + IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN + WRITE(3,1050) INPUT(7:ILEN) + ELSE + WRITE(3,1050) DESCRIP + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END IF + + DO WHILE (ILEN.GT.0) + CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) + IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) + END DO + + CLOSE (UNIT=3) ! Bulletin copy completed + + CALL CLOSE_BULLFIL + END IF + +900 CALL READDIR(BULL_ENTRY,IER) + DELETE(UNIT=2) + + NEMPTY = NEMPTY + LENGTH + CALL WRITEDIR(0,IER) + +1050 FORMAT('Description: ',A,/) +1060 FORMAT(/,'From: ',A,' Date: ',A11) + + RETURN + END + + + + + SUBROUTINE GET_EXDATE(EXDATE,NDAYS) +C +C SUBROUTINE GET_EXDATE +C +C FUNCTION: Computes expiration date giving number of days to expire. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*11 EXDATE + + CHARACTER*3 MONTHS(12) + DIMENSION LENGTH(12) + DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP', + & 'OCT','NOV','DEC'/ + DATA LENGTH/31,27,31,30,31,30,31,31,30,31,30,31/ + + CALL SYS$ASCTIM(,EXDATE,,) ! Get the present date + + DECODE(2,'(I2)',EXDATE(:2)) DAY ! Get day + DECODE(4,'(I4)',EXDATE(8:11)) YEAR ! Get year + + MONTH = 1 + DO WHILE (MONTHS(MONTH).NE.EXDATE(4:6)) ! Get month + MONTH = MONTH + 1 + END DO + + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + + NUM_DAYS = NDAYS ! Put number of days into buffer variable + + DO WHILE (NUM_DAYS.GT.0) + IF (NUM_DAYS+DAY.GT.LENGTH(MONTH)) THEN + ! If expiration date exceeds end of month + NUM_DAYS = NUM_DAYS - (LENGTH(MONTH) - DAY + 1) + ! Decrement # of days by days left in month + DAY = 1 ! Reset day to first of month + MONTH = MONTH + 1 ! Increment month pointer + IF (MONTH.EQ.13) THEN ! Moved into next year? + MONTH = 1 ! Reset month pointer + YEAR = YEAR + 1 ! Increment year pointer + IF (MOD(YEAR,4).EQ.0) THEN ! Correct February length + LENGTH(2) = 28 ! if we're in a leap year + ELSE + LENGTH(2) = 27 + END IF + END IF + ELSE ! If expiration date is within the month + DAY = DAY + NUM_DAYS ! Find expiration day + NUM_DAYS = 0 ! Force loop exit + END IF + END DO + + ENCODE(2,'(I2)',EXDATE(:2)) DAY ! Put day into new date + ENCODE(4,'(I4)',EXDATE(8:11)) YEAR ! Put year into new date + EXDATE(4:6) = MONTHS(MONTH) ! Put month into new date + + RETURN + END + + + + SUBROUTINE GET_LINE(INPUT,LEN_INPUT) +C +C SUBROUTINE GET_LINE +C +C FUNCTION: +C Gets line of input from terminal. +C +C OUTPUTS: +C LEN_INPUT - Length of input line. If = -1, CTRLC entered. +C if = -2, CTRLZ entered. +C +C NOTES: +C Also, on first call, set LEN_INPUT to 1+LENGTH OF INPUT CHARCTER +C for initializing the CTRLC AST. +C + + IMPLICIT INTEGER (A-Z) + + LOGICAL*1 DESCRIP(8),DTYPE,CLASS + INTEGER*2 LENGTH + CHARACTER*(*) INPUT + EQUIVALENCE (DESCRIP(1),LENGTH),(DESCRIP(3),DTYPE) + EQUIVALENCE (DESCRIP(4),CLASS),(DESCRIP(5),POINTER) + + DATA LENGTH/0/,DTYPE/0/,CLASS/2/,POINTER/0/ + + EXTERNAL SMG$_EOF + + COMMON /DECNET/ DECNET_PROC,ERROR_UNIT + LOGICAL DECNET_PROC + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + CHARACTER PROMPT*(*),NULLPROMPT*1 + LOGICAL*1 USE_PROMPT + + USE_PROMPT = .FALSE. + + GO TO 5 + + ENTRY GET_INPUT_PROMPT(INPUT,LEN_INPUT,PROMPT) + + USE_PROMPT = .TRUE. + +5 LIMIT = LEN(INPUT) ! Get input line size limit + INPUT = ' ' ! Clean out input buffer + +C +C Initialize CTRL-C AST with AST routine CTRLC_ROUTINE and +C AST parameter FLAG. When CTRLC occurs, FLAG is set to 1 +C + + CALL DECLARE_CTRLC_AST + + LEN_INPUT = 0 ! Nothing inputted yet + +C +C LIB$GET_INPUT is nice way of getting input from terminal, +C as it handles such thing as accidental wrap around to next line. +C + + IF (DECNET_PROC) THEN + READ (5,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUT + IF (IER.NE.0) LEN_INPUT = -2 + RETURN + ELSE IF (USE_PROMPT) THEN + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,PROMPT) ! Get line from terminal with prompt + ELSE + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & DESCRIP,NULLPROMPT) ! Get line from terminal with no prompt + END IF + + IF (.NOT.IER.AND.IER.NE.%LOC(SMG$_EOF)) CALL EXIT(IER) + + CALL STR$TRIM(DESCRIP,DESCRIP,LEN_INPUT) + + IF (FLAG.EQ.0) THEN ! If no CTRL-C has occurred + CALL CANCEL_CTRLC_AST ! Cancel CTRL-C AST + IF (IER.NE.%LOC(SMG$_EOF)) THEN ! End of input? + LEN_INPUT = MIN(LIMIT,LENGTH) ! No. Get length of line + DO I=0,LEN_INPUT-1 ! Extract from descriptor + CALL GET_VAL(INPUT(I+1:I+1),%VAL(POINTER+I)) + END DO + CALL CONVERT_TABS(INPUT,LEN_INPUT) + LEN_INPUT = MAX(LEN_INPUT,LENGTH) + ELSE + LEN_INPUT = -2 ! If CTRL-Z, say so + END IF + ELSE + LEN_INPUT = -1 ! If CTRL-C, say so + END IF + RETURN + END + + + + SUBROUTINE CONVERT_TABS(INPUT,LEN_INPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT + + PARAMETER TAB = CHAR(9) + + LIMIT = LEN(INPUT) + + DO WHILE (INDEX(INPUT,TAB).GT.0.AND.LEN_INPUT.LT.LIMIT) + TAB_POINT = INDEX(INPUT,TAB) ! Remove tabs + MOVE = ((TAB_POINT-1)/8)*8 + 9 + ADD = MOVE - TAB_POINT + IF (MOVE-1.LE.LIMIT) THEN + INPUT(MOVE:) = INPUT(TAB_POINT+1:) + DO I = TAB_POINT,MOVE-1 + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LEN_INPUT + ADD - 1 + ELSE + DO I = TAB_POINT,LIMIT + INPUT(I:I) = ' ' + END DO + LEN_INPUT = LIMIT+1 + END IF + END DO + + CALL FILTER (INPUT, LEN_INPUT) + + RETURN + END + + + SUBROUTINE FILTER (INCHAR, LENGTH) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INCHAR + + DO I = 1,LENGTH + IF ((INCHAR(I:I).LT.' '.AND. + & INCHAR(I:I).NE.CHAR(13).AND.INCHAR(I:I).NE.CHAR(10))) + & INCHAR(I:I) = '.' + END DO + + RETURN + END + + + SUBROUTINE GET_VAL(OUTPUT,INPUT) ! Used to convert logical + CHARACTER*(*) OUTPUT ! byte to character value + LOGICAL*1 INPUT + OUTPUT = CHAR(INPUT) + RETURN + END + + SUBROUTINE CTRLC_ROUTINE ! CTRL-C AST routine + IMPLICIT INTEGER (A-Z) ! If CTRL-C, come here + + COMMON /CTRLY/ CTRLY + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + IF (FLAG.EQ.2) THEN + CALL LIB$PUT_OUTPUT('Bulletin aborting...') + CALL SYS$CANEXH() + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + CALL EXIT + END IF + FLAG = 1 ! to set flag + RETURN + END + + + + SUBROUTINE DECLARE_CTRLC_AST +C +C SUBROUTINE DECLARE_CTRLC_AST +C +C FUNCTION: +C Declares a CTRLC ast. +C NOTES: +C Assumes terminal assigned to TERM_CHAN in common /TERM_CHAN/. +C + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SETMODE,IO$M_CTRLCAST,CTRLC_ROUTINE + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /CTRLC_FLAG/ FLAG + + FLAG = 0 ! Init CTRL-C flag + IO_CTRLC = %LOC(IO$_SETMODE)+%LOC(IO$M_CTRLCAST) ! Set AST code + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + + ENTRY CANCEL_CTRLC_AST + + IER = SYS$CANCEL(%VAL(TERM_CHAN)) + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,, ! for QIO + & CTRLC_ROUTINE,,,,,) ! Enable the AST + + RETURN + END + + + + + SUBROUTINE GET_INPUT_NOECHO(DATA) +C +C SUBROUTINE GET_INPUT_NOECHO +C +C FUNCTION: Reads data in from terminal without echoing characters. +C Also contains entry to assign terminal. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) DATA,PROMPT + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /CTRLC_FLAG/ FLAG + + COMMON /READIT/ READIT + + INCLUDE '($TRMDEF)' + + INTEGER TERMSET(2) + + INTEGER MASK(4) + DATA MASK/4*'FFFFFFFF'X/ + + DATA PURGE/.TRUE./ + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NOECHO_PROMPT(DATA,PROMPT) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), + & TRM$M_TM_NOECHO) + END IF + + RETURN + + ENTRY GET_INPUT_NUM(DATA,NLEN) + + DO I=1,LEN(DATA) + DATA(I:I) = ' ' + END DO + + IF (PURGE) THEN + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), + & TRM$M_TM_PURGE,,TERMSET,NLEN,TERM) + PURGE = .FALSE. + ELSE + CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA),,, + & TERMSET,NLEN,TERM) + END IF + + IF (TERM.NE.13.AND.TERM.NE.510.AND.NLEN.EQ.0) THEN + ! Input did not end with CR or buffer full + NLEN = 1 + DATA(:1) = CHAR(TERM) + END IF + + RETURN + + ENTRY ASSIGN_TERMINAL + + IER = SYS$ASSIGN('TT',TERM_CHAN,,) ! Assign terminal + + CALL DECLARE_CTRLC_AST + + FLAG = 2 ! Indicates that a CTRLC will cause an exit + + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IF (CLI$PRESENT('KEYPAD')) THEN + CALL SET_KEYPAD + ELSE IF (READIT.EQ.0) THEN + CALL SET_NOKEYPAD + END IF + + TERMSET(1) = 16 + TERMSET(2) = %LOC(MASK) + + DO I=ICHAR('0'),ICHAR('9') + MASK(2) = IBCLR(MASK(2),I-32) + END DO + + RETURN + END + + + + + + SUBROUTINE GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) +C +C SUBROUTINE GETPAGSIZ +C +C FUNCTION: +C Gets page size of the terminal. +C +C OUTPUTS: +C PAGE_LENGTH - Page length of the terminal. +C PAGE_WIDTH - Page size of the terminal. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($DVIDEF)' + + LOGICAL*1 DEVDEPEND(4) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,DVI$_DEVDEPEND,%LOC(DEVDEPEND(1))) + CALL ADD_2_ITMLST(4,DVI$_DEVBUFSIZ,%LOC(PAGE_WIDTH)) + CALL END_ITMLST(GETDVI_ITMLST) ! Get address of itemlist + + CALL SYS$GETDVIW(,,'TT',%VAL(GETDVI_ITMLST),,,,) + + PAGE_LENGTH = ZEXT(DEVDEPEND(4)) + + PAGE_WIDTH = MIN(PAGE_WIDTH,132) + + RETURN + END + + + + + + LOGICAL FUNCTION SLOW_TERMINAL +C +C FUNCTION SLOW_TERMINAL +C +C FUNCTION: +C Indicates that terminal has a slow speed (2400 baud or less). +C +C OUTPUTS: +C SLOW_TERMINAL = .true. if slow, .false. if not. +C + + IMPLICIT INTEGER (A-Z) + + EXTERNAL IO$_SENSEMODE + + COMMON /TERM_CHAN/ TERM_CHAN + + COMMON CHAR_BUF(2) + + LOGICAL*1 IOSB(8) + + INCLUDE '($TTDEF)' + + IER = SYS$QIOW(,%VAL(TERM_CHAN),IO$_SENSEMODE,IOSB,,, + & CHAR_BUF,%VAL(8),,,,) + + IF (IOSB(3).LE.TT$C_BAUD_2400) THEN + SLOW_TERMINAL = .TRUE. + ELSE + SLOW_TERMINAL = .FALSE. + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_PRIV +C +C SUBROUTINE SHOW_PRIV +C +C FUNCTION: +C To show privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($PRVDEF)' + + INCLUDE '($SSDEF)' + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + IF (NEW_FLAG(1).EQ.-1.AND.NEW_FLAG(2).EQ.-1) THEN ! Info not present + CALL CLOSE_BULLUSER + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + CALL READ_USER_FILE_HEADER(IER) + USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + USERPRIV(2) = 0 + REWRITE (4) USER_HEADER + END IF + WRITE (6,'('' Following privileges are needed for privileged + & commands:'')') + DO I=0,38 + IF ((I.LT.32.AND.BTEST(USERPRIV(1),I)).OR. + & (I.GT.31.AND.BTEST(USERPRIV(2),I-32))) THEN + WRITE (6,'(1X,A)') PRIVS(I) + END IF + END DO + ELSE + WRITE (6,'('' ERROR: Cannot show privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + CALL CHKACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE)),IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN + CALL SHOWACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE))) + END IF + + RETURN + + END + + + + + SUBROUTINE SET_PRIV +C +C SUBROUTINE SET_PRIV +C +C FUNCTION: +C To set privileges necessary for managing bulletin board. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + INCLUDE 'BULLUSER.INC' + + COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) + + COMMON /PRVDEF/ PRIVS + CHARACTER*8 PRIVS(0:38) + DATA PRIVS + & /'CMKRNL','CMEXEC','SYSNAM','GRPNAM','ALLSPOOL','DETACH', + & 'DIAGNOSE','LOG_IO','GROUP','ACNT','PRMCEB','PRMMBX','PSWAPM', + & 'ALTPRI','SETPRV','TMPMBX','WORLD','MOUNT','OPER','EXQUOTA', + & 'NETMBX','VOLPRO','PHY_IO','BUGCHK','PRMGBL','SYSGBL','PFNMAP', + & 'SHMEM','SYSPRV','BYPASS','SYSLCK','SHARE','UPGRADE','DOWNGRADE', + & 'GRPPRV','READALL',' ',' ','SECURITY'/ + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + DIMENSION ONPRIV(2),OFFPRIV(2) + + CHARACTER*32 INPUT_PRIV + + IF (.NOT.SETPRV_PRIV().OR..NOT.BTEST(PROCPRIV(1),PRV$V_SETPRV)) THEN + WRITE (6,'('' ERROR: This command requires SETPRV privileges.'')') + RETURN + END IF + + IF (CLI$PRESENT('ID').OR. + & CLI$PRESENT('ID').EQ.%LOC(CLI$_NEGATED)) THEN + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the IDs + IF (CLI$PRESENT('ID')) THEN + CALL ADD_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + ELSE + CALL DEL_ACL(INPUT_PRIV(:PLEN),'R+C',IER) + END IF + IF (.NOT.IER) CALL SYS_GETMSG(IER) + END DO + RETURN + END IF + + OFFPRIV(1) = 0 + OFFPRIV(2) = 0 + ONPRIV(1) = 0 + ONPRIV(2) = 0 + + DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN) + & .NE.%LOC(CLI$_ABSENT)) ! Get the privileges + PRIV_FOUND = -1 + I = 0 + DO WHILE (I.LT.39.AND.PRIV_FOUND.EQ.-1) + IF (INPUT_PRIV(:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + IF (INPUT_PRIV(3:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I + I = I + 1 + END DO + IF (PRIV_FOUND.EQ.-1) THEN + WRITE(6,'('' ERROR: Incorrectly specified privilege = '', + & A)') INPUT_PRIV(:PLEN) + RETURN + ELSE IF (INPUT_PRIV(:2).EQ.'NO') THEN + IF (INPUT_PRIV.EQ.'NOSETPRV') THEN + WRITE(6,'('' ERROR: Cannot remove SETPRV privileges.'')') + RETURN + ELSE IF (PRIV_FOUND.LT.32) THEN + OFFPRIV(1) = IBSET(OFFPRIV(1),PRIV_FOUND) + ELSE + OFFPRIV(2) = IBSET(OFFPRIV(2),PRIV_FOUND-32) + END IF + ELSE + IF (PRIV_FOUND.LT.32) THEN + ONPRIV(1) = IBSET(ONPRIV(1),PRIV_FOUND) + ELSE + ONPRIV(2) = IBSET(ONPRIV(2),PRIV_FOUND-32) + END IF + END IF + END DO + + CALL OPEN_BULLUSER ! Get BULLUSER.DAT file + + CALL READ_USER_FILE_HEADER(IER) + + IF (IER.EQ.0) THEN ! If header is present, exit + USERPRIV(1) = USERPRIV(1).OR.ONPRIV(1) + USERPRIV(2) = USERPRIV(2).OR.ONPRIV(2) + USERPRIV(1) = USERPRIV(1).AND.(.NOT.OFFPRIV(1)) + USERPRIV(2) = USERPRIV(2).AND.(.NOT.OFFPRIV(2)) + REWRITE (4) USER_HEADER + WRITE (6,'('' Privileges successfully modified.'')') + ELSE + WRITE (6,'('' ERROR: Cannot modify privileges.'')') + END IF + + CALL CLOSE_BULLUSER ! All finished with BULLUSER + + RETURN + + END + + + + SUBROUTINE ADD_ACL(ID,ACCESS,IER) +C +C SUBROUTINE ADD_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + INCLUDE '($SSDEF)' + + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) THEN + IF (IER.EQ.SS$_NOSUCHID.AND.ADDID.AND. + & INDEX(ACCESS,'C').EQ.0) THEN + CALL GET_UAF(ID,USER,GROUP,ACCOUNT,FLAGS,IER) + IF (.NOT.IER) THEN + CALL ERRSNS(IDUMMY,IER) + WRITE (6,'( + & '' ERROR: Specified username cannot be verified.'')') + CALL SYS_GETMSG(IER) + RETURN + END IF + IDENT = USER + ISHFT(GROUP,16) + IER = SYS$ADD_IDENT(ID,%VAL(IDENT),,) + IF (IER) THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + END IF + END IF + END IF + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_ADDACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IF (INDEX(ACCESS,'C').GT.0.AND.INDEX(ACCESS,'W').EQ.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + SUBROUTINE DEL_ACL(ID,ACCESS,IER) +C +C SUBROUTINE DEL_ACL +C +C FUNCTION: Adds ACL to bulletin files. +C +C PARAMETERS: +C ID - Character string containing identifier to add to ACL. +C ACCESS - Character string containing access controls to give to ID. +C IER - Return error from attempting to set ACL. +C +C NOTE: The ID must be in the RIGHTS data base. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER ACLENT*255,ID*(*),ACCESS*(*) + + INCLUDE '($ACLDEF)' + + IF (ID.NE.' ') THEN + IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS=' + & //ACCESS//')',ACLENT,,) + IF (.NOT.IER) RETURN + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_DELACLENT,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_DELETEACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + END IF + + IF (INDEX(ACCESS,'C').GT.0) THEN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM( + & BULLUSER_FILE)),%VAL(ACL_ITMLST),,,) + RETURN + END IF + + FLEN = TRIM(FOLDER1_FILE) + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLDIR',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILE(:FLEN)// + & '.BULLFIL',%VAL(ACL_ITMLST),,,) + IF (.NOT.IER) RETURN + + RETURN + END + + + + + SUBROUTINE CREATE_FOLDER +C +C SUBROUTINE CREATE_FOLDER +C +C FUNCTION: Creates a new bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + IF (.NOT.SETPRV_PRIV().AND.CLI$PRESENT('NEEDPRIV')) THEN + WRITE(6,'('' ERROR: CREATE is a privileged command.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('CREATE_FOLDER',FOLDER,LEN_T) ! Get folder name + + IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + IF (.NOT.SETPRV_PRIV().AND.(CLI$PRESENT('ALWAYS').OR. + & CLI$PRESENT('NOTIFY').OR.CLI$PRESENT('READNEW').OR. + & CLI$PRESENT('BRIEF').OR.CLI$PRESENT('SYSTEM'))) THEN + WRITE (6,'('' ERROR: Privileged qualifier specified.'')') + RETURN + END IF + + IF (CLI$PRESENT('NODE')) THEN ! Remote node specified? + IER = CLI$GET_VALUE('NODE',FOLDER_BBOARD,LEN_B) ! Get node name + FOLDER_BBOARD = '::'//FOLDER_BBOARD(:LEN_B) + FOLDER1_BBOARD = FOLDER_BBOARD + IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1)) THEN + FOLDER1 = FOLDER + END IF + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder not accessible on remote node.'')') + RETURN + ELSE IF (CLI$PRESENT('SYSTEM').AND. + & .NOT.BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' ERROR: /SYSTEM not allowed as remote node'', + & '' is not SYSTEM folder.'')') + RETURN + END IF + END IF + + LENDES = 0 + DO WHILE (LENDES.EQ.0) + IF (CLI$PRESENT('DESCRIPTION')) THEN ! DESCRIPTION specified? + IER = CLI$GET_VALUE('DESCRIPTION',FOLDER_DESCRIP,LENDES) + ELSE + WRITE (6,'('' Enter one line description of folder.'')') + CALL GET_LINE(FOLDER_DESCRIP,LENDES) ! Get input line + FOLDER_DESCRIP = FOLDER_DESCRIP(:LENDES) ! End fill with spaces + END IF + IF (LENDES.LE.0) THEN + WRITE (6,'('' Aborting folder creation.'')') + RETURN + ELSE IF (LENDES.GT.80) THEN ! If too many characters + WRITE(6,'('' ERROR: folder must be < 80 characters.'')') + LENDES = 0 + END IF + END DO + + CALL OPEN_BULLFOLDER ! Open folder file + READ (7,IOSTAT=IER,KEY=FOLDER,KEYID=0) + ! See if folder exists + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Specified folder already exists.'')') + GO TO 1000 + END IF + + IF (CLI$PRESENT('OWNER')) THEN + IF (.NOT.SETPRV_PRIV().AND..NOT.CLI$PRESENT('ID')) THEN + WRITE (6,'('' ERROR: /OWNER requires privileges.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE + CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P) + IF (LEN_P.GT.12) THEN + WRITE (6,'('' ERROR: Folder owner name must be'', + & '' no more than 12 characters long.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (CLI$PRESENT('ID')) THEN + IER = CHKPRO(FOLDER1_OWNER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: ID not valid.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + ELSE + CALL GET_UAF + & (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Owner not valid username.'')') + CALL CLOSE_BULLFOLDER + RETURN + END IF + END IF + FOLDER_OWNER = FOLDER1_OWNER + END IF + ELSE + FOLDER_OWNER = USERNAME ! Get present username + FOLDER1_OWNER = FOLDER_OWNER ! Save for later + END IF + + FOLDER_SET = .TRUE. + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + +C +C Folder file is placed in the directory FOLDER_DIRECTORY. +C The file prefix is the name of the folder. +C + + FD_LEN = TRIM(FOLDER_DIRECTORY) + IF (FD_LEN.EQ.0) THEN + WRITE (6,'('' ERROR: System programmer has disabled folders.'')') + GO TO 910 + ELSE + FOLDER_FILE = FOLDER_DIRECTORY(:FD_LEN)//FOLDER + END IF + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder directory file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='NEW', + 1 ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',IOSTAT=IER) + + IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot create folder message file.'')') + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + + FOLDER_FLAG = 0 + + IF (CLI$PRESENT('PRIVATE').OR.CLI$PRESENT('SEMIPRIVATE')) THEN + ! Will folder have access limitations? + FOLDER1_FILE = FOLDER_FILE + CLOSE (UNIT=1) + CLOSE (UNIT=2) + IF (CLI$PRESENT('SEMIPRIVATE')) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER_OWNER,'R+W+C',IER) + OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLDIR',STATUS='OLD',IOSTAT=IER1) + OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + 1 //'.BULLFIL',STATUS='OLD',IOSTAT=IER1) + IF (.NOT.IER) THEN + WRITE(6, + & '('' ERROR: Cannot create private folder using ACLs.'')') + CALL SYS_GETMSG(IER) + GO TO 910 + END IF + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + + IER = 0 + LAST_NUMBER = 1 + DO WHILE (IER.EQ.0.AND.LAST_NUMBER.LT.FOLDER_MAX-1) + READ (7,IOSTAT=IER,KEY=LAST_NUMBER,KEYID=1) + LAST_NUMBER = LAST_NUMBER + 1 + END DO + + IF (IER.EQ.0) THEN + WRITE (6,'('' ERROR: Folder limit of '',I,'' has been reached.'')') + & FOLDER_MAX + WRITE (6,'('' Unable to add specified folder.'')') + GO TO 910 + ELSE + FOLDER1_NUMBER = LAST_NUMBER - 1 + END IF + + IF (.NOT.CLI$PRESENT('NODE')) THEN + FOLDER_BBOARD = 'NONE' + IF (REMOTE_SET) CLOSE (UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + FOLDER_BBEXPIRE = 14 + F_NBULL = 0 + NBULL = 0 + F_NEWEST_BTIM(1) = 0 + F_NEWEST_BTIM(2) = 0 + F_NEWEST_NOSYS_BTIM(1) = 0 + F_NEWEST_NOSYS_BTIM(2) = 0 + F_EXPIRE_LIMIT = 0 + FOLDER_NUMBER = FOLDER1_NUMBER + ELSE + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + IF (FOLDER1.NE.FOLDER) THEN ! Different remote folder name? + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR ! If so, store name in directory file + BULLDIR_HEADER(13:) = FOLDER1 + CALL WRITEDIR_NOCONV(0,IER) + CALL CLOSE_BULLDIR + FOLDER1_BBOARD = FOLDER1_BBOARD(:LEN_B+2)//'*' + FOLDER1 = FOLDER + END IF + REMOTE_SET = .TRUE. + IF (BTEST(FOLDER1_FLAG,0)) FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + FOLDER1_FLAG = FOLDER_FLAG + FOLDER1_DESCRIP = FOLDER_DESCRIP + FOLDER_COM = FOLDER1_COM + NBULL = F_NBULL + END IF + + FOLDER_OWNER = FOLDER1_OWNER + + IF (CLI$PRESENT('SYSTEM')) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + IF (CLI$PRESENT('ID')) FOLDER_FLAG = IBSET(FOLDER_FLAG,6) + IF (CLI$PRESENT('ALWAYS')) FOLDER_FLAG = IBSET(FOLDER_FLAG,7) + + CALL WRITE_FOLDER_FILE(IER) + CALL MODIFY_SYSTEM_LIST(0) + + CLOSE (UNIT=1) + CLOSE (UNIT=2) + + NOTIFY = 0 + READNEW = 0 + BRIEF = 0 + IF (CLI$PRESENT('NOTIFY')) NOTIFY = 1 + IF (CLI$PRESENT('READNEW')) READNEW = 1 + IF (CLI$PRESENT('SHOWNEW')) BRIEF = 1 + IF (CLI$PRESENT('BRIEF')) THEN + BRIEF = 1 + READNEW = 1 + END IF + CALL SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) + + WRITE (6,'('' Folder is now set to '',A)') + & FOLDER(:TRIM(FOLDER))//'.' + + GO TO 1000 + +910 WRITE (6,'('' Aborting folder creation.'')') + IF (FOLDER_NUMBER.EQ.0) FOLDER_SET = .FALSE. + CLOSE (UNIT=1,STATUS='DELETE') + CLOSE (UNIT=2,STATUS='DELETE') + +1000 CALL CLOSE_BULLFOLDER + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + INTEGER FUNCTION CHKPRO(INPUT) +C +C Description: +C Parse given identify into binary ACL format. +C Call SYS$CHKPRO to check if present process has read +C access to an object if the object's protection is the ACL. +C + IMPLICIT INTEGER (A-Z) + + CHARACTER ACL*255 + CHARACTER*(*) INPUT + + INCLUDE '($CHPDEF)' + + CHKPRO = SYS$PARSE_ACL('(IDENTIFIER='//INPUT(:TRIM(INPUT))// + & ',ACCESS=R)',ACL,,) ! Convert to ACL into binary format + IF (.NOT.CHKPRO) RETURN ! Exit if can't + + FLAGS = CHP$M_READ ! Specify read access checking + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACL(:1)),CHP$_ACL,%LOC(ACL(1:1))) + CALL ADD_2_ITMLST(4,CHP$_FLAGS,%LOC(FLAGS)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + CHKPRO = SYS$CHKPRO(%VAL(ACL_ITMLST)) ! Check if process has the + ! rights-id assigned to it + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin5.for b/decus/vax91b/gce91b/net91b/bulletin5.for new file mode 100644 index 0000000..84f16aa --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin5.for @@ -0,0 +1,2139 @@ +C +C BULLETIN5.FOR, Version 9/15/91 +C Purpose: Contains subroutines for the bulletin board utility program. +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C +C + SUBROUTINE SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF) +C +C SUBROUTINE SET_FOLDER_DEFAULT +C +C FUNCTION: Sets flag defaults for specified folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + EXTERNAL CLI$_NEGATED + + IF (FOLDER_NUMBER.LT.0) THEN + WRITE (6,'('' ERROR: Cannot set modify for remote folder.'')') + RETURN + END IF + + ALL = .FALSE. + DEFAULT = 0 + + IF (INCMD(:3).EQ.'SET') THEN + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: Privileges needed for changing defaults.'')') + RETURN + END IF + ALL = CLI$PRESENT('ALL') + DEFAULT = CLI$PRESENT('DEFAULT') + CALL OPEN_BULLUSER_SHARED + IF (CLI$PRESENT('PERMANENT')) THEN + CALL SET_PERM(NOTIFY,READNEW,BRIEF) + ELSE IF (CLI$PRESENT('NOPERMANENT')) THEN + IF (NOTIFY.GE.0) CALL SET_PERM(0,-1,-1) + IF (READNEW.GE.0.OR.BRIEF.GE.0) CALL SET_PERM(-1,0,0) + END IF + ELSE + CALL OPEN_BULLUSER_SHARED + END IF + + CALL READ_USER_FILE_HEADER(IER) + IF (DEFAULT.EQ.0.OR.DEFAULT) THEN + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG_DEF,FOLDER_NUMBER) + REWRITE(4) USER_HEADER + END IF + + IF (ALL.OR.(BRIEF.NE.-1.AND.NOTIFY.NE.-1.AND.READNEW.NE.-1)) THEN + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + IF (TEMP_USER(:1).NE.'*'.AND.TEMP_USER(:1).NE.':') THEN + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_FLAG,FOLDER_NUMBER) + REWRITE(4) TEMP_USER//USER_ENTRY(13:) + END IF + CALL READ_USER_FILE(IER) + END DO + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + SUBROUTINE READ_PERM + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /BULL_PERM/ SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + DIMENSION SET_PERM_FLAG(FLONG) + DIMENSION BRIEF_PERM_FLAG(FLONG) + DIMENSION NOTIFY_PERM_FLAG(FLONG) + + COMMON /FLAG_ACCESS/ FLAG_ACCESS + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*PERM',IOSTAT=IER) TEMP_USER, + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + SET_PERM_FLAG(I) = 0 + BRIEF_PERM_FLAG(I) = 0 + NOTIFY_PERM_FLAG(I) = 0 + END DO + BRIEF_PERM_FLAG(1) = 1 ! SHOWNEW permanent for GENERAL folder + WRITE (4,IOSTAT=IER) + & '*PERM ', + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + CALL READ_USER_FILE_HEADER(IER) + IF (.NOT.TEST2(SET_FLAG_DEF,0)) THEN + CALL SET2(BRIEF_FLAG_DEF,0) + REWRITE(4) USER_HEADER + END IF + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0) + IF (TEMP_USER(:1).NE.'*'.AND.TEMP_USER(:1).NE.':') THEN + IF (.NOT.TEST2(SET_FLAG,0)) THEN + CALL SET2(BRIEF_FLAG,0) + REWRITE(4) TEMP_USER//USER_ENTRY(13:) + END IF + END IF + CALL READ_USER_FILE(IER) + END DO + ELSE + UNLOCK 4 + END IF + + RETURN + + ENTRY SET_PERM(NOTIFY,READNEW,BRIEF) + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*PERM',IOSTAT=IER) TEMP_USER, + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + END DO + + IF (NOTIFY.EQ.0) CALL CLR2(NOTIFY_PERM_FLAG,FOLDER_NUMBER) + IF (NOTIFY.EQ.1) CALL SET2(NOTIFY_PERM_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.0) CALL CLR2(SET_PERM_FLAG,FOLDER_NUMBER) + IF (READNEW.EQ.1) CALL SET2(SET_PERM_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.0) CALL CLR2(BRIEF_PERM_FLAG,FOLDER_NUMBER) + IF (BRIEF.EQ.1) CALL SET2(BRIEF_PERM_FLAG,FOLDER_NUMBER) + + REWRITE (4,IOSTAT=IER) TEMP_USER, + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + + RETURN + + ENTRY SET_USER_FLAG(NOTIFY,READNEW,BRIEF) + + IF (.NOT.FLAG_ACCESS) THEN + WRITE (6,'('' ERROR: Cannot set flags for protected'', + & '' folder without explicit access granted'',/, + & '' via SET ACCESS. See HELP SET ACCESS for further'' + & '' information.'')') + RETURN + END IF + + IF (FOLDER_NUMBER.LT.0.AND.NEWS_FOLDER_NUMBER.GT.0) THEN + CALL NEWS_SET_USER_FLAG(NOTIFY,READNEW,BRIEF) + RETURN + END IF + + CALL OPEN_BULLUSER_SHARED + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*PERM',IOSTAT=IER) TEMP_USER, + & SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + END DO + + CALL CLOSE_BULLUSER + + IER = .TRUE. + IF (NOTIFY.EQ.0) THEN + IF (TEST2(NOTIFY_PERM_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' ERROR: NOTIFY is permanent for this folder.'')') + RETURN + ELSE + CALL CHANGE_FLAG(0,4) + END IF + ELSE IF (NOTIFY.EQ.1) THEN + CALL CHANGE_FLAG(1,4) + RETURN + ELSE IF (BRIEF.EQ.0.AND.READNEW.EQ.0.AND. + & (TEST2(SET_PERM_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_PERM_FLAG,FOLDER_NUMBER))) THEN + IER = .FALSE. + ELSE IF (BRIEF.EQ.1.AND.READNEW.EQ.0.AND. + & TEST2(SET_PERM_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(BRIEF_PERM_FLAG,FOLDER_NUMBER)) THEN + IER = .FALSE. + ELSE IF (BRIEF.EQ.1.AND.READNEW.EQ.1.AND. + & (TEST2(SET_PERM_FLAG,FOLDER_NUMBER).XOR. + & TEST2(BRIEF_PERM_FLAG,FOLDER_NUMBER))) THEN + IER = .FALSE. + END IF + + IF (IER) THEN + IF (READNEW.GE.0) CALL CHANGE_FLAG(READNEW,2) + IF (BRIEF.GE.0) CALL CHANGE_FLAG(BRIEF,3) + ELSE + WRITE (6,'('' ERROR: PERMANENT flags exist for this folder.'')') + WRITE (6,'('' Flags will be set to those permanent settings.'')') + + IF (TEST2(SET_PERM_FLAG,FOLDER_NUMBER)) THEN + CALL CHANGE_FLAG(1,2) + ELSE + CALL CHANGE_FLAG(0,2) + END IF + + IF (TEST2(BRIEF_PERM_FLAG,FOLDER_NUMBER)) THEN + CALL CHANGE_FLAG(1,3) + ELSE + CALL CHANGE_FLAG(0,3) + END IF + END IF + + RETURN + END + + + + + + SUBROUTINE REMOVE_FOLDER +C +C SUBROUTINE REMOVE_FOLDER +C +C FUNCTION: Removes a bulletin folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + EXTERNAL CLI$_ABSENT + + CHARACTER RESPONSE*1,TEMP*80 + + IER = CLI$GET_VALUE('REMOVE_FOLDER',FOLDER1,LEN_T) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + IF (.NOT.FOLDER_SET) THEN + WRITE (6,'('' ERROR: No folder specified.'')') + RETURN + ELSE + FOLDER1 = FOLDER + END IF + ELSE IF (LEN_T.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Are you sure you want to remove folder ' + & //FOLDER1(:TRIM(FOLDER1))//' (Y/N with N as default): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder was not removed.'')') + RETURN + END IF + + IF (INDEX(FOLDER1,'.').GT.0) THEN + CALL OPEN_BULLNEWS_SHARED + ELSE + CALL OPEN_BULLFOLDER + END IF + + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if folder exists + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + GO TO 1000 + ELSE IF (INDEX(FOLDER1,'.').GT.0) THEN + CALL REMOTE_REMOVE_FOLDER(IER) + IF (.NOT.IER) GO TO 1000 + END IF + + IF (.NOT.FOLDER_ACCESS(USERNAME,FOLDER1_FLAG,FOLDER1_OWNER).OR. + & FOLDER1.EQ.'GENERAL') THEN + WRITE (6,'('' ERROR: You are not able to remove the folder.'')') + GO TO 1000 + END IF + + TEMP = FOLDER_FILE + FOLDER_FILE = FOLDER1_FILE + + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND.BTEST(FOLDER1_FLAG,2)) THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) FLEN = FLEN - 1 + OPEN (UNIT=17,STATUS='UNKNOWN',IOSTAT=IER, + & RECL=256,FILE=FOLDER1_BBOARD(3:FLEN) + & //'::"TASK=BULLETIN1"') + IF (IER.EQ.0) THEN ! Deregister remote SYSTEM folder + IF (INDEX(FOLDER1_BBOARD,'*').GT.0) THEN + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + IF (IER.EQ.1) FOLDER1 = BULLDIR_HEADER(13:) + CALL CLOSE_BULLDIR + END IF + WRITE (17,'(2A)',IOSTAT=IER) 1,FOLDER1 ! Select folder + IF (IER.EQ.0) READ(17,'(5A)',IOSTAT=IER) ! Throw away response + IF (IER.EQ.0) WRITE(17,'(2A)',IOSTAT=IER) 14,0 ! Deregister + CLOSE (UNIT=17) + END IF + END IF + + TEMPSET = FOLDER_SET + FOLDER_SET = .TRUE. + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + ! in case files don't exist and are created. + CALL OPEN_BULLDIR ! Remove directory file + CALL OPEN_BULLFIL ! Remove bulletin file + CALL CLOSE_BULLFIL_DELETE + CALL CLOSE_BULLDIR_DELETE + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + FOLDER_FILE = TEMP + FOLDER_SET = TEMPSET + + DELETE (7) + + TEMP_NUMBER = FOLDER_NUMBER + FOLDER_NUMBER = FOLDER1_NUMBER + CALL SET_FOLDER_DEFAULT(0,0,0) + FOLDER_NUMBER = TEMP_NUMBER + + WRITE (6,'('' Folder removed.'')') + + IF (FOLDER.EQ.FOLDER1) THEN + FOLDER_SET = .FALSE. + ELSE + REMOTE_SET = REMOTE_SET_SAVE + END IF + +1000 CALL CLOSE_BULLFOLDER + + RETURN + + END + + + SUBROUTINE SELECT_FOLDER(OUTPUT,IER) +C +C SUBROUTINE SELECT_FOLDER +C +C FUNCTION: Selects the specified folder. +C +C INPUTS: +C OUTPUT - Specifies whether status messages are outputted. +C +C NOTES: +C FOLDER_NUMBER is used for selecting the folder. +C If FOLDER_NUMBER = -1, the name stored in FOLDER1 is used. +C If FOLDER_NUMBER = -2, the name stored in FOLDER1 is used, +C but the folder is not selected if it is remote. +C If the specified folder is on a remote node and does not have +C a local entry (i.e. specified via NODENAME::FOLDERNAME), then +C FOLDER_NUMBER is set to -1. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE '($RMSDEF)' + INCLUDE '($SSDEF)' + + COMMON /POINT/ BULL_POINT + + COMMON /ACCESS/ READ_ONLY + LOGICAL READ_ONLY + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + DATA REMOTE_SET /.FALSE./ + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /TAGS/ BULL_TAG,READ_TAG + + COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM + + COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG) + + COMMON /HEADER/ HEADER + + COMMON /READIT/ READIT + + COMMON /FLAG_ACCESS/ FLAG_ACCESS + + EXTERNAL CLI$_ABSENT,CLI$_NEGATED + + CHARACTER*80 LOCAL_FOLDER1_DESCRIP + + CHARACTER*25 FOLDER1_SAVE + + DIMENSION FIRST_TIME(FLONG) ! Bit set for folder if folder has + DATA FIRST_TIME /FLONG*0/ ! been selected before this. + + DIMENSION OLD_NEWEST_BTIM(2) + + DATA LAST_NEWS_GROUP/0/ + + COMMAND = (INCMD(:3).EQ.'ADD').OR.(INCMD(:3).EQ.'DEL').OR. + & (INCMD(:3).EQ.'DIR').OR.(INCMD(:3).EQ.'IND').OR. + & (INCMD(:3).EQ.'REP').OR.(INCMD(:3).EQ.'SEL').OR. + & (INCMD(:3).EQ.'SET') + + IF (.NOT.OUTPUT.OR.FOLDER_NUMBER.NE.-1.OR.COMMAND) THEN + IF (OUTPUT) THEN ! Get folder name + IER = CLI$GET_VALUE('SELECT_FOLDER',FOLDER1_NAME) + FOLDER1 = FOLDER1_NAME + END IF + + FLEN = TRIM(FOLDER1) ! Add GENERAL after :: if no + IF (FLEN.GT.1) THEN ! name specified after the :: + IF (FOLDER1(FLEN-1:FLEN).EQ.'::') THEN + FOLDER1 = FOLDER1(:FLEN)//'GENERAL' + END IF + END IF + + IF (((IER.EQ.%LOC(CLI$_ABSENT).OR.FOLDER1.EQ.'GENERAL').AND. + & OUTPUT).OR.((FOLDER_NUMBER.EQ.0.OR.(FOLDER1.EQ.'GENERAL'.AND. + & FOLDER_NUMBER.LE.-1)).AND..NOT.OUTPUT)) THEN ! Select GENERAL + FOLDER_NUMBER = 0 + FOLDER1 = 'GENERAL' + END IF + END IF + + REMOTE_TEST = 0 + + IF (SAVE_FOLDER_Q1.NE.0) THEN ! Have folder info + FOLDER1_COM = FOLDER_COM + IER = 0 + NEWS = INDEX(FOLDER1,'.').GT.0.OR.(FOLDER1(:1).GE.'a'.AND. + & FOLDER1(:1).LE.'z') + ELSE + NEWS = (INDEX(FOLDER1,'.').GT.0.OR.(FOLDER1(:1).GE.'a'.AND. + & FOLDER1(:1).LE.'z')).AND.(FOLDER_NUMBER.LE.-1.OR.OUTPUT) + IF (NEWS.AND. + & SYS_TRNLNM('BULL_NEWS_SERVER','DEFINED')) THEN + CALL OPEN_BULLNEWS_SHARED ! Go find folder + READ (7,IOSTAT=IER,KEYEQ=1000,KEYID=1) NEWS_FOLDER1_COM + IF (IER.NE.0) THEN + WRITE (6,'('' Fetching NEWS groups from remote node.'' + & ,'' This will take several minutes.'')') + WRITE (6,'('' This is the only time this will have'' + & ,'' to be done.'')') + CALL CLOSE_BULLFOLDER + FOLDER1_SAVE = FOLDER1 + CALL NEWS_LIST + CALL OPEN_BULLFOLDER_SHARED + FOLDER1 = FOLDER1_SAVE + ELSE IF (NEWS_F1_END.GT.LAST_NEWS_READ(1,FOLDER_MAX).AND. + & OUTPUT.AND.NEWS_F1_END.GT.LAST_NEWS_GROUP) THEN + IF (LAST_NEWS_READ(1,FOLDER_MAX).GT.0) THEN + WRITE (6,'('' Type NEWS/NEWGROUP to see recently'', + & '' added news groups.'')') + ELSE + LAST_NEWS_READ(1,FOLDER_MAX) = NEWS_F1_END + END IF + LAST_NEWS_GROUP = NEWS_F1_END + END IF + CALL LOWERCASE(FOLDER1) + ELSE + CALL OPEN_BULLFOLDER_SHARED ! Go find folder + END IF + + IF (OUTPUT.OR.FOLDER_NUMBER.LE.-1) THEN + REMOTE_TEST = INDEX(FOLDER1,'::') + IF (REMOTE_TEST.GT.0) THEN + FOLDER1_BBOARD = '::'//FOLDER1(:REMOTE_TEST-1) + FOLDER1 = FOLDER1(REMOTE_TEST+2:TRIM(FOLDER1)) + FOLDER1_NUMBER = -1 + IER = 0 + ELSE IF (INCMD(:2).EQ.'SE') THEN + CALL READ_FOLDER_FILE_KEYNAME_TEMP + & (FOLDER1(:TRIM(FOLDER1)),IER) + ELSE + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + END IF + ELSE + FOLDER1_NUMBER = FOLDER_NUMBER + CALL READ_FOLDER_FILE_KEYNUM_TEMP(FOLDER_NUMBER,IER) + END IF + + IF (REMOTE_TEST.EQ.0) THEN + IF (BTEST(FOLDER1_FLAG,29)) THEN ! Error in folder flag!! + FOLDER1_FLAG = FOLDER1_FLAG.AND.3 + F1_EXPIRE_LIMIT = 0 + CALL REWRITE_FOLDER_FILE_TEMP + END IF + END IF + + CALL CLOSE_BULLFOLDER + END IF + + IF ((IER.EQ.0.OR.NEWS).AND. + & FOLDER1_BBOARD(:2).EQ.'::') THEN + IF (FOLDER_NUMBER.EQ.-2) RETURN ! Don't allow + IF (IER.NE.0) FOLDER1_DESCRIP = FOLDER1_NAME + LOCAL_FOLDER1_FLAG = FOLDER1_FLAG + LOCAL_FOLDER1_DESCRIP = FOLDER1_DESCRIP + CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER1) + IF (IER1.NE.0) THEN + IF (OUTPUT) THEN + WRITE (6,'('' ERROR: Unable to select the folder.'')') + IF (.NOT.NEWS) THEN + LENB = TRIM(FOLDER1_BBOARD) + IF (FOLDER1_BBOARD(LENB:LENB).EQ.'*') LENB = LENB - 1 + WRITE (6,'('' Cannot connect to node '',A,''.'')') + & FOLDER1_BBOARD(3:LENB) + ELSE IF (.NOT.IER1) THEN + WRITE (6,'('' Cannot connect to remote NEWS node.'')') + END IF + END IF + RETURN + END IF + IF (REMOTE_TEST.GT.0) THEN ! Folder specified with "::" + FOLDER1 = FOLDER1_BBOARD(3:TRIM(FOLDER1_BBOARD))//'::'// + & FOLDER1 + FOLDER1_NUMBER = -1 + REMOTE_SET = 1 + ELSE IF (NEWS) THEN + REMOTE_SET = 3 + CALL OPEN_BULLNEWS_SHARED ! Update local folder information + IF (IER.NE.0) CALL NEWS_NEW_FOLDER + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + IF ((F1_START.NE.F_START.OR.F1_NBULL.NE.F_NBULL).AND. + & F1_START.GT.0) THEN + IF (F1_NBULL.NE.F_NBULL) CALL SYS_BINTIM('-',F_NEWEST_BTIM) + F_NBULL = F1_NBULL + F_START = F1_START + CALL REWRITE_FOLDER_FILE + END IF + CALL CLOSE_BULLFOLDER + ELSE ! True remote folder + FOLDER1_DESCRIP = LOCAL_FOLDER1_DESCRIP ! Use local description + IF (BTEST(FOLDER1_FLAG,0)) THEN ! Copy remote folder protection + LOCAL_FOLDER1_FLAG = IBSET(LOCAL_FOLDER1_FLAG,0) + ELSE + LOCAL_FOLDER1_FLAG = IBCLR(LOCAL_FOLDER1_FLAG,0) + END IF + FOLDER1_FLAG = LOCAL_FOLDER1_FLAG ! Use local flag info + CALL OPEN_BULLFOLDER ! Update local folder information + CALL READ_FOLDER_FILE_KEYNAME(FOLDER1,IER) + OLD_NEWEST_BTIM(1) = F_NEWEST_BTIM(1) + OLD_NEWEST_BTIM(2) = F_NEWEST_BTIM(2) + FOLDER_COM = FOLDER1_COM + CALL REWRITE_FOLDER_FILE + CALL CLOSE_BULLFOLDER + REMOTE_SET = 1 + DIFF = COMPARE_BTIM(OLD_NEWEST_BTIM,F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN + CALL READ_NOTIFY + IF (TEST2(NOTIFY_REMOTE,FOLDER_NUMBER)) THEN + CALL NOTIFY_REMOTE_USERS(OLD_NEWEST_BTIM) + END IF + END IF + END IF + END IF + + IF (IER.EQ.0) THEN ! Folder found + FLAG1_ACCESS = .TRUE. + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + IF (BTEST(FOLDER1_FLAG,0).AND. ! Folder protected + & FOLDER1_BBOARD(:2).NE.'::') THEN ! and not remote? + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER1_OWNER) THEN + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + IF (SETPRV_PRIV().AND.READIT.EQ.0) THEN + IF (.NOT.READ_ACCESS) FLAG1_ACCESS = .FALSE. + READ_ACCESS = 1 + WRITE_ACCESS = 1 + END IF + IF (.NOT.READ_ACCESS.AND..NOT.WRITE_ACCESS) THEN + IF (OUTPUT) THEN + WRITE(6,'('' You are not allowed to access folder.'')') + WRITE(6,'('' See '',A,'' if you wish to access folder.'')') + & FOLDER1_OWNER(:TRIM(FOLDER1_OWNER)) + ELSE IF (TEST2(BRIEF_FLAG,FOLDER1_NUMBER).OR. + & TEST2(SET_FLAG,FOLDER1_NUMBER)) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + CALL CLR2(BRIEF_FLAG,FOLDER1_NUMBER) + CALL CLR2(SET_FLAG,FOLDER1_NUMBER) + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + CALL CLOSE_BULLUSER + END IF + IER = 0 + RETURN + END IF + ELSE IF (BTEST(FOLDER1_FLAG,0).AND. + & IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CALL OPEN_BULLFOLDER + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER1) + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + ELSE ! Folder not protected + IER = SS$_ACLEMPTY.OR.SS$_NORMAL ! Indicate folder selected + END IF + + IF (FOLDER1_BBOARD(:2).NE.'::') THEN + IF (REMOTE_SET) CLOSE(UNIT=REMOTE_UNIT) + REMOTE_SET = .FALSE. + END IF + + IF (IER) THEN + FLAG_ACCESS = FLAG1_ACCESS ! Can set flags? + + FOLDER_COM = FOLDER1_COM ! Folder successfully set so + FOLDER_FILE = FOLDER1_FILE ! update folder parameters + + IF (FOLDER_NUMBER.NE.0) THEN + FOLDER_SET = .TRUE. + ELSE + FOLDER_SET = .FALSE. + END IF + + IF (REMOTE_SET.LT.3) THEN + FOLDER_NAME = FOLDER + HEADER = .NOT.BTEST(FOLDER_FLAG,4) + ELSE + HEADER = .FALSE. + FOLDER_NAME = FOLDER_DESCRIP + FOLDER_NUMBER = -1 + END IF + + IF (REMOTE_SET.EQ.0) THEN + SLIST = INDEX(FOLDER_DESCRIP,'<') + IF (SLIST.GT.0.AND. + & FOLDER_DESCRIP(SLIST+1:SLIST+1).EQ.'@') THEN + REMOTE_SET = 4 + ELSE IF (SLIST.GT.0) THEN + I = SLIST + 1 + FLEN = TRIM(FOLDER_DESCRIP) + DO WHILE (I.LE.FLEN) + IF ((FOLDER_DESCRIP(I:I).GE.'a'.AND. + & FOLDER_DESCRIP(I:I).LE.'z').OR. + & FOLDER_DESCRIP(I:I).EQ.'.') THEN + I = I + 1 + ELSE IF (FOLDER_DESCRIP(I:I).EQ.'>') THEN + I = FLEN + 1 + ELSE + I = FLEN + 2 + END IF + END DO + IF (I.EQ.FLEN+1) REMOTE_SET = 4 + END IF + IF (OUTPUT.AND.INCMD(:3).NE.'DIR'.AND. + & REMOTE_SET.EQ.0.AND.SLIST.GT.0) THEN + WRITE (6,'('' Use the POST command to send a '', + & ''message to this folder''''s mailing list.'')') + END IF + END IF + + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + WRITE (6,'('' Folder has been set to '',A)') + & FOLDER_NAME(:TRIM(FOLDER_NAME))//'.' + END IF + + IF (OUTPUT) THEN + IF (REMOTE_SET.EQ.3) THEN + BULL_POINT = F_START - 1 + ELSE + BULL_POINT = 0 ! Reset pointer to first bulletin + END IF + END IF + + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.USERNAME + & .NE.FOLDER_OWNER) THEN + IF (.NOT.WRITE_ACCESS) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR'.AND.SLIST.EQ.0) THEN + WRITE (6,'('' Folder only accessible for reading.'')') + END IF + READ_ONLY = .TRUE. + ELSE + READ_ONLY = .FALSE. + END IF + ELSE + READ_ONLY = .FALSE. + END IF + + IF (FOLDER_NUMBER.GT.0) THEN + IF (TEST_BULLCP().GT.0.OR.REMOTE_SET) THEN + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + ELSE IF (.NOT.TEST2(FIRST_TIME,FOLDER_NUMBER)) THEN + ! If first select, look for expired messages. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) ! Get header info from BULLDIR.DAT + IF (IER.EQ.1) THEN ! Is header present? + IER = COMPARE_DATE(NEWEST_EXDATE,' ') ! Yes. Any expired? + IF (SHUTDOWN.GT.0.AND.NODE_AREA.GT.0.AND. + & (FOLDER_NUMBER.EQ.0.OR.BTEST(FOLDER_FLAG,2)) + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ! Do shutdown bulletins exist? + SHUTDOWN = 0 + IER1 = -1 + ELSE + IF (TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL UPDATE_SHUTDOWN(FOLDER_NUMBER) + END IF + IER1 = 1 + END IF + IF (IER.LE.0.OR.IER.GT.20*356.OR.IER1.LE.0) THEN + CALL UPDATE ! Need to update + END IF + ELSE + NBULL = 0 + END IF + CALL CLOSE_BULLDIR + CALL SET2(FIRST_TIME,FOLDER_NUMBER) + END IF + END IF + + IF (OUTPUT) THEN + IF (CLI$PRESENT('MARKED')) THEN + READ_TAG = 1 + IBSET(0,1) + BULL_PARAMETER = 'MARKED' + ELSE IF (CLI$PRESENT('SEEN')) THEN + READ_TAG = 1 + IBSET(0,2) + BULL_PARAMETER = 'SEEN' + ELSE IF (CLI$PRESENT('UNMARKED').OR.CLI$PRESENT + & ('MARKED').EQ.%LOC(CLI$_NEGATED)) THEN + READ_TAG = 1 + IBSET(0,1) + IBSET(0,3) + BULL_PARAMETER = 'UNMARKED' + ELSE IF (CLI$PRESENT('UNSEEN').OR.CLI$PRESENT + & ('SEEN').EQ.%LOC(CLI$_NEGATED)) THEN + READ_TAG = 1 + IBSET(0,2) + IBSET(0,3) + BULL_PARAMETER = 'UNSEEN' + ELSE + READ_TAG = IBSET(0,1) + IBSET(0,2) + END IF + IF (READ_TAG) THEN + IF (FOLDER_NUMBER.GE.0.OR.REMOTE_SET.EQ.3) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + ELSE + WRITE (6,'('' ERROR: Invalid qualifier'', + & '' with remote folder.'')') + READ_TAG = IBSET(0,1) + IBSET(0,2) + END IF + END IF + IF (READ_TAG.AND.INCMD(:3).NE.'DIR') THEN + IF (IER.EQ.0) THEN + WRITE(6,'('' NOTE: Only '',A,'' messages'', + & '' will be shown.'')') + & BULL_PARAMETER(:TRIM(BULL_PARAMETER)) + ELSE + WRITE(6,'('' WARNING: No '',A, + & '' messages found.'')') + & BULL_PARAMETER(:TRIM(BULL_PARAMETER)) + END IF + END IF + END IF + + IF (REMOTE_SET.EQ.3.AND.OUTPUT.AND..NOT.READ_TAG) THEN + CALL NEWS_GET_NEWEST_MESSAGE(IER) + IF (IER.GT.0.AND.IER.LE.F_NBULL) THEN + BULL_POINT = IER - 1 + WRITE(6,'('' Type READ to read new messages.'')') + END IF + ELSE IF (FOLDER_NUMBER.NE.0.AND..NOT.READ_TAG.AND. + & REMOTE_SET.NE.3) THEN + IF (OUTPUT.AND.INCMD(:3).NE.'DIR') THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN ! If new unread messages + CALL FIND_NEWEST_BULL ! See if we can find it + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + END IF + END IF + END IF + END IF + IER = 1 + ELSE IF (OUTPUT) THEN + WRITE (6,'('' Cannot access specified folder.'')') + CALL SYS_GETMSG(IER) + END IF + ELSE ! Folder not found + IF (OUTPUT) WRITE (6,'('' ERROR: Folder does not exist.'')') + IER = 0 + END IF + + RETURN + + END + + + + + + SUBROUTINE UPDATE_FOLDER +C +C SUBROUTINE UPDATE_FOLDER +C +C FUNCTION: Updates folder info due to new message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + IF (FOLDER_NUMBER.LT.0) RETURN + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + + F_NBULL = NBULL + + IF (FOLDER_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + + IF (.NOT.BTEST(SYSTEM,0)) THEN ! Is non-system message? + F_NEWEST_NOSYS_BTIM(1) = F_NEWEST_BTIM(1) ! If so, update latest + F_NEWEST_NOSYS_BTIM(2) = F_NEWEST_BTIM(2) ! system time. + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + RETURN + END + + + + SUBROUTINE SHOW_FOLDER +C +C SUBROUTINE SHOW_FOLDER +C +C FUNCTION: Shows the information on any folder. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + COMMON /BULL_PERM/ SET_PERM_FLAG,BRIEF_PERM_FLAG,NOTIFY_PERM_FLAG + DIMENSION SET_PERM_FLAG(FLONG) + DIMENSION BRIEF_PERM_FLAG(FLONG) + DIMENSION NOTIFY_PERM_FLAG(FLONG) + + INCLUDE '($SSDEF)' + + INCLUDE '($RMSDEF)' + + EXTERNAL CLI$_ABSENT + + IF (INDEX(INCMD,'/A').GT.0.OR.INDEX(INCMD,'/a').GT.0) THEN + WRITE (6,'('' ERROR: /ALL is invalid qualifier.'')') + RETURN + END IF + + IF (CLI$GET_VALUE('SHOW_FOLDER',FOLDER1).EQ.%LOC(CLI$_ABSENT)) + & FOLDER1 = FOLDER + + IF (INDEX(FOLDER1,'::').NE.0.OR.REMOTE_SET.EQ.3) THEN + WRITE (6,'('' ERROR: Invalid command for remote folder.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER_SHARED ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Specified folder was not found.'')') + CALL CLOSE_BULLFOLDER + RETURN + ELSE IF (FOLDER.EQ.FOLDER1) THEN + WRITE (6,1000) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + ELSE + WRITE (6,1010) FOLDER1,FOLDER1_OWNER, + & FOLDER1_DESCRIP(:TRIM(FOLDER1_DESCRIP)) + END IF + + IF (CLI$PRESENT('FULL')) THEN + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL).OR.(.NOT.IER)) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::'.AND. ! Is folder remote + & BTEST(FOLDER1_FLAG,0)) THEN ! and private? + WRITE (6,'('' Folder is a private folder.'')') + ELSE + WRITE (6,'('' Folder is not a private folder.'')') + END IF + ELSE + IF (SETPRV_PRIV()) THEN + READ_ACCESS = 1 + WRITE_ACCESS = 1 + ELSE + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,WRITE_ACCESS) + END IF + IF (WRITE_ACCESS) + & CALL SHOWACL(FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL') + END IF + IF (FOLDER_ACCESS(USERNAME,FOLDER1_FLAG,FOLDER1_OWNER)) THEN + IF (FOLDER1_BBOARD(:2).EQ.'::') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (INDEX(FOLDER1_BBOARD,'*').EQ.0) THEN + WRITE (6,'('' Folder is located on node '', + & A,''.'')') FOLDER1_BBOARD(3:FLEN) + ELSE + FOLDER1_FILE = FOLDER_FILE + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + REMOTE_SET_SAVE = REMOTE_SET + REMOTE_SET = .FALSE. + CALL OPEN_BULLDIR + CALL READDIR(0,IER) + CALL CLOSE_BULLDIR + REMOTE_SET = REMOTE_SET_SAVE + WRITE (6,'('' Folder is located on node '', + & A,''. Remote folder name is '',A,''.'')') + & FOLDER1_BBOARD(3:FLEN-1), + & BULLDIR_HEADER(13:TRIM(BULLDIR_HEADER)) + END IF + ELSE IF (FOLDER1_BBOARD.NE.'NONE') THEN + FLEN = TRIM(FOLDER1_BBOARD) + IF (FLEN.GT.0) THEN + WRITE (6,'('' BBOARD for folder is '',A,''.'')') + & FOLDER1_BBOARD(:FLEN) + END IF + IF ((USERB1.EQ.0.AND.GROUPB1.EQ.0).OR.BTEST(USERB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /SPECIAL.'')') + IF (BTEST(GROUPB1,31)) THEN + WRITE (6,'('' BBOARD was specified with /VMSMAIL.'')') + END IF + END IF + ELSE + WRITE (6,'('' No BBOARD has been defined.'')') + END IF + IF (FOLDER1_BBEXPIRE.GT.0) THEN + WRITE (6,'('' Default expiration is '',I3,'' days.'')') + & FOLDER1_BBEXPIRE + ELSE IF (FOLDER1_BBEXPIRE.EQ.-1) THEN + WRITE (6,'('' Default expiration is permanent.'')') + ELSE + WRITE (6,'('' No default expiration set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,2)) THEN + WRITE (6,'('' SYSTEM has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,1)) THEN + WRITE (6,'('' DUMP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,3)) THEN + WRITE (6,'('' NOPROMPT_EXPIRE has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,4)) THEN + WRITE (6,'('' STRIP has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,5)) THEN + WRITE (6,'('' DIGEST has been set.'')') + END IF + IF (BTEST(FOLDER1_FLAG,7)) THEN + WRITE (6,'('' ALWAYS has been set.'')') + END IF + IF (F1_EXPIRE_LIMIT.GT.0) THEN + WRITE (6,'('' EXPIRATION limit is '',I3,'' days.'')') + & F1_EXPIRE_LIMIT + END IF + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_HEADER(IER) + CALL READ_PERM + PERM = .FALSE. + IF (TEST2(SET_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER).AND. + & TEST2(SET_PERM_FLAG,FOLDER1_NUMBER)) THEN + PERM = .TRUE. + WRITE (6,'('' Default is BRIEF, which is permanent.'')') + ELSE + WRITE (6,'('' Default is BRIEF.'')') + END IF + ELSE + IF (TEST2(SET_PERM_FLAG,FOLDER1_NUMBER).AND. + & .NOT.TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER)) THEN + PERM = .TRUE. + WRITE (6,'('' Default is READNEW, which is permanent.'')') + ELSE + WRITE (6,'('' Default is READNEW.'')') + END IF + END IF + ELSE + IF (TEST2(BRIEF_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER).AND. + & .NOT.TEST2(SET_PERM_FLAG,FOLDER1_NUMBER)) THEN + PERM = .TRUE. + WRITE (6,'('' Default is SHOWNEW, which is permanent.'')') + ELSE + WRITE (6,'('' Default is SHOWNEW.'')') + END IF + END IF + END IF + IF (.NOT.PERM) THEN + IF (TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER).AND. + & TEST2(SET_PERM_FLAG,FOLDER1_NUMBER)) THEN + WRITE (6,'('' BRIEF is the permanent setting.'')') + ELSE IF (TEST2(SET_PERM_FLAG,FOLDER1_NUMBER).AND. + & .NOT.TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER)) THEN + WRITE (6,'('' READNEW is the permanent setting.'')') + ELSE IF (TEST2(BRIEF_PERM_FLAG,FOLDER1_NUMBER).AND. + & .NOT.TEST2(SET_PERM_FLAG,FOLDER1_NUMBER)) THEN + WRITE (6,'('' SHOWNEW is the permanent setting.'')') + END IF + END IF + IF (TEST2(NOTIFY_FLAG_DEF,FOLDER1_NUMBER)) THEN + IF (TEST2(NOTIFY_PERM_FLAG,FOLDER1_NUMBER)) THEN + WRITE (6,'('' Default is NOTIFY, which is permanent.'')') + ELSE + WRITE (6,'('' Default is NOTIFY.'')') + END IF + ELSE + WRITE (6,'('' Default is NONOTIFY.'')') + END IF + CALL CLOSE_BULLUSER + END IF + END IF + + CALL CLOSE_BULLFOLDER + + RETURN + +1000 FORMAT(' Current folder is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) +1010 FORMAT(' Folder name is: ',A25,' Owner: ',A12, + & ' Description: ',/,1X,A) + END + + + SUBROUTINE DIRECTORY_FOLDERS(FOLDER_COUNT) +C +C SUBROUTINE DIRECTORY_FOLDERS +C +C FUNCTION: Display all FOLDER entries. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + LOGICAL PAGING + + COMMON /CTRLC_FLAG/ FLAG + + DATA SCRATCH_D1/0/ + + CHARACTER*80 FOLDER_MATCH + + CHARACTER*17 DATETIME + + INTEGER*2 MLEN,FLEN + + IF (CLI$PRESENT('NEWS')) THEN + IF (SYS_TRNLNM('BULL_NEWS_SERVER','DEFINED')) THEN + CALL OPEN_BULLNEWS_SHARED + ELSE + WRITE (6,'('' ERROR: NEWS connection is not present.'')') + RETURN + END IF + ELSE + CALL OPEN_BULLFOLDER_SHARED ! Get folder file + END IF + + IF (FOLDER_COUNT.EQ.0) THEN + SUBSCRIBE = .FALSE. + NEW = .FALSE. + FOLDER_COUNT = 1 ! Init folder number counter + NLINE = 1 + START = .FALSE. + IF (.NOT.CLI$PRESENT('NEWS')) THEN + NEWS = .FALSE. + IF (CLI$PRESENT('DESCRIBE')) THEN + NLINE = 2 ! Include folder descriptor if /DESCRIBE + END IF + ELSE + NEWS = .TRUE. + CALL READ_FOLDER_FILE_KEYNAME_TEMP('a',IER) + IF (IER.NE.0) THEN + WRITE (6,'('' Fetching NEWS groups from remote node.'' + & ,'' This will take several minutes.'')') + WRITE (6,'('' This is the only time this will have'' + & ,'' to be done.'')') + CALL CLOSE_BULLFOLDER + CALL NEWS_LIST + CALL OPEN_BULLNEWS_SHARED + CALL READ_FOLDER_FILE_KEYNAME_TEMP('a',IER) + END IF + SUBSCRIBE = CLI$PRESENT('SUBSCRIBE') + NEW = CLI$PRESENT('NEWGROUPS') + IF (NEW) NEW_NEWS = LAST_NEWS_READ(1,FOLDER_MAX) + IF (SUBSCRIBE) THEN + CALL NEWS_GET_SUBSCRIBE(0,F1_END) + SUBNUM = 1 + END IF + END IF + IF (CLI$GET_VALUE('START',FOLDER1,FLEN)) THEN + IF (NEWS) CALL LOWERCASE(FOLDER1) + CALL READ_FOLDER_FILE_KEYNAMEGE_TEMP(FOLDER1(:FLEN),IER) + IF (IER.NE.0) THEN + WRITE (6,'('' There are no folders.'')') + CALL CLOSE_BULLFOLDER + FOLDER_COUNT = -1 + RETURN + ELSE + START = .TRUE. + END IF + END IF + MATCH = CLI$GET_VALUE('MATCH_FOLDER',FOLDER_MATCH,MLEN) + IF (MATCH.AND.NEWS) CALL LOWERCASE(FOLDER_MATCH) + IF (MATCH.AND.INDEX(FOLDER_MATCH,'*').EQ.0) THEN + FOLDER_MATCH = '*'//FOLDER_MATCH(:MLEN)//'*' + MLEN = MLEN + 2 + END IF + ELSE IF (SUBSCRIBE.AND.PAGING.AND.MORE) THEN + SUBNUM = -2 + ELSE + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + END IF + +C +C Folder listing is first buffered into temporary memory storage before +C being outputted to the terminal. This is to be able to quickly close the +C folder file, and to avoid the possibility of the user holding the screen, +C and thus causing the folder file to stay open. The temporary memory +C is structured as a linked-list queue, where SCRATCH_D1 points to the header +C of the queue. +C + CALL INIT_QUEUE(SCRATCH_D1,FOLDER1_COM) + SCRATCH_D = SCRATCH_D1 + + CALL DECLARE_CTRLC_AST + + NUM_FOLDER = 0 + IER = 0 + IER1 = 0 + MORE = .FALSE. + DO WHILE (IER.EQ.0.AND.IER1.EQ.0) + IF (SUBSCRIBE) THEN + IER = 1 + DO WHILE (SUBNUM.NE.0.AND.IER.NE.0) + CALL NEWS_GET_SUBSCRIBE(SUBNUM,MSGNUM) + IF (SUBNUM.NE.0) THEN + CALL READ_FOLDER_FILE_KEYNUM_TEMP(SUBNUM,IER) + IF (IER.NE.0) SUBNUM = -1 + END IF + END DO + F1_END = MSGNUM + IF (SUBNUM.EQ.0) IER = 1 + ELSE IF (START) THEN + START = .FALSE. + ELSE IF (NEW) THEN + CALL READ_FOLDER_FILE_KEYNUM_GT_TEMP(NEW_NEWS,IER) + IF (IER.EQ.0) THEN + NEW_NEWS = FOLDER1_NUMBER + ELSE + CALL READ_FOLDER_FILE_KEYNAME_TEMP('a',IER2) + NEW_NEWS = NEWS_F1_END + END IF + ELSE + CALL READ_FOLDER_FILE_TEMP(IER) + END IF + IF (IER.EQ.0) THEN + IF (INDEX(FOLDER1_BBOARD,'::').EQ.0.AND. + & BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + IF (.NOT.MATCH) THEN + NUM_FOLDER = NUM_FOLDER + 1 + CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + ELSE IF (STR$MATCH_WILD(FOLDER1_DESCRIP + & (:TRIM(FOLDER1_DESCRIP)),FOLDER_MATCH(:MLEN))) THEN + GO TO 100 + END IF + END IF + IF (PAGING.AND.NUM_FOLDER*NLINE+2.GT.PAGE_LENGTH-4) THEN + IER1 = 1 + MORE = .TRUE. + END IF + END IF + IF (FLAG.EQ.1) IER1 = 1 + END DO + + IF (MATCH) MATCH = .FALSE. + + CALL CANCEL_CTRLC_AST + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + IF (FLAG.EQ.1) THEN + WRITE (6,'('' Folder search aborted.'')') + FOLDER_COUNT = -1 + RETURN + END IF + + IF (NUM_FOLDER.EQ.0) THEN + WRITE (6,'('' There are no folders.'')') + FOLDER_COUNT = -1 + IF (NEW) LAST_NEWS_READ(1,FOLDER_MAX) = NEW_NEWS + RETURN + END IF + +C +C Folder entries are now in queue. Output queue entries to screen. +C + + SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header + +100 CALL LIB$ERASE_PAGE(1,1) ! Clear the screen + + IF (.NOT.NEWS) THEN + WRITE (6,'(1X,''Folder'',22X,''Last message'',7X,''Messages'', + & 2X,''Owner'',/,1X,80(''-''))') + ELSE + WRITE (6,'(1X,''Folder'',X, + & ''First Last'',/,1X,(''-''))') + END IF + + IF (PAGING.AND.MORE) NUM_FOLDER = NUM_FOLDER - 1 + + I = 1 + DO WHILE ((I.LE.NUM_FOLDER.OR.MATCH).AND.FLAG.NE.1) + IF (.NOT.MATCH) THEN + CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,FOLDER1_COM) + I = I + 1 + END IF + IF (.NOT.NEWS) THEN + DIFF = COMPARE_BTIM + & (LAST_READ_BTIM(1,FOLDER1_NUMBER+1),F1_NEWEST_BTIM) + IF (F1_NBULL.GT.0) THEN + CALL SYS$ASCTIM(,DATETIME,F1_NEWEST_BTIM,) + ELSE + DATETIME = ' NONE' + END IF + IF (DIFF.GE.0.OR.F1_NBULL.EQ.0) THEN + WRITE (6,1000) ' '//FOLDER1,DATETIME,F1_NBULL, + & FOLDER1_OWNER + ELSE + WRITE (6,1000) '*'//FOLDER1,DATETIME,F1_NBULL, + & FOLDER1_OWNER + END IF + ELSE + FLEN = MIN(80,PAGE_WIDTH-80+56) + IF (SUBSCRIBE) FLEN = MIN(81,PAGE_WIDTH-80+55) + IF (F1_START.LE.F1_NBULL) THEN + IF (SUBSCRIBE) THEN + IF (F1_END.LT.F1_NBULL.AND.F1_NBULL.GT.0) THEN + WRITE (6,1005) '*'//FOLDER1_DESCRIP(:FLEN-1) + & ,F1_START,F1_NBULL + ELSE + WRITE (6,1005) ' '//FOLDER1_DESCRIP(:FLEN-1) + & ,F1_START,F1_NBULL + END IF + ELSE + WRITE (6,1005) FOLDER1_DESCRIP(:FLEN) + & ,F1_START,F1_NBULL + END IF + ELSE IF (SUBSCRIBE) THEN + WRITE (6,1005) ' '//FOLDER1_DESCRIP(:FLEN-1),0,0 + ELSE + WRITE (6,1005) FOLDER1_DESCRIP(:FLEN),0,0 + END IF + END IF + IF (NLINE.EQ.2) WRITE (6,'(1X,A)') FOLDER1_DESCRIP + IF (MATCH.AND.FLAG.NE.1) THEN + NUM_FOLDER = NUM_FOLDER + 1 + IF (PAGING.AND. + & NUM_FOLDER*NLINE+2.GE.PAGE_LENGTH-4) MORE = .TRUE. + FOUND = .FALSE. + DO WHILE (FLAG.NE.1.AND.IER.EQ.0.AND..NOT.FOUND) + CALL READ_FOLDER_FILE_TEMP(IER) + IF (IER.EQ.0.AND.STR$MATCH_WILD(FOLDER1_DESCRIP + & (:TRIM(FOLDER1_DESCRIP)),FOLDER_MATCH(:MLEN))) THEN + FOUND = .TRUE. + END IF + END DO + MORE = MORE.AND.FOUND + FOUND = FOUND.AND..NOT.MORE + IF (.NOT.FOUND) FLAG = 1 + END IF + END DO + + IF (MATCH) THEN + CALL CANCEL_CTRLC_AST + CALL CLOSE_BULLFOLDER + END IF + + IF (IER.NE.0.AND..NOT.MORE) THEN ! Outputted all entries? + FOLDER_COUNT = -1 ! Yes. Set counter to -1. + IF (NEW) LAST_NEWS_READ(1,FOLDER_MAX) = NEW_NEWS + ELSE + WRITE(6,1100) ! Else say there are more + END IF + + RETURN + +1000 FORMAT(1X,A26,2X,A17,2X,I8,2X,A12) +1005 FORMAT(1X,A,X,I10,' ',I10) +1100 FORMAT(1X,/,' Press RETURN for more...',/) + + END + + + SUBROUTINE SET_ACCESS(ACCESS) +C +C SUBROUTINE SET_ACCESS +C +C FUNCTION: Set access on folder for specified ID. +C +C PARAMETERS: +C ACCESS - Logical: If .true., grant access, if .false. deny access +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + LOGICAL ACCESS,ALL,READONLY + + EXTERNAL CLI$_ABSENT + + CHARACTER ID*64,RESPONSE*1 + + CHARACTER INPUT*132 + + IF (CLI$PRESENT('ALL')) THEN + ALL = .TRUE. + ELSE + ALL = .FALSE. + END IF + + IF (CLI$PRESENT('READONLY')) THEN + READONLY = .TRUE. + ELSE + READONLY = .FALSE. + END IF + + IER = CLI$GET_VALUE('ACCESS_FOLDER',FOLDER1,LEN) ! Get folder name + + IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN + FOLDER1 = FOLDER + ELSE IF (LEN.GT.25) THEN + WRITE(6,'('' ERROR: Folder name must be < 26 characters.'')') + RETURN + END IF + + CALL OPEN_BULLFOLDER ! Open folder file + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) ! See if it exists + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder exists.'')') + ELSE IF (.NOT.FOLDER_ACCESS(USERNAME,FOLDER1_FLAG,FOLDER1_OWNER)) THEN + WRITE (6, + & '('' ERROR: You are not able to modify access to the folder.'')') + ELSE + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER1 + CALL CHKACL + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + IF ((ALL.AND..NOT.READONLY).OR.(.NOT.ACCESS)) THEN + WRITE (6,'('' ERROR: Folder is not a private folder.'')') + RETURN + END IF + CALL GET_INPUT_PROMPT(RESPONSE,LEN, + & 'Folder is not private. Do you want to make it so? (Y/N): ') + IF (RESPONSE.NE.'y'.AND.RESPONSE.NE.'Y') THEN + WRITE (6,'('' Folder access was not changed.'')') + RETURN + ELSE + FOLDER1_FLAG = IBSET(FOLDER1_FLAG,0) + IF (READONLY.AND.ALL) THEN + CALL ADD_ACL('*','R',IER) + ELSE + CALL ADD_ACL('*','NONE',IER) + END IF + CALL ADD_ACL(FOLDER1_OWNER,'R+W+C',IER) + IF (ALL) THEN ! All finished, so exit + WRITE (6,'('' Access to folder has been modified.'')') + GOTO 100 + END IF + END IF + END IF + + IF (ALL) THEN + IF (ACCESS) THEN + CALL DEL_ACL(' ','R+W',IER) + IF (READONLY) THEN + CALL ADD_ACL('*','R',IER) + ELSE + FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) + END IF + ELSE + CALL DEL_ACL('*','R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access.'')') + CALL SYS_GETMSG(IER) + END IF + END IF + + DO WHILE (CLI$GET_VALUE('ACCESS_ID',INPUT,ILEN) + & .NE.%LOC(CLI$_ABSENT).AND..NOT.ALL) + IER = SYS_TRNLNM(INPUT,INPUT) + IF (INPUT(:1).EQ.'@') THEN + ILEN = INDEX(INPUT,',') - 1 + IF (ILEN.EQ.-1) ILEN = TRIM(INPUT) + OPEN (UNIT=3,STATUS='OLD',FILE=INPUT(2:ILEN), + & DEFAULTFILE='.DIS',IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Cannot find file '',A)') + & INPUT(2:ILEN) + RETURN + END IF + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + ELSE + FILE_OPEN = .TRUE. + END IF + ELSE + FILE_OPEN = .FALSE. + END IF + DO WHILE (TRIM(INPUT).GT.0) + COMMA = INDEX(INPUT,',') + IF (INPUT(:1).EQ.'[') COMMA = INDEX(INPUT,']') + 1 + IF (INPUT(:1).EQ.'"') COMMA = INDEX(INPUT(2:),'"') + 2 + IF (COMMA.GT.0) THEN + ID = INPUT(1:COMMA-1) + INPUT = INPUT(COMMA+1:) + ELSE + ID = INPUT + INPUT = ' ' + END IF + ILEN = TRIM(ID) + IF (ID.EQ.FOLDER1_OWNER) THEN + WRITE (6,'('' ERROR: Cannot modify access'', + & '' for owner of folder.'')') + ELSE + IF (ACCESS) THEN + IF (READONLY) THEN + CALL ADD_ACL(ID,'R',IER) + ELSE + CALL ADD_ACL(ID,'R+W',IER) + END IF + ELSE + CALL DEL_ACL(ID,'R+W',IER) + IF (.NOT.IER) CALL DEL_ACL(ID,'R',IER) + END IF + IF (.NOT.IER) THEN + WRITE(6,'('' Cannot modify access for '',A, + & ''.'')') ID(:ILEN) + CALL SYS_GETMSG(IER) + ELSE + WRITE(6,'('' Access modified for '',A,''.'')') + & ID(:ILEN) + END IF + END IF + IF (TRIM(INPUT).EQ.0.AND.FILE_OPEN) THEN + READ (3,'(A)',IOSTAT=IER) INPUT + IF (IER.NE.0) THEN + CLOSE (UNIT=3) + INPUT = ' ' + FILE_OPEN = .FALSE. + END IF + END IF + END DO + END DO + +100 IF (OLD_FOLDER1_FLAG.NE.FOLDER1_FLAG) THEN + CALL OPEN_BULLFOLDER ! Open folder file + OLD_FOLDER1_FLAG = FOLDER1_FLAG + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + FOLDER1_FLAG = OLD_FOLDER1_FLAG + CALL REWRITE_FOLDER_FILE_TEMP + CALL CLOSE_BULLFOLDER + END IF + END IF + + RETURN + + END + + + + SUBROUTINE CHKACL(FILENAME,IERACL) +C +C SUBROUTINE CHKACL +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C IERACL - Error returned for attempt to open file. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) FILENAME + + INCLUDE '($ACLDEF)' + INCLUDE '($SSDEF)' + + CHARACTER*255 ACLENT,ACLSTR + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(255,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IERACL=SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + IF (IERACL.EQ.SS$_ACLEMPTY) THEN + IERACL = SS$_NORMAL.OR.IERACL + END IF + + RETURN + END + + + + SUBROUTINE CHECK_ACCESS(FILENAME,USERNAME,READ_ACCESS,WRITE_ACCESS) +C +C SUBROUTINE CHECK_ACCESS +C +C FUNCTION: Checks ACL of given file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C USERNAME - Name of user to check access for. +C READ_ACCESS - Error returned indicating read access. +C WRITE_ACCESS - Error returned indicating write access. +C If initially set to -1, indicates just +C folder for read access. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER FILENAME*(*),USERNAME*(*),ACE*255,OUTPUT*80 + + INCLUDE '($ACLDEF)' + INCLUDE '($CHPDEF)' + INCLUDE '($ARMDEF)' + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,CHP$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(4,CHP$_ACCESS,%LOC(ACCESS)) + CALL ADD_2_ITMLST(LEN(ACE),CHP$_MATCHEDACE,%LOC(ACE)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + FLAGS = 0 ! Default is no access + + ACCESS = ARM$M_READ ! Check if user has read access + READ_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + + IF (ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'READ').EQ.0) READ_ACCESS = 0 + ELSE IF (ICHAR(ACE(:1)).EQ.0.AND.READ_ACCESS) THEN + READ_ACCESS = 0 + END IF + + IF (WRITE_ACCESS.EQ.-1) THEN ! Only check read access + RETURN + ELSE IF (READ_ACCESS.EQ.0) THEN ! If no read access, then of + WRITE_ACCESS = 0 ! course there is no write access. + RETURN + END IF + + ACCESS = ARM$M_WRITE ! Check if user has write access + WRITE_ACCESS=SYS$CHECK_ACCESS(ACL$C_FILE,FILENAME,USERNAME, + & %VAL(ACL_ITMLST)) + + IF (ICHAR(ACE(:1)).NE.0) THEN + CALL SYS$FORMAT_ACL(ACE,,OUTPUT,,,,) + IF (INDEX(OUTPUT,'=*').NE.0.AND. + & INDEX(OUTPUT,'WRITE').EQ.0) WRITE_ACCESS = 0 + ELSE IF (ICHAR(ACE(:1)).EQ.0.AND.WRITE_ACCESS) THEN + WRITE_ACCESS = 0 + END IF + + RETURN + END + + + + + SUBROUTINE SHOWACL(FILENAME) +C +C SUBROUTINE SHOWACL +C +C FUNCTION: Shows users who are allowed to read private bulletin. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER*(*) FILENAME + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + CALL LIB$GET_VM(ACLLENGTH+8,ACLSTR) + CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) + + CALL READACL(FILENAME,%VAL(ACLSTR),ACLLENGTH) + + RETURN + END + + + + SUBROUTINE FOLDER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLFOLDER.INC' + + COMMON /NEWS_OPEN/ NEWS_OPEN + + ENTRY WRITE_FOLDER_FILE(IER) + + IF (NEWS_OPEN) CALL FOLDER_TO_NEWS + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + WRITE (7,IOSTAT=IER) NEWS_FOLDER_COM + ELSE + WRITE (7,IOSTAT=IER) FOLDER_COM + END IF + END DO + + RETURN + + ENTRY REWRITE_FOLDER_FILE + + IF (NEWS_OPEN) THEN + CALL FOLDER_TO_NEWS + REWRITE (7,IOSTAT=IER) NEWS_FOLDER_COM + ELSE + REWRITE (7,IOSTAT=IER) FOLDER_COM + END IF + + RETURN + + ENTRY REWRITE_FOLDER_FILE_TEMP + + IF (NEWS_OPEN) THEN + CALL FOLDER1_TO_NEWS + REWRITE (7,IOSTAT=IER) NEWS_FOLDER1_COM + ELSE + REWRITE (7,IOSTAT=IER) FOLDER1_COM + END IF + + RETURN + + ENTRY READ_FOLDER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + READ (7,IOSTAT=IER) NEWS_FOLDER_COM + ELSE + READ (7,IOSTAT=IER) FOLDER_COM + END IF + END DO + + IF (NEWS_OPEN.AND.IER.EQ.0) CALL NEWS_TO_FOLDER + + RETURN + + ENTRY READ_FOLDER_FILE_TEMP(IER) + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + READ (7,IOSTAT=IER) NEWS_FOLDER1_COM + ELSE + READ (7,IOSTAT=IER) FOLDER1_COM + END IF + END DO + + IF (NEWS_OPEN.AND.IER.EQ.0) CALL NEWS_TO_FOLDER1 + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM(KEY_NUMBER,IER) + + SAVE_FOLDER_NUMBER = FOLDER_NUMBER + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) NEWS_FOLDER_COM + ELSE + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER_COM + END IF + END DO + + IF (NEWS_OPEN.AND.IER.EQ.0) CALL NEWS_TO_FOLDER + + FOLDER_NUMBER = SAVE_FOLDER_NUMBER + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM_GT(KEY_NUMBER,IER) + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + READ (7,KEYGT=KEY_NUMBER,KEYID=1,IOSTAT=IER) NEWS_FOLDER_COM + ELSE + READ (7,KEYGT=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER_COM + END IF + END DO + + IF (NEWS_OPEN.AND.IER.EQ.0) CALL NEWS_TO_FOLDER + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM_TEMP(KEY_NUMBER,IER) + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) NEWS_FOLDER1_COM + ELSE + READ (7,KEY=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER1_COM + END IF + END DO + + IF (NEWS_OPEN.AND.IER.EQ.0) CALL NEWS_TO_FOLDER1 + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNUM_GT_TEMP(KEY_NUMBER,IER) + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + READ (7,KEYGT=KEY_NUMBER,KEYID=1,IOSTAT=IER) NEWS_FOLDER1_COM + ELSE + READ (7,KEYGT=KEY_NUMBER,KEYID=1,IOSTAT=IER) FOLDER1_COM + END IF + END DO + + IF (NEWS_OPEN.AND.IER.EQ.0) CALL NEWS_TO_FOLDER1 + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME_TEMP(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) NEWS_FOLDER1_COM + ELSE + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER1_COM + END IF + END DO + + IF (NEWS_OPEN.AND.IER.EQ.0) CALL NEWS_TO_FOLDER1 + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAMEGE_TEMP(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + READ (7,KEYGE=KEY_NAME,KEYID=0,IOSTAT=IER) NEWS_FOLDER1_COM + ELSE + READ (7,KEYGE=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER1_COM + END IF + END DO + + IF (NEWS_OPEN.AND.IER.EQ.0) CALL NEWS_TO_FOLDER1 + + RETURN + + ENTRY READ_FOLDER_FILE_KEYNAME(KEY_NAME,IER) + + DO WHILE (REC_LOCK(IER)) + IF (NEWS_OPEN) THEN + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) NEWS_FOLDER_COM + ELSE + READ (7,KEY=KEY_NAME,KEYID=0,IOSTAT=IER) FOLDER_COM + END IF + END DO + + IF (NEWS_OPEN.AND.IER.EQ.0) CALL NEWS_TO_FOLDER + + RETURN + + END + + + SUBROUTINE USER_FILE_ROUTINES + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + INCLUDE '($FORIOSDEF)' + + CHARACTER*(*) KEY_NAME + + INCLUDE 'BULLUSER.INC' + + CHARACTER*12 SAVE_USERNAME + + ENTRY READ_USER_FILE(IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,IOSTAT=IER) USER_ENTRY + END DO + + TEMP_USER = USERNAME + USERNAME = SAVE_USERNAME + + RETURN + + ENTRY READ_USER_FILE_KEYNAME(KEY_NAME,IER) + + SAVE_USERNAME = USERNAME + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=KEY_NAME,IOSTAT=IER) USER_ENTRY + END DO + + USERNAME = SAVE_USERNAME + TEMP_USER = KEY_NAME + + RETURN + + ENTRY READ_USER_FILE_HEADER(IER) + + DO WHILE (REC_LOCK(IER)) + READ (4,KEY=' ',IOSTAT=IER) USER_HEADER + IF (IER.EQ.FOR$IOS_ATTACCNON) THEN + WRITE (4,FMT=USER_FMT,IOSTAT=IER) + & USER_HEADER_KEY,NEWEST_BTIM, + & BBOARD_BTIM,PRV$M_OPER.OR.PRV$M_CMKRNL.OR. + & PRV$M_SETPRV,(0,I=1,FLONG*4-1) + IER = FOR$IOS_SPERECLOC + END IF + END DO + + RETURN + + ENTRY WRITE_USER_FILE_NEW(IER) + + DO I=1,FLONG + SET_FLAG(I) = SET_FLAG_DEF(I) + BRIEF_FLAG(I) = BRIEF_FLAG_DEF(I) + NOTIFY_FLAG(I) = NOTIFY_FLAG_DEF(I) + END DO + + ENTRY WRITE_USER_FILE(IER) + + DO WHILE (REC_LOCK(IER)) + WRITE (4,IOSTAT=IER) USER_ENTRY + END DO + + RETURN + + END + + + + + + SUBROUTINE SET_GENERIC(GENERIC) +C +C SUBROUTINE SET_GENERIC +C +C FUNCTION: Enables or disables "GENERIC" display, i.e. displaying +C general bulletins continually for a certain amount of days. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change GENERIC.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + IF (IER.EQ.0) THEN + IF (GENERIC) THEN + IF (CLI$PRESENT('DAYS')) THEN + IER = CLI$GET_VALUE('DAYS',BULL_PARAMETER) + CALL LIB$MOVC3(4,%REF(BULL_PARAMETER),NEW_FLAG(2)) + ELSE + NEW_FLAG(2) = ' 7' + END IF + ELSE + NEW_FLAG(2) = 0 + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET_BRIEF_CONTINUOUS(BRIEF_CONTINUOUS) +C +C SUBROUTINE SET_BRIEF_CONTINUOUS +C +C FUNCTION: Enables or disables "BRIEF_CONTINUOUS" display, i.e. displaying +C the brief message continually until the new messages have been read. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + + IF (BRIEF_CONTINUOUS) THEN + NEW_FLAG(2) = -1 + ELSE + NEW_FLAG(2) = 0 + END IF + + IF (IER.EQ.0) REWRITE (4) USER_ENTRY + + CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET_LOGIN(LOGIN) +C +C SUBROUTINE SET_LOGIN +C +C FUNCTION: Enables or disables bulletin display at login. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + CHARACTER TODAY*23 + + DIMENSION NOLOGIN_BTIM(2) + + CALL SYS$ASCTIM(,TODAY,,) ! Get the present time + + IF (.NOT.SETPRV_PRIV()) THEN + WRITE (6,'( + & '' ERROR: No privs to change LOGIN.'')') + RETURN + END IF + + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + + CALL OPEN_BULLUSER_SHARED + + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + IF (IER.EQ.0) THEN + IF (LOGIN.AND.COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + CALL SYS_BINTIM(TODAY,LOGIN_BTIM) + ELSE IF (.NOT.LOGIN) THEN + LOGIN_BTIM(1) = NOLOGIN_BTIM(1) + LOGIN_BTIM(2) = NOLOGIN_BTIM(2) + END IF + REWRITE (4) TEMP_USER//USER_ENTRY(13:) + ELSE + WRITE (6,'('' ERROR: Specified username not found.'')') + END IF + + CALL CLOSE_BULLUSER + + RETURN + END + + + + + + SUBROUTINE GET_UAF(USERNAME,USER,GROUP,ACCOUNT,FLAGS,IER) + + IMPLICIT INTEGER (A-Z) + + CHARACTER USERNAME*(*),ACCOUNT*(*) + + INCLUDE '($UAIDEF)' + + INTEGER*2 UIC(2) + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(LEN(ACCOUNT),UAI$_ACCOUNT,%LOC(ACCOUNT)) + CALL ADD_2_ITMLST(4,UAI$_UIC,%LOC(UIC)) + CALL END_ITMLST(GETUAI_ITMLST) + + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) + + USER = UIC(1) + GROUP = UIC(2) + + RETURN + END + + + + SUBROUTINE DCLEXH(EXIT_ROUTINE) + + IMPLICIT INTEGER (A-Z) + + INTEGER*4 EXBLK(4) + + EXBLK(2) = EXIT_ROUTINE + EXBLK(3) = 1 + EXBLK(4) = %LOC(EXBLK(4)) + + CALL SYS$DCLEXH(EXBLK(1)) + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin6.for b/decus/vax91b/gce91b/net91b/bulletin6.for new file mode 100644 index 0000000..7af811a --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin6.for @@ -0,0 +1,1700 @@ +C +C BULLETIN6.FOR, Version 7/17/91 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + SUBROUTINE CLOSE_FILE +C +C SUBROUTINE CLOSE_FILE +C +C FUNCTION: To close out the bulletin files and enable CTRL-C & -Y +C + DATA LUN /0/ + + ENTRY CLOSE_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY CLOSE_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY CLOSE_BULLNEWS + ENTRY CLOSE_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY CLOSE_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY CLOSE_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN) + + LUN = 0 + + RETURN + END + + + SUBROUTINE CLOSE_FILE_DELETE + + IMPLICIT INTEGER (A-Z) + + DATA LUN /0/ + + ENTRY CLOSE_BULLDIR_DELETE + LUN = LUN + 1 ! Unit = 2 + + ENTRY CLOSE_BULLFIL_DELETE + LUN = LUN + 1 ! Unit = 1 + + CALL ENABLE_CTRL + + CLOSE (UNIT=LUN,STATUS='DELETE') + + LUN = 0 + + RETURN + END + + + SUBROUTINE OPEN_FILE(UNIT) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE '($FORIOSDEF)' + + INCLUDE '($PRVDEF)' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + COMMON /NEWS_OPEN/ NEWS_OPEN + + DATA LUN /0/ + + LUN = UNIT - 14 ! 14 gets added to LUN + + ENTRY OPEN_BULLNEWS + LUN = LUN + 5 ! Unit = 14 + + ENTRY OPEN_BULLINF + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL ! No breaks while file is open + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + WRITE (4,FMT=USER_FMT) USER_HEADER_KEY,NEWEST_BTIM, + & BBOARD_BTIM,PRV$M_OPER.OR.PRV$M_CMKRNL.OR. + & PRV$M_SETPRV,(0,I=1,FLONG*4-1) + CLOSE (UNIT=4) + IDUMMY = FILE_LOCK(IER,IER1) + ELSE IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + FOLDER1 = 'GENERAL' + FOLDER1_OWNER = 'SYSTEM' + FOLDER1_DESCRIP = 'Default general bulletin folder.' + FOLDER1_BBOARD = 'NONE' + FOLDER1_BBEXPIRE = 14 + NBULL = 0 + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER2, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + WRITE (7,FMT=FOLDER_FMT,IOSTAT=IER2) + & FOLDER1,0,FOLDER1_OWNER,FOLDER1_DESCRIP + & ,FOLDER1_BBOARD,FOLDER1_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,4,0,F_NEWEST_NOSYS_BTIM + ! 4 means system folder + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + IF (IER.EQ.0) NEWS_OPEN = .FALSE. + END IF + + IF (LUN.EQ.14) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLNEWS_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + OPEN (UNIT=7,FILE=BULLNEWS_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=NEWS_FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER2, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + IF (IER.EQ.0) NEWS_OPEN = .TRUE. + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='UNKNOWN', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = 0 + IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) + END DO + END IF + + IF (IER.NE.0) THEN + WRITE (6,'( + & '' Cannot open file in OPEN_FILE, unit = '',I)') LUN + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT ! Enable CTRL-Y & -C & EXIT + END IF + + LUN = 0 + + RETURN + END + + + + SUBROUTINE TIMER_ERR(UNIT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*14 NAMES(6) + DATA NAMES/'directory','message','BULLUSER.DAT','BULLFOLDER.DAT', + & 'BULLINF.DAT','BULLNEWS.DAT'/ + INTEGER NAME(14) + DATA NAME/1,2,0,3,0,0,4,0,5,0,0,0,0,6/ + + IF (TEST_BULLCP().NE.2) THEN ! If BULLCP process, don't log error + WRITE(6,'('' ERROR: Unable to open '',A, + & '' file after 30 secs.'')') + & NAMES(NAME(UNIT))(:TRIM(NAMES(NAME(UNIT)))) + WRITE (6,'('' Please try again later.'')') + END IF + + CALL ENABLE_CTRL_EXIT ! No breaks while file is open + END + + + + SUBROUTINE OPEN_FILE_SHARED + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($FORIOSDEF)' + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + COMMON /NEWS_OPEN/ NEWS_OPEN + + EXTERNAL LNM_MODE_EXEC,ENABLE_CTRL_EXIT +C +C The following 2 files were used prior to V1.1. +C + CHARACTER*80 BULLDIR_FILE /'BULL_DIR:BULLDIR.DAT'/ + CHARACTER*80 BULLETIN_FILE /'BULL_DIR:BULLETIN.DAT'/ + + CHARACTER*25 SAVE_FOLDER + DATA SAVE_BLOCK/-1/ + + CHARACTER*14 NAMES(6) + DATA NAMES/'directory','message','BULLUSER.DAT','BULLFOLDER.DAT', + & 'BULLINF.DAT','BULLNEWS.DAT'/ + INTEGER NAME(14) + DATA NAME/1,2,0,3,0,0,4,0,5,0,0,0,0,6/ + + DATA LUN /0/ + + ENTRY OPEN_BULLNEWS_SHARED + LUN = LUN + 5 ! Unit = 14 + + ENTRY OPEN_BULLINF_SHARED + LUN = LUN + 1 ! Unit = 9 + + ENTRY OPEN_SYSUAF_SHARED + LUN = LUN + 1 ! Unit = 8 + + ENTRY OPEN_BULLFOLDER_SHARED + LUN = LUN + 3 ! Unit = 7 + + ENTRY OPEN_BULLUSER_SHARED + LUN = LUN + 2 ! Unit = 4 + + ENTRY OPEN_BULLDIR_SHARED + LUN = LUN + 1 ! Unit = 2 + + ENTRY OPEN_BULLFIL_SHARED + LUN = LUN + 1 ! Unit = 1 + + IER = 0 + + NTRIES = 0 + + CALL DISABLE_CTRL + + IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED,READONLY, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.(FOLDER_NUMBER.EQ.0 + & .OR.FOLDER.EQ.'GENERAL')) THEN + IER2 = LIB$RENAME_FILE(BULLETIN_FILE,'GENERAL.BULLFIL') + IER2 = LIB$RENAME_FILE(BULLDIR_FILE,'GENERAL.BULLDIR') + IF (IER2) IDUMMY = FILE_LOCK(IER,IER1) ! Don't break out of loop + ELSE IF (IER.EQ.0) THEN + INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN + CLOSE (UNIT=2) + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILES + NTRIES = 0 + END IF + ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLDIRS + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + DIR_NUM = -1 + END IF + + IF (LUN.EQ.1.AND.REMOTE_SET.AND.(SAVE_BLOCK.NE.BLOCK.OR. + & SAVE_FOLDER.NE.FOLDER)) THEN + CALL REMOTE_READ_MESSAGE(BULL_POINT,IER) + IF (IER.GT.0) THEN + CALL ERROR_AND_EXIT + ELSE + SAVE_BLOCK = BLOCK + SAVE_FOLDER = FOLDER + CALL GET_REMOTE_MESSAGE(IER) + IER = 0 + END IF + ELSE IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN + SAVE_BLOCK = -1 + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED',IOSTAT=IER,SHARED,READONLY) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_BULLFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.4) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_USERFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (LUN.EQ.7) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + + IF (IER.EQ.0) THEN + INQUIRE(UNIT=7,RECORDSIZE=ASK_SIZE) + IF (ASK_SIZE.NE.FOLDER_RECORD/4) THEN + CLOSE (UNIT=7) + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_BULLFOLDER(BULLFOLDER_FILE,ASK_SIZE) + NTRIES = 0 + END IF + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + IF (IER.EQ.0) NEWS_OPEN = .FALSE. + END IF + + IF (LUN.EQ.14) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=BULLNEWS_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + IF (IER.EQ.0) NEWS_OPEN = .TRUE. + END IF + + IF (LUN.EQ.8) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=8,FILE='SYSUAF',DEFAULTFILE='SYS$SYSTEM:SYSUAF.DAT', + & ACCESS='KEYED',FORM='UNFORMATTED',ORGANIZATION='INDEXED', + & STATUS='OLD',READONLY,IOSTAT=IER,SHARED, + & USEROPEN=LNM_MODE_EXEC) + END DO + END IF + + IF (LUN.EQ.9) THEN + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, + & KEY=(1:12:CHARACTER)) + IF (IER.EQ.FOR$IOS_INCRECLEN) THEN + IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop + CALL CONVERT_INFFILE + NTRIES = 0 + END IF + NTRIES = NTRIES + 1 + IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT + END DO + END IF + + IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.LUN.NE.8) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + CALL OPEN_FILE(LUN) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + ELSE IF (IER.NE.0) THEN + WRITE(6,'('' ERROR: Cannot open '',A)') + & NAMES(NAME(LUN))(:TRIM(NAMES(NAME(LUN)))) + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL ENABLE_CTRL_EXIT + END IF + + LUN = 0 + + RETURN + END + + + + + SUBROUTINE FOLDER_TO_NEWS + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + NEWS_FOLDER = FOLDER + NEWS_FOLDER_NUMBER = FOLDER_NUMBER + NEWS_FOLDER_DESCRIP = FOLDER_DESCRIP(26:) + NEWS_FOLDER_BBOARD = FOLDER_BBOARD + NEWS_F_NBULL = F_NBULL + NEWS_F_NEWEST_BTIM(1) = F_NEWEST_BTIM(1) + NEWS_F_NEWEST_BTIM(2) = F_NEWEST_BTIM(2) + + RETURN + + ENTRY FOLDER1_TO_NEWS + + NEWS_FOLDER1 = FOLDER1 + NEWS_FOLDER1_NUMBER = FOLDER1_NUMBER + NEWS_FOLDER1_DESCRIP = FOLDER1_DESCRIP(26:) + NEWS_FOLDER1_BBOARD = FOLDER1_BBOARD + NEWS_F1_NBULL = F1_NBULL + NEWS_F1_NEWEST_BTIM(1) = F1_NEWEST_BTIM(1) + NEWS_F1_NEWEST_BTIM(2) = F1_NEWEST_BTIM(2) + + RETURN + + ENTRY NEWS_TO_FOLDER + + FOLDER = NEWS_FOLDER + FOLDER_NUMBER = NEWS_FOLDER_NUMBER + FOLDER_DESCRIP = NEWS_FOLDER//NEWS_FOLDER_DESCRIP + FOLDER_BBOARD = NEWS_FOLDER_BBOARD + F_NBULL = NEWS_F_NBULL + F_NEWEST_BTIM(1) = NEWS_F_NEWEST_BTIM(1) + F_NEWEST_BTIM(2) = NEWS_F_NEWEST_BTIM(2) + FOLDER_FLAG = 0 + + RETURN + + ENTRY NEWS_TO_FOLDER1 + + FOLDER1 = NEWS_FOLDER1 + FOLDER1_NUMBER = NEWS_FOLDER1_NUMBER + FOLDER1_DESCRIP = NEWS_FOLDER1//NEWS_FOLDER1_DESCRIP + FOLDER1_BBOARD = NEWS_FOLDER1_BBOARD + F1_NBULL = NEWS_F1_NBULL + F1_NEWEST_BTIM(1) = NEWS_F1_NEWEST_BTIM(1) + F1_NEWEST_BTIM(2) = NEWS_F1_NEWEST_BTIM(2) + FOLDER1_FLAG = 0 + + RETURN + + END + + + + + SUBROUTINE CONVERT_BULLDIRS + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER BUFFER*115 + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP', + & IOSTAT=IER) + + IF (IER.NE.0) GO TO 900 ! No BULLDIR file found. + + READ (2'1,IOSTAT=IER1) BUFFER + + CALL LIB$MOVC3(4,%REF(BUFFER(39:)),NBULL) + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+5 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END IF + + IF (IER1.NE.0) GO TO 800 + + CALL SYS_BINTIM(BUFFER(1:11)//' '//BUFFER(12:19),NEWEST_EXBTIM) + CALL SYS_BINTIM(BUFFER(20:30)//' '//BUFFER(31:38),NEWEST_MSGBTIM) + BULLDIR_HEADER(29:40) = BUFFER(39:) + CALL SYS_BINTIM(BUFFER(51:61)//' '//BUFFER(62:69),SHUTDOWN_BTIM) + BULLDIR_HEADER(49:52) = BUFFER(70:) + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) BULLDIR_HEADER + + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ (2'ICOUNT,IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + MSG_NUM = ICOUNT - 1 + DESCRIP = BUFFER(1:) + FROM = BUFFER(54:) + BULLDIR_ENTRY(78:81) = BUFFER(85:) + BULLDIR_ENTRY(90:97) = BUFFER(108:) + CALL SYS_BINTIM(BUFFER(89:99)//' '//BUFFER(100:107),EX_BTIM) + CALL SYS_BINTIM(BUFFER(66:76)//' '//BUFFER(77:84),MSG_BTIM) + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (9,IOSTAT=IER) BULLDIR_ENTRY + ICOUNT = ICOUNT + 1 + END IF + END DO + +800 CLOSE (UNIT=9,DISPOSE='KEEP') + CLOSE (UNIT=2) + +900 CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFILES +C +C SUBROUTINE CONVERT_BULLFILES +C +C FUNCTION: Converts bulletin files to new format file. +C Add expiration time to directory file, add extra byte to bulletin +C file to show where each bulletin starts (for redunancy sake in +C case crash occurs). +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*81 BUFFER + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + OPEN (UNIT=9,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=107,ACCESS='DIRECT', + & ORGANIZATION='RELATIVE',DISPOSE='KEEP',FORM='FORMATTED', + & SHARED,READONLY,IOSTAT=IER) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=10,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=80, + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=81, + & FORM='FORMATTED') + + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + + NEWEST_EXTIME = '00:00:00.00' + READ (9'1,1000,IOSTAT=IER) + & NEWEST_EXDATE,NEWEST_DATE,NEWEST_TIME(:8), + & NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_DATE,SHUTDOWN_TIME(:8) + NEMPTY = 0 + IF (IER.EQ.0) CALL WRITEDIR(0,IER1) + + EXTIME = '00:00:00.00' + ICOUNT = 2 + DO WHILE (IER.EQ.0) + READ(9'ICOUNT,1010,IOSTAT=IER) + & DESCRIP,FROM,DATE,TIME(:8),LENGTH,EXDATE,SYSTEM,BLOCK + IF (IER.EQ.0) THEN + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER(1:80)//CHAR(1) + DO I=2,LENGTH + READ(10,'(A)') BUFFER + WRITE(1,'(A)') BUFFER + END DO + CALL WRITEDIR(ICOUNT-1,IER1) + ICOUNT = ICOUNT + 1 + END IF + END DO + + CLOSE (UNIT=9) + CLOSE (UNIT=2) + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + RETURN + +1000 FORMAT(A11,A11,A8,A4,A4,A4,A11,A8) +1010 FORMAT(A53,A12,A11,A8,A4,A11,A4,A4) + + END + + SUBROUTINE CONVERT_BULLFILE +C +C SUBROUTINE CONVERT_BULLFILE +C +C FUNCTION: Converts bulletin data file to new format file. +C +C NOTE: CONVERT_BULLFILES converts from 80 to 81 byte length. +C This converts from 81 byte length to 128 compressed format. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + CHARACTER*80 BUFFER,NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL CLOSE_BULLDIR + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + + CALL OPEN_BULLFOLDER + +100 READ (7,FMT=FOLDER_FMT,ERR=200) + & FOLDER,FOLDER_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + NEW_FILE = FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFILOLD' + OPEN (UNIT=10,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL' + & ,STATUS='OLD', + & RECORDTYPE='FIXED',RECORDSIZE=81,ACCESS='DIRECT', + & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=1,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, + & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, + & FORM='UNFORMATTED') + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.BULLFIL;-1',NEW_FILE) + + CALL OPEN_BULLDIR + + CALL READDIR(0,IER) + + IF (IER.EQ.1) THEN + NBLOCK = 0 + DO I=1,NBULL + CALL READDIR(I,IER) + NBLOCK = NBLOCK + 1 + SBLOCK = NBLOCK + DO J=BLOCK,LENGTH+BLOCK-1 + READ(10'J,'(A)') BUFFER + ILEN = TRIM(BUFFER) + IF (ILEN.EQ.0) ILEN = 1 + CALL STORE_BULL(ILEN,BUFFER,NBLOCK) + END DO + CALL FLUSH_BULL(NBLOCK) + LENGTH = NBLOCK - SBLOCK + 1 + BLOCK = SBLOCK + CALL WRITEDIR(I,IER) + END DO + + NEMPTY = 0 + CALL WRITEDIR(0,IER) + END IF + + CLOSE (UNIT=10) + CLOSE (UNIT=1) + + CALL CLOSE_BULLDIR + GOTO 100 + +200 CALL OPEN_BULLDIR_SHARED + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + + END + + + + SUBROUTINE CONVERT_BULLFOLDER(FILENAME,ASK_SIZE) +C +C SUBROUTINE CONVERT_BULLFOLDER +C +C FUNCTION: Converts bulletin folder file to new format. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($SSDEF)' + + INCLUDE '($FORIOSDEF)' + + CHARACTER*(*) FILENAME + + CHARACTER*80 NEW_FILE + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + + EODIR = MAX(INDEX(FILENAME,':'),INDEX(FILENAME,']')) + SUFFIX = INDEX(FILENAME(EODIR:),'.') + EODIR - 1 + NEW_FILE = FILENAME(:SUFFIX)//'OLD' + + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=7,FILE=FILENAME,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER)) + END DO + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + OPEN (UNIT=19,FILE=NEW_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & RECORDSIZE=FOLDER_RECORD, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:25:CHARACTER,26:29:INTEGER),DISPOSE='DELETE') + + IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? + + IF (ASK_SIZE.EQ.173/4) THEN + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8,5A4)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + IF (IER.EQ.0) THEN + WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET + & ,F_NEWEST_BTIM + F_NUMBER = F_NUMBER + 1 + END IF + END DO + ELSE + F_NUMBER = 0 + DO WHILE (IER.EQ.0) + READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8)', + & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + IF (IER.EQ.0) THEN + FOLDER_FLAG = 0 + IF (F_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER(:TRIM(FOLDER)) + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,0) + END IF + DO WHILE (FILE_LOCK(IER,IER1)) + OPEN (UNIT=2,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.EQ.FOR$IOS_INCFILORG) THEN + IDUMMY = FILE_LOCK(IER,IER1) + CALL CONVERT_BULLDIRS + END IF + END DO + IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN + F_NEWEST_BTIM(1) = 0 + F_NEWEST_BTIM(2) = 0 + ELSE + CALL READDIR(0,IER) + IF (NEWEST_DATE.EQ.'5-NOV-1956 ') THEN + IF (NBULL.GT.0) THEN + CALL READDIR(NBULL,IER) + NEWEST_DATE = DATE + NEWEST_TIME = TIME + CALL WRITEDIR(0,IER) + END IF + END IF + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) + CLOSE (UNIT=2) + END IF + WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) + & FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP + & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB + & ,NBULL,F_NEWEST_BTIM,FOLDER_FLAG,0,F_NEWEST_BTIM + F_NUMBER = F_NUMBER + 1 + END IF + END DO + END IF + + CLOSE (UNIT=7) + CLOSE (UNIT=19,STATUS='SAVE') + + IER = LIB$RENAME_FILE(NEW_FILE,FILENAME) + IER = LIB$RENAME_FILE(BULLFOLDER_FILE//';-1',NEW_FILE) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:TRIM(BBOARD_DIRECTORY)) + & //'BOARD.COM;*') ! BULLETIN$ is referenced in old file + + RETURN + END + + SUBROUTINE CONVERT_USERFILE +C +C SUBROUTINE CONVERT_USERFILE +C +C FUNCTION: Converts user file to new format which has 8 bytes added. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLUSER.INC' + + CHARACTER BUFFER*74,NEW_FILE*80 + + CHARACTER*11 LOGIN_DATE,READ_DATE + CHARACTER*8 LOGIN_TIME,READ_TIME + + WRITE (6,'('' Converting data files to new format. Please wait.'')') + + EODIR = MAX(INDEX(BULLUSER_FILE,':'),INDEX(BULLUSER_FILE,']')) + SUFFIX = INDEX(BULLUSER_FILE(EODIR:),'.') + EODIR - 1 + NEW_FILE = BULLUSER_FILE(:SUFFIX)//'OLD' + IER = LIB$RENAME_FILE(BULLUSER_FILE,NEW_FILE) + + OPEN (UNIT=9,FILE=NEW_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + INQUIRE (UNIT=9,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IER = LIB$RENAME_FILE(NEW_FILE,BULLUSER_FILE) + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + IF (IER.EQ.0) THEN + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) + OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, + & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, + & KEY=(1:12:CHARACTER)) + END IF + + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot convert user file.'')') + IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) + CALL SYS_GETMSG(IER1) + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + CALL ENABLE_CTRL_EXIT + END IF + + DO I=1,FLONG + NEW_FLAG(I) = 'FFFFFFFF'X + NOTIFY_FLAG(I) = 0 + BRIEF_FLAG(I) = 0 + SET_FLAG(I) = 0 + END DO + + IF (RECL.EQ.42.OR.RECL.EQ.50.OR.RECL.EQ.58.OR.RECL.EQ.66.OR. + & RECL.EQ.74) THEN ! Old format + IF (RECL.LE.58) RECL = 50 + IER = 0 + DO WHILE (IER.EQ.0) + READ (9,'(A)',IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + TEMP_USER = BUFFER(1:12) + LOGIN_DATE = BUFFER(13:23) + LOGIN_TIME = BUFFER(24:31) + READ_DATE = BUFFER(32:42) + READ_TIME = BUFFER(43:50) + IF (RECL.EQ.58) + & CALL LIB$MOVC3(8,%REF(BUFFER(51:)),SET_FLAG(1)) + IF (RECL.EQ.66) + & CALL LIB$MOVC3(8,%REF(BUFFER(59:)),NEW_FLAG(1)) + IF (RECL.EQ.74) + & CALL LIB$MOVC3(8,%REF(BUFFER(67:)),NOTIFY_FLAG(1)) + CALL SYS_BINTIM(LOGIN_DATE//' '//LOGIN_TIME,LOGIN_BTIM) + CALL SYS_BINTIM(READ_DATE//' '//READ_TIME,READ_BTIM) + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + IF (RECL.LT.66) THEN + READ (4,KEY=USER_HEADER_KEY,FMT=USER_FMT) TEMP_USER, + & LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + NEW_FLAG(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + ELSE ! Folder maxmimum increase + OFLONG = (RECL - 28) / 16 ! Old #longwords/flag + DO WHILE (IER.EQ.0) + READ (9,FMT='(A12,<4+OFLONG*4>A4)',IOSTAT=IER) + & TEMP_USER,LOGIN_BTIM,READ_BTIM, + & (NEW_FLAG(I),I=1,OFLONG),(SET_FLAG(I),I=1,OFLONG), + & (BRIEF_FLAG(I),I=1,OFLONG),(NOTIFY_FLAG(I),I=1,OFLONG) + IF (IER.EQ.0) THEN + WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, + & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG + END IF + END DO + END IF + + IER = 0 + + CLOSE (UNIT=9) + CLOSE (UNIT=4) + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection + + RETURN + END + + + SUBROUTINE READDIR(BULLETIN_NUM,ICOUNT) +C +C SUBROUTINE READDIR +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file and returns the information for that entry. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, gives header info, i.e number of bulls, +C number of blocks in bulletin file, etc. +C OUTPUTS: +C ICOUNT - The last record read by this routine. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /PROMPT/ COMMAND_PROMPT + CHARACTER*39 COMMAND_PROMPT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + CHARACTER*3 CFOLDER_NUMBER + + ICOUNT = BULLETIN_NUM + + IF (ICOUNT.EQ.0) THEN + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=0,IOSTAT=IER) BULLDIR_HEADER + END DO + IF (IER.EQ.0) THEN + CALL CONVERT_HEADER_FROMBIN + DIR_NUM = 0 + END IF + ELSE + CALL REMOTE_GET_HEADER(BULLETIN_NUM,ICOUNT,IER) + RETURN + END IF + IF (IER.EQ.0) THEN + IF (NBULL.LT.0) THEN ! This indicates bulletin deletion + ! was incomplete. + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR + CALL CLEANUP_DIRFILE(1) + CALL UPDATE_FOLDER + END IF + IF (NEMPTY.EQ.' ') NEMPTY = 0 +C +C Check to see if cleanup of empty file space is necessary, which is +C defined here as being 50 blocks (200 128byte records). Also check +C to see if cleanup was in progress but didn't properly finish. +C + IF (NEMPTY.GT.200.AND.TEST_BULLCP().EQ.0) THEN + WRITE (CFOLDER_NUMBER,'(I3)') FOLDER_NUMBER + IER1 = LIB$SPAWN('$'//COMMAND_PROMPT(1:INDEX( + & COMMAND_PROMPT,'>')-1)//'/CLEANUP='//CFOLDER_NUMBER, + & 'NL:','NL:',1,'BULL_CLEANUP') + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLEANUP_BULLFILE + END IF + END IF + ELSE + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + IF (DIR_NUM.EQ.ICOUNT-1) THEN + READ(2,IOSTAT=IER) BULLDIR_ENTRY + IF (MSG_NUM.NE.ICOUNT) IER = 36 + ELSE + READ(2,KEYID=0,KEY=ICOUNT,IOSTAT=IER) BULLDIR_ENTRY + END IF + END DO + IF (IER.EQ.0) THEN + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + DIR_NUM = -1 + END IF + ELSE + CALL REMOTE_GET_HEADER(BULLETIN_NUM,ICOUNT,IER) + RETURN + END IF + END IF + + IF (IER.EQ.0) ICOUNT = ICOUNT + 1 + + UNLOCK 2 + + RETURN + + END + + + + + + SUBROUTINE READDIR_KEYGE(IER) +C +C SUBROUTINE READDIR_KEYGE +C +C FUNCTION: Finds the entry for the specified bulletin in the +C directory file corresponding to or later than the date specified. +C +C INPUTS: +C MSG_KEY - Message key (passed via BULLDIR.INC common block). +C OUTPUTS: +C IER - If not 0, no entry found. Else contains message number. +C + + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + IF (.NOT.REMOTE_SET) THEN + DO WHILE (REC_LOCK(IER)) + READ(2,KEYID=1,KEYGT=MSG_KEY,IOSTAT=IER) BULLDIR_ENTRY + END DO + IF (IER.EQ.0) THEN + IER = MSG_NUM + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + CALL CONVERT_ENTRY_FROMBIN + DIR_NUM = MSG_NUM + ELSE + IER = 0 + DIR_NUM = -1 + END IF + UNLOCK 2 + ELSE + CALL REMOTE_GET_HEADER(DUMMY,-1,IER) + END IF + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,NEWEST_EXBTIM,) + + NEWEST_EXDATE = DATETIME + NEWEST_EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,NEWEST_MSGBTIM,) + + NEWEST_DATE = DATETIME + NEWEST_TIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,SHUTDOWN_BTIM,) + + SHUTDOWN_DATE = DATETIME + SHUTDOWN_TIME = DATETIME(13:) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_FROMBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*23 DATETIME + + CALL SYS$ASCTIM(,DATETIME,EX_BTIM,) + + EXDATE = DATETIME + EXTIME = DATETIME(13:) + + CALL SYS$ASCTIM(,DATETIME,MSG_BTIM,) + + DATE = DATETIME + TIME = DATETIME(13:) + + RETURN + END + + + + + + SUBROUTINE WRITEDIR(BULLETIN_NUM,IER) +C +C SUBROUTINE WRITEDIR +C +C FUNCTION: Writes the entry for the specified bulletin in the +C directory file. +C +C INPUTS: +C BULLETIN_NUM - Bulletin number. Starts with 1. +C If 0, write the header of the directory file. +C OUTPUTS: +C IER - Error status from WRITE. +C + + IMPLICIT INTEGER (A - Z) + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /DIR_POSITION/ DIR_NUM + + INCLUDE 'BULLDIR.INC' + + CONV = .TRUE. + + GO TO 10 + + ENTRY WRITEDIR_NOCONV(BULLETIN_NUM,IER) + + CONV = .FALSE. + +10 IF (BULLETIN_NUM.EQ.0) THEN + IF (CONV) CALL CONVERT_HEADER_TOBIN + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,0,BULLDIR_HEADER + ELSE + IER = -1 + IF (DIR_NUM.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=0,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + IF (IER.NE.0) THEN + WRITE (2,IOSTAT=IER) BULLDIR_HEADER + END IF + END IF + ELSE + IF (CONV) CALL CONVERT_ENTRY_TOBIN + MSG_NUM = BULLETIN_NUM + IF (REMOTE_SET) THEN + WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,BULLETIN_NUM,BULLDIR_ENTRY + ELSE + IER = -1 + IF (DIR_NUM.EQ.MSG_NUM) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + IF (IER.NE.0) THEN + READ (2,KEYID=0,KEY=BULLETIN_NUM,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY + ELSE + WRITE (2,IOSTAT=IER) BULLDIR_ENTRY + END IF + END IF + END IF + END IF + + IF (REMOTE_SET.AND.IER.GT.0) CALL ERROR_AND_EXIT + + DIR_NUM = -1 + + RETURN + + END + + + + SUBROUTINE CONVERT_HEADER_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(NEWEST_EXDATE//' '//NEWEST_EXTIME,NEWEST_EXBTIM) + + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_MSGBTIM) + + CALL SYS_BINTIM(SHUTDOWN_DATE//' '//SHUTDOWN_TIME,SHUTDOWN_BTIM) + + RETURN + END + + + + SUBROUTINE CONVERT_ENTRY_TOBIN + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CALL SYS_BINTIM(EXDATE//' '//EXTIME,EX_BTIM) + + CALL SYS_BINTIM(DATE//' '//TIME,MSG_BTIM) + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + + RETURN + END + + + + + SUBROUTINE READACL(FILENAME,ACLENT,ACLLENGTH) +C +C SUBROUTINE READACL +C +C FUNCTION: Reads the ACL of a file. +C +C PARAMETERS: +C FILENAME - Name of file to check. +C ACLENT - String which will be large enough to hold ACL information. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*(*),OUTPUT*80,ACLSTR*255,FILENAME*(*) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) + + BIG = .NOT.IER + IF (BIG) THEN + IER = SYS$PARSE_ACL('(ID=*,ACCESS=NONE)',ACLENT,,) + ACLLENGTH = ACL$S_ADDACLENT + CTXT = 0 + END IF + + DO ACC_TYPE=1,2 + POINT = 1 + OUTLEN = 0 + DO WHILE ((POINT.LT.ACLLENGTH).AND.IER) + IF (.NOT.BIG) THEN + IER = SYS$FORMAT_ACL(ACLENT(POINT:POINT-1+ + & ICHAR(ACLENT(POINT:POINT))),ACLLEN,ACLSTR,,,,) + ELSE + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_FNDACETYP,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST) + & ,,,CTXT,,) + IER = SYS$FORMAT_ACL(ACLENT(:ICHAR(ACLENT(1:1))), + & ACLLEN,ACLSTR,,,,) + CALL LIB$MOVC3(4,%REF(ACLENT(5:)),ACCESS) + IF (ACCESS.EQ.0) IER = .FALSE. + END IF + AC = INDEX(ACLSTR,',ACCESS') + IF ((ACC_TYPE.EQ.1.AND.INDEX(ACLSTR(AC:),'WRITE').GT.0).OR. + & (ACC_TYPE.EQ.2.AND.INDEX(ACLSTR(AC:),'READ').GT.0.AND. + & INDEX(ACLSTR(AC:),'WRITE').EQ.0)) THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,',ACCESS') - 1 + IF (ACLSTR(END_ID:END_ID).EQ.']') THEN + START_ID = END_ID - 1 + ASCII = .FALSE. + DO WHILE (ACLSTR(START_ID:START_ID).NE.'['.AND. + & ACLSTR(START_ID:START_ID).NE.'='.AND. + & (ACLSTR(START_ID:START_ID).NE.','.OR..NOT.ASCII)) + IF (ACLSTR(START_ID:START_ID).NE.','.AND. + & (ACLSTR(START_ID:START_ID).LT.'0'.OR. + & ACLSTR(START_ID:START_ID).GT.'9')) ASCII = .TRUE. + IF (ACLSTR(START_ID:START_ID).NE.','.OR..NOT.ASCII) THEN + START_ID = START_ID - 1 + END IF + END DO + IF (ASCII) THEN + START_ID = START_ID + 1 + END_ID = END_ID - 1 + IF (ACLSTR(START_ID:START_ID).EQ.'*') THEN + START_ID = INDEX(ACLSTR,'=') + 1 + END_ID = INDEX(ACLSTR,'ACCESS') - 2 + END IF + END IF + END IF + IF (OUTLEN.EQ.0) THEN + IF (FILENAME.NE.BULLUSER_FILE) THEN + IF (ACC_TYPE.EQ.1) THEN + WRITE (6,'( + & '' These users can read and write to this folder:'')') + ELSE + WRITE (6,'( + & '' These users can only read this folder:'')') + END IF + ELSE + WRITE (6,'('' The following are rights identifiers'', + & '' which will give privileges.'')') + END IF + OUTLEN = 1 + END IF + IDLEN = END_ID - START_ID + 1 + IF (OUTLEN+IDLEN-1.GT.80) THEN + WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-1) + OUTPUT = ACLSTR(START_ID:END_ID)//',' + OUTLEN = IDLEN + 2 + ELSE IF (OUTLEN+IDLEN-1.EQ.80) THEN + WRITE (6,'(1X,A)') + & OUTPUT(:OUTLEN-1)//ACLSTR(START_ID:END_ID) + OUTLEN = 1 + ELSE + OUTPUT(OUTLEN:) = ACLSTR(START_ID:END_ID)//',' + OUTLEN = OUTLEN + IDLEN + 1 + END IF + END IF + POINT = POINT + ICHAR(ACLENT(POINT:POINT)) + END DO + IF (OUTLEN.GT.1) WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-2) + END DO + + RETURN + END + + + + + SUBROUTINE CONVERT_INFFILE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + OPEN (UNIT=10,FILE=BULLINF_FILE,STATUS='OLD', + & ACCESS='KEYED',RECORDTYPE='FIXED', + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + INQUIRE (UNIT=10,RECORDSIZE=RECL) + + IF ((RECL-28)/16.GT.FLONG) THEN + WRITE (6,'('' ERROR: Old data files have more folders'', + & '' than was specified with BULLUSER.INC.'')') + WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') + IF (USERNAME.EQ.'DECNET') THEN + CALL SYS$DELPRC(,) + ELSE + CALL SYS$CANEXH() + CALL EXIT + END IF + END IF + + RECL = RECL/8 + + OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='NEW', + & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, + & IOSTAT=IER,ORGANIZATION='INDEXED', + & KEY=(1:12:CHARACTER)) + + DO WHILE (IER.EQ.0) + READ (10,IOSTAT=IER) TEMP_USER,((LAST_READ_BTIM(J,I),J=1,2),I=1,RECL) + IF (IER.EQ.0) WRITE (9) TEMP_USER, + & ((LAST_READ_BTIM(J,I),J=1,2),I=1,FOLDER_MAX) + END DO + + CLOSE (UNIT=10,STATUS='DELETE') + + CLOSE (UNIT=9) + + RETURN + END + + + SUBROUTINE ERROR_AND_EXIT + + IMPLICIT INTEGER (A-Z) + + CALL ERRSNS(IDUMMY,IER) + CALL SYS_GETMSG(IER) + CALL ENABLE_CTRL_EXIT + + RETURN + END + + + + + SUBROUTINE COPY_ACL(INFILE,OUTFILE) +C +C SUBROUTINE COPY_ACL +C +C FUNCTION: +C Copy ACLs from one file to another file +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER*(*) INFILE,OUTFILE + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) + ! Get length needed to store acl output + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,,,) + + CALL LIB$GET_VM(ACLLENGTH+8,ACLSTR) ! Create character string to + CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) ! store acl + + CALL COPY_ACL1(INFILE,OUTFILE,%VAL(ACLSTR),ACLLENGTH) + ! Pass location of string + CALL LIB$FREE_VM(ACLLENGTH+8,ACLSTR) + + RETURN + END + + + SUBROUTINE COPY_ACL1(INFILE,OUTFILE,ACLENT,ACLLENGTH) +C +C SUBROUTINE COPY_ACL1 +C +C FUNCTION: Called by COPY_ACL to actually do the copy. Need 2 routines +C since must convert location of string into a character string. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($ACLDEF)' + + CHARACTER ACLENT*(*),INFILE*(*),OUTFILE*(*) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,,,) + ! Read input file acl + + IF (.NOT.IER) THEN + IER = SYS$PARSE_ACL('(ID=*,ACCESS=NONE)',ACLENT,,) + IF (.NOT.IER) RETURN + ACLLENGTH = ACL$S_ADDACLENT + CTXT = 0 + DO WHILE (IER) + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ICHAR(ACLENT(1:1)),ACL$C_ADDACLENT, + & %LOC(ACLENT)) + CALL END_ITMLST(ACL1_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL + & (,ACL$C_FILE,OUTFILE,%VAL(ACL1_ITMLST),,,) + + CALL INIT_ITMLST ! Initialize item list + CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_FNDACETYP,%LOC(ACLENT)) + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST) + & ,,,CTXT,,) + CALL LIB$MOVC3(4,%REF(ACLENT(5:)),ACCESS) + IF (ACCESS.EQ.0) RETURN ! ID=*, ACCESS=NONE, which has + ! (and must) be applied first + END DO + RETURN + END IF + + CALL INIT_ITMLST ! Initialize item list + + POINT = 1 + DO WHILE (POINT.LT.ACLLENGTH) ! Transfer all acls to output file + CALL ADD_2_ITMLST(ICHAR(ACLENT(POINT:POINT)),ACL$C_ADDACLENT, + & %LOC(ACLENT(POINT:))) + POINT = POINT + ICHAR(ACLENT(POINT:POINT)) + END DO + + CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist + IER = SYS$CHANGE_ACL(,ACL$C_FILE,OUTFILE,%VAL(ACL_ITMLST),,,) + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin7.for b/decus/vax91b/gce91b/net91b/bulletin7.for new file mode 100644 index 0000000..4b3f0e1 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin7.for @@ -0,0 +1,2044 @@ +C +C BULLETIN7.FOR, Version 5/27/91 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + SUBROUTINE UPDATE_LOGIN(ADD_BULL) +C +C SUBROUTINE UPDATE_LOGIN +C +C FUNCTION: Updates the login file when a bulletin has been deleted +C or added. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($SSDEF)' + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + DIMENSION READ_BTIM_SAVE(2),TEMP_BTIM(2) + +C +C We want to keep the last read date for comparison when selecting new +C folders, so save it for later restoring. +C + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL OPEN_BULLUSER_SHARED + +C +C Newest date/time in user file only applies to general bulletins. +C This was present before adding folder capability. +C We set flags in user entry to show new folder added for folder bulletins. +C However, the newest bulletin for each folder is not continually updated, +C As it is only used when comparing to the last bulletin read time, and to +C store this for each folder would be too expensive. +C + + TEMP_BTIM(1) = NEWEST_BTIM(1) + TEMP_BTIM(2) = NEWEST_BTIM(2) + CALL READ_USER_FILE_HEADER(IER) + NEWEST_BTIM(1) = TEMP_BTIM(1) + NEWEST_BTIM(2) = TEMP_BTIM(2) + + IF (IER.NE.0) THEN + CALL CLOSE_BULLUSER + RETURN + ELSE IF (FOLDER_NUMBER.EQ.0) THEN + CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_BTIM) + REWRITE (4,IOSTAT=IER) USER_HEADER + END IF + + BROAD_MSG = .FALSE. + IF (ADD_BULL.AND.FOLDER_NUMBER.GE.0) THEN ! Message added? + IF (INCMD(1:3).NE.'ADD') THEN + BROAD_MSG = .TRUE. + ELSE IF (.NOT.CLI$PRESENT('BROADCAST')) THEN + BROAD_MSG = .TRUE. + END IF + END IF + + IF (BROAD_MSG) THEN + IF (FOLDER_BBOARD(:2).NE.'::'.AND. + & FOLDER_NUMBER.GT.0) THEN ! Folder private? + CALL CHKACL + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL',IER) + IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN + CHECK_ACL = 0 + ELSE + CHECK_ACL = 1 + END IF + ELSE + CHECK_ACL = 0 + END IF + + CALL NOTIFY_USERS(CHECK_ACL) + END IF + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) + ! Reobtain present values as calling programs still uses them + + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + + CALL CLOSE_BULLUSER + + RETURN + + END + + + + + SUBROUTINE NOTIFY_USERS(CHECK_ACL) +C +C SUBROUTINE NOTIFY_USERS +C +C FUNCTION: Notify users with SET NOTIFY set of new message. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE '($BRKDEF)' + + CHARACTER OUTPUT*160,TERMINAL*7,FLAGS*1 + CHARACTER*1 CR/13/,LF/10/,BELL/7/ + CHARACTER*12 SENT_TEMP_USER,TEMP_USERNAME + + OUTPUT = BELL//CR//LF//LF// + & 'New bulletin added to folder '//FOLDER(1:TRIM(FOLDER)) + & //'. From: '//FROM(1:TRIM(FROM))//CR//LF// + & 'Description: '//DESCRIP(1:TRIM(DESCRIP)) + + IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',FLAGS) + IF (.NOT.IER) THEN + IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',FLAGS) + END IF + + BFLAG = 0 + READ (FLAGS(:1),'(I1)',IOSTAT=IER) FLAG + IF (BTEST(FLAG,1).AND.IER.EQ.0) BFLAG = BRK$M_CLUSTER + + CALL SYS$SETRWM(%VAL(1)) ! Don't wait if can't broadcast + + CALL INIT_QUEUE(TEMP_USER_QUEUE,TEMP_USERNAME) + WRITE_TEMP_USER = TEMP_USER_QUEUE + + DO WHILE (GETUSERS(TEMP_USERNAME,TERMINAL)) + READ_TEMP_USER = TEMP_USER_QUEUE + SENT_TEMP_USER = ' ' + DO WHILE (TEMP_USERNAME.NE.SENT_TEMP_USER.AND. + & READ_TEMP_USER.NE.WRITE_TEMP_USER) + CALL READ_QUEUE(%VAL(READ_TEMP_USER),READ_TEMP_USER, + & SENT_TEMP_USER) + END DO + IF (TEMP_USERNAME.NE.SENT_TEMP_USER) THEN + CALL READ_USER_FILE_KEYNAME(TEMP_USERNAME,IER) + CALL WRITE_QUEUE(%VAL(WRITE_TEMP_USER),WRITE_TEMP_USER, + & TEMP_USERNAME) + ELSE + IER = 2 + END IF + IF (IER.EQ.0.AND.TEMP_USERNAME.NE.FROM.AND. + & TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + IF (CHECK_ACL) THEN + CALL CHECK_ACCESS + & (FOLDER_FILE(1:TRIM(FOLDER_FILE))//'.BULLFIL', + & TEMP_USERNAME,IER,WRITE_ACCESS) + ELSE + IER = 1 + END IF + IF (IER) THEN + CALL SYS$BRKTHRU(,OUTPUT(1:TRIM(OUTPUT))//CR, + & TEMP_USERNAME(:TRIM(TEMP_USERNAME)), + & %VAL(BRK$C_USERNAME),,,%VAL(BFLAG),,,,) + ELSE + CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) + REWRITE (4,IOSTAT=IER) TEMP_USERNAME//USER_ENTRY(13:) + END IF + END IF + END DO + CALL SYS$SETRWM(%VAL(0)) + + RETURN + END + + + + + + SUBROUTINE ADD_ENTRY +C +C SUBROUTINE ADD_ENTRY +C +C FUNCTION: Enters a new directory entry in the directory file. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER TODAY_TIME*32 + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + IF (REMOTE_SET) THEN + LOCAL = .TRUE. + IF (INCMD(:3).EQ.'ADD') LOCAL = CLI$PRESENT('LOCAL') + IF (LOCAL) THEN + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,0,0,0,0 + ELSE + WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) + & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,CLI$PRESENT('BROADCAST'), + & CLI$PRESENT('BELL'),CLI$PRESENT('ALL'), + & CLI$PRESENT('CLUSTER') + END IF + IF (IER.EQ.0) THEN + READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM + END IF + IF (IER.EQ.0) THEN + IF (I.EQ.LEN(FOLDER1_COM)) THEN + IER = SYS$ASCTIM(,TODAY_TIME,F1_NEWEST_BTIM,) + NEWEST_DATE = TODAY_TIME(1:11) + NEWEST_TIME = TODAY_TIME(13:) + NBULL = F1_NBULL + CALL UPDATE_FOLDER + ELSE + WRITE (6,'(1X,A)') FOLDER1_COM(:I) + END IF + ELSE + CALL DISCONNECT_REMOTE + IF (INCMD(:4).EQ.'MOVE') CALL EXIT + END IF + CALL UPDATE_LOGIN(.TRUE.) + RETURN + END IF + + NEW_DATE = .TRUE. + + GO TO 10 + + ENTRY NEWS2BULL_ADD_ENTRY + + NEW_DATE = .FALSE. + +10 CALL READDIR(0,IER) + + IF (IER.NE.1) THEN + NEWEST_EXDATE = '5-NOV-2000' + NEWEST_EXTIME = '00:00:00.00' + NEWEST_DATE = '5-NOV-1956' + NEWEST_TIME = '00:00:00.00' + NBULL = 0 + NBLOCK = 0 + SHUTDOWN = 0 + NEMPTY = 0 + END IF + + IF (.NOT.NEW_DATE) THEN + DIFF = COMPARE_DATE(NEWEST_DATE,DATE) + IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_TIME,TIME) + END IF + IF (DIFF.GE.0) NEW_DATE = .TRUE. + END IF + + IF (NEW_DATE) THEN + CALL SYS$ASCTIM(,TODAY_TIME,,) + DATE = TODAY_TIME(1:11) + TIME = TODAY_TIME(13:) + END IF + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + NBULL = NBULL + 1 + BLOCK = NBLOCK + 1 + NBLOCK = NBLOCK + LENGTH + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + CALL UPDATE_LOGIN(.TRUE.) + + CALL WRITEDIR(NBULL,IER) + + CALL WRITEDIR(0,IER) + + RETURN + END + + + + + INTEGER FUNCTION COMPARE_BTIM(BTIM1,BTIM2) +C +C FUNCTION COMPARE_BTIM +C +C FUCTION: Compares times in binary format to see which is farther in future. +C +C INPUTS: +C BTIM1 - First time in binary format +C BTIM2 - Second time in binary format +C OUTPUT: +C Returns +1 if first time is farther in future +C Returns -1 if second time is farther in future +C Returns 0 if equal time +C + IMPLICIT INTEGER (A - Z) + + DIMENSION BTIM1(2),BTIM2(2),DIFF(2) + + CALL LIB$SUBX(BTIM1,BTIM2,DIFF) + + IF (DIFF(2).LT.0) THEN + COMPARE_BTIM = -1 + ELSE IF (DIFF(2).GE.0) THEN + COMPARE_BTIM = +1 + END IF + + RETURN + END + + + + + + INTEGER FUNCTION MINUTE_DIFF(DATE2,DATE1) +C +C FUNCTION MINUTE_DIFF +C +C FUNCTION: Finds difference in minutes between 2 binary times. +C +C + IMPLICIT INTEGER (A-Z) + + DIMENSION DATE1(2),DATE2(2) + + CALL LIB$DAY(DAYS1,DATE1,MSECS1) + CALL LIB$DAY(DAYS2,DATE2,MSECS2) + + MINUTE_DIFF = (DAYS2-DAYS1)*24*60 + (MSECS2-MSECS1)/6000 + + RETURN + END + + + + + + + INTEGER FUNCTION COMPARE_DATE(DATE1,DATE2) +C +C FUNCTION COMPARE_DATE +C +C FUCTION: Compares dates to see which is farther in future. +C +C INPUTS: +C DATE1 - First date (dd-mm-yy) +C DATE2 - Second date (If is equal to ' ', then use present date) +C OUTPUT: +C Returns the difference in days between the two dates. +C If the DATE1 is farther in the future, the output is positive, +C else it is negative. +C + IMPLICIT INTEGER (A - Z) + + CHARACTER*(*) DATE1,DATE2 + INTEGER USER_TIME(2) + + CALL SYS_BINTIM(DATE1,USER_TIME) + + CALL VERIFY_DATE(USER_TIME) +C +C LIB$DAY crashes if date invalid, which happened once due to an unknown +C hardware or software error which created a date very far in the future. +C + CALL LIB$DAY(DAY1,USER_TIME) + + IF (DATE2.NE.' ') THEN + CALL SYS_BINTIM(DATE2,USER_TIME) + CALL VERIFY_DATE(USER_TIME) + ELSE + CALL SYS$GETTIM(USER_TIME) + END IF + + CALL LIB$DAY(DAY2,USER_TIME) + + COMPARE_DATE = DAY1 - DAY2 + + RETURN + END + + + + SUBROUTINE VERIFY_DATE(BTIM) + + IMPLICIT INTEGER (A-Z) + + DIMENSION BTIM(2),TEMP(2) + + CALL SYS_BINTIM(' 5-NOV-2011 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.GT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + CALL SYS_BINTIM(' 5-NOV-1955 00:00:00.00',TEMP) + + IER = COMPARE_BTIM(BTIM,TEMP) + + IF (IER.LT.0) THEN ! Date invalid + BTIM(1) = TEMP(1) + BTIM(2) = TEMP(2) + END IF + + RETURN + END + + + + INTEGER FUNCTION COMPARE_TIME(TIME1,TIME2) +C +C FUNCTION COMPARE_TIME +C +C FUCTION: Compares times to see which is farther in future. +C +C INPUTS: +C TIME1 - First time (hh:mm:ss.xx) +C TIME2 - Second time +C OUTPUT: +C Outputs (TIME1-TIME2) in seconds. Thus, if TIME1 is further +C in the future, outputs positive number, else negative. +C + + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) TIME1,TIME2 + CHARACTER*23 TODAY_TIME + CHARACTER*11 TEMP2 + + IF (TIME2.EQ.' ') THEN + CALL SYS$ASCTIM(,TODAY_TIME,,) + TEMP2 = TODAY_TIME(13:) + ELSE + TEMP2 = TIME2 + END IF + + COMPARE_TIME = 3600*10*(ICHAR(TIME1(1:1))-ICHAR(TEMP2(1:1))) + & +3600*(ICHAR(TIME1(2:2))-ICHAR(TEMP2(2:2))) + & +60*10*(ICHAR(TIME1(4:4))-ICHAR(TEMP2(4:4))) + & +60*(ICHAR(TIME1(5:5))-ICHAR(TEMP2(5:5))) + & +10*(ICHAR(TIME1(7:7))-ICHAR(TEMP2(7:7))) + & +(ICHAR(TIME1(8:8))-ICHAR(TEMP2(8:8))) + + IF (COMPARE_TIME.EQ.0) THEN + COMPARE_TIME = 10*(ICHAR(TIME1(10:10))-ICHAR(TEMP2(10:10))) + & +(ICHAR(TIME1(11:11))-ICHAR(TEMP2(11:11))) + IF (COMPARE_TIME.GT.0) THEN + COMPARE_TIME = 1 + ELSE IF (COMPARE_TIME.LT.0) THEN + COMPARE_TIME = -1 + END IF + END IF + + RETURN + END + +C------------------------------------------------------------------------- +C +C The following are subroutines to create a linked-list queue for +C temporary buffer storage of data that is read from files to be +C outputted to the terminal. This is done so as to be able to close +C the file as soon as possible. +C +C Each record in the queue has the following format. The first two +C words are used for creating a character variable. The first word +C contains the length of the character variable, the second contains +C the address. The address is simply the address of the 3rd word of +C the record. The last word in the record contains the address of the +C next record. Every time a record is written, if that record has a +C zero link, it adds a new record for the next write operation. +C Therefore, there will always be an extra record in the queue. To +C check for the end of the queue, the last word (link to next record) +C is checked to see if it is zero. +C +C------------------------------------------------------------------------- + SUBROUTINE INIT_QUEUE(HEADER,DATA) + CHARACTER*(*) DATA + INTEGER HEADER + IF (HEADER.NE.0) RETURN ! Queue already initialized + LENGTH = LEN(DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + CALL LIB$GET_VM(LENGTH+12,HEADER) + CALL MAKE_CHAR(%VAL(HEADER),LEN(DATA),LENGTH) + RETURN + END + + + SUBROUTINE WRITE_QUEUE(RECORD,NEXT,DATA) + INTEGER RECORD(1) + CHARACTER*(*) DATA + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,DATA,%VAL(%LOC(RECORD))) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + IF (NEXT.NE.0) RETURN + CALL LIB$GET_VM(LENGTH+12,NEXT) + CALL MAKE_CHAR(%VAL(NEXT),RECORD(1),LENGTH) + RECORD((LENGTH+12)/4) = NEXT + RETURN + END + + SUBROUTINE READ_QUEUE(RECORD,NEXT,DATA) + CHARACTER*(*) DATA + INTEGER RECORD(1) + LENGTH = RECORD(1) + CALL COPY_CHAR(LENGTH,%VAL(%LOC(RECORD)),DATA) + IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) + NEXT = RECORD((LENGTH+12)/4) + RETURN + END + + SUBROUTINE COPY_CHAR(LENGTH,INCHAR,OUTCHAR) + CHARACTER*(*) INCHAR,OUTCHAR + OUTCHAR = INCHAR(:LENGTH) + RETURN + END + + SUBROUTINE MAKE_CHAR(IARRAY,CHAR_LEN,REAL_LEN) + IMPLICIT INTEGER (A-Z) + DIMENSION IARRAY(1) + IARRAY(1) = CHAR_LEN + IARRAY(2) = %LOC(IARRAY(3)) + IARRAY(REAL_LEN/4+3) = 0 + RETURN + END + + + + SUBROUTINE DISABLE_PRIVS +C +C SUBROUTINE DISABLE_PRIVS +C +C FUNCTION: Disable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($PRVDEF)' + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + DATA PRV_DEPTH /0/ + + COMMON /REALPROC/ REALPROCPRIV(2) + + PRV_DEPTH = PRV_DEPTH + 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(0),,,SETPRV) ! Get privileges + + SETPRV(1) = SETPRV(1).AND..NOT.REALPROCPRIV(1) + + CALL SYS$SETPRV(%VAL(0),SETPRV,,) ! Disable installed privs + + RETURN + END + + + + SUBROUTINE ENABLE_PRIVS +C +C SUBROUTINE ENABLE_PRIVS +C +C FUNCTION: Enable image high privileges. +C + + IMPLICIT INTEGER (A-Z) + + COMMON /PRIVS/ SETPRV,PRV_DEPTH + DIMENSION SETPRV(2) + + PRV_DEPTH = PRV_DEPTH - 1 + + IF (PRV_DEPTH.GT.1) RETURN + + CALL SYS$SETPRV(%VAL(1),SETPRV,,) ! Enable image privs + + RETURN + END + + + + SUBROUTINE CHECK_PRIV_IO(ERROR) +C +C SUBROUTINE CHECK_PRIV_IO +C +C FUNCTION: Checks SYS$OUTPUT and SYS$ERROR to see if they need +C privileges to output to. +C + + IMPLICIT INTEGER (A-Z) + + CALL DISABLE_PRIVS ! Disable SYSPRV + + OPEN (UNIT=6,FILE='SYS$OUTPUT',IOSTAT=IER,STATUS='NEW') + CLOSE (UNIT=6,STATUS='DELETE') + + OPEN (UNIT=4,FILE='SYS$ERROR',IOSTAT=IER1,STATUS='NEW') + IF (IER.NE.0.OR.IER1.NE.0) THEN + IF (IER1.EQ.0) WRITE (4,100) + IF (IER.EQ.0) WRITE (6,200) + ERROR = 1 + ELSE + CLOSE (UNIT=4,STATUS='DELETE') + ERROR = 0 + END IF + + CALL ENABLE_PRIVS ! Enable SYSPRV + +100 FORMAT(1X,'ERROR: SYS$OUTPUT cannot be opened.') +200 FORMAT(1X,'ERROR: SYS$ERROR cannot be opened.') + + RETURN + END + + + SUBROUTINE CHANGE_FLAG(CMD,FLAG) +C +C SUBROUTINE CHANGE_FLAG +C +C FUNCTION: Sets flags for specified folder. +C +C INPUTS: +C CMD - LOGICAL*4 value. If TRUE, set flag. +C If FALSE, clear flag. +C FLAG - If 1, modify NEW_FLAG, if 2, modify SET_FLAG +C If 3, modify BRIEF_FLAG, 4, modify NOTIFY_FLAG +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG) + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + + DATA CHANGE_FOLDER /.FALSE./ + + IF (CLI$PRESENT('FOLDER')) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1) + IF (IER) THEN + FOLDER_NUMBER_SAVE = FOLDER_NUMBER + CALL OPEN_BULLFOLDER_SHARED + CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) + CALL CLOSE_BULLFOLDER + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: No such folder found.'')') + RETURN + ELSE IF (INDEX(FOLDER1,'.').GT.0.OR. + & (FOLDER1(:1).GE.'a'.AND.FOLDER1(:1).LE.'z')) THEN + WRITE (6,'('' ERROR: Command not valid for folder.'')') + RETURN + END IF + END IF + FOLDER_NUMBER = FOLDER1_NUMBER + CHANGE_FOLDER = .TRUE. + ELSE IF (REMOTE_SET.EQ.3) THEN + WRITE (6,'('' ERROR: Command not valid for folder.'')') + RETURN + END IF + +C +C Find user entry in BULLUSER.DAT to update information. +C + + ENTRY CHANGE_FLAG_NOCMD(CMD,FLAG) + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.GT.0) THEN ! No entry (how did this happen??) + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's today + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) ! Fake new entry + CALL READ_USER_FILE_HEADER(IER) + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + ELSE + IF (CMD) THEN + CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) + ELSE + CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) + END IF + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + IF (CMD.AND.FLAG.EQ.4.AND.FOLDER_BBOARD(:2).EQ.'::') THEN + DO WHILE (REC_LOCK(IER)) + READ (4,KEY='*NOTIFY',IOSTAT=IER) TEMP_USER,NOTIFY_REMOTE + END DO + + IF (IER.NE.0) THEN + DO I=1,FLONG + NOTIFY_REMOTE(I) = 0 + END DO + CALL SET2(NOTIFY_REMOTE,FOLDER_NUMBER) + WRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + ELSE + CALL SET2(NOTIFY_REMOTE,FOLDER_NUMBER) + REWRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE + END IF + END IF + + CALL CLOSE_BULLUSER + + IF (CHANGE_FOLDER) THEN + FOLDER_NUMBER = FOLDER_NUMBER_SAVE + CHANGE_FOLDER = .FALSE. + END IF + + RETURN + + END + + + + + SUBROUTINE SET_VERSION +C +C SUBROUTINE SET_VERSION +C +C FUNCTION: Sets version number. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + DIMENSION FLAGS(FLONG,4) + EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) + + LOGICAL CMD + + DIMENSION READ_BTIM_SAVE(2) + +C +C Find user entry in BULLUSER.DAT to update information. +C + + CALL OPEN_BULLUSER_SHARED ! Open user file + + READ_BTIM_SAVE(1) = READ_BTIM(1) + READ_BTIM_SAVE(2) = READ_BTIM(2) + + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + + IF (IER.EQ.0) THEN + NEW_FLAG(1) = 143 + REWRITE (4,IOSTAT=IER) USER_ENTRY ! Write modified entry + READ_BTIM(1) = READ_BTIM_SAVE(1) + READ_BTIM(2) = READ_BTIM_SAVE(2) + END IF + + CALL CLOSE_FILE (4) + RETURN + + END + + + + + + SUBROUTINE CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) +C +C SUBROUTINE CHECK_NEWUSER +C +C FUNCTION: Checks flags for a new: Whether DISMAIL is set, +C and what the last password change was. +C +C INPUTS: +C USERNAME - Username +C OUTPUTS: +C DISMAIL - Returns 1 if account has DISMAIL. +C returns 0 if account has no DISMAIL. +C PASSCHANGE - Date of last password change. +C + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) USERNAME + + INTEGER PASSCHANGE(2) + + INCLUDE '($UAIDEF)' + + CALL INIT_ITMLST + CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) + CALL ADD_2_ITMLST(8,UAI$_PWD_DATE,%LOC(PASSCHANGE)) + CALL END_ITMLST(GETUAI_ITMLST) + + DISMAIL = 0 ! Set return false + IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) ! Read Record + IF (IER) THEN ! If username found + IF (BTEST(FLAGS,UAI$V_NOMAIL)) THEN ! DISMAIL SET? + DISMAIL = 1 ! Yep + END IF + END IF + + RETURN ! Return + END ! End + + + + INTEGER FUNCTION SYS_TRNLNM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + IF (OUTPUT.NE.'DEFINED') CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM = SYS$TRNLNM(,'LNM$FILE_DEV',INPUT(:TRIM(INPUT)),, + & %VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM.AND.OUTPUT.NE.'DEFINED') OUTPUT = OUTPUT(:OLEN) + + RETURN + END + + + + + INTEGER FUNCTION SYS_TRNLNM_SYSTEM(INPUT,OUTPUT) + + IMPLICIT INTEGER (A-Z) + + CHARACTER*(*) INPUT,OUTPUT + + PARAMETER LNM$_STRING = '2'X + + CALL INIT_ITMLST ! Initialize item list + IF (OUTPUT.NE.'DEFINED') CALL ADD_2_ITMLST_WITH_RET + & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) + CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist + + SYS_TRNLNM_SYSTEM = SYS$TRNLNM(,'LNM$SYSTEM', + & INPUT(:TRIM(INPUT)),,%VAL(TRNLNM_ITMLST)) + + IF (SYS_TRNLNM_SYSTEM.AND.OUTPUT.NE.'DEFINED') THEN + OUTPUT = OUTPUT(:OLEN) + END IF + + RETURN + END + + + + INTEGER FUNCTION FILE_LOCK(IER,IER1) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($RMSDEF)' + + DATA INIT /.TRUE./ + + IF (INIT) THEN + FILE_LOCK = 1 + INIT = .FALSE. + ELSE + IF (IER.GT.0) THEN + CALL ERRSNS(IDUMMY,IER1) + IF (IER1.EQ.RMS$_FLK) THEN + FILE_LOCK = 1 + CALL WAIT_SEC('01') + ELSE + FILE_LOCK = 0 + INIT = .TRUE. + END IF + ELSE + FILE_LOCK = 0 + IER1 = 0 + INIT = .TRUE. + END IF + END IF + + RETURN + END + + + + SUBROUTINE ENABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + + COMMON /DEF_PROT/ ORIGINAL_DEF_PROT + + COMMON /KEYPAD/ KEYPAD_MODE + + QUIT = 1 + + ENTRY ENABLE_CTRL_EXIT + + QUIT = QUIT.AND.1 ! If called via entry, QUIT = 0 + IF (QUIT.EQ.1) LEVEL = LEVEL - 1 + + IF (LEVEL.LT.0.AND.QUIT.EQ.1) THEN + WRITE (6,'('' ERROR: Error in CTRL.'')') + END IF + + IF (LEVEL.EQ.0.OR.QUIT.EQ.0) THEN + CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C + END IF + + IF (QUIT.EQ.0) THEN + IF (KEYPAD_MODE.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,) + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1) + END IF + CALL CLOSE_TAG + CALL UPDATE_USERINFO + CALL PRINT_NOW + CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) + CALL EXIT + END IF + QUIT = 0 ! Reinitialize + + RETURN + END + + + SUBROUTINE DISABLE_CTRL + + IMPLICIT INTEGER (A-Z) + + COMMON /CTRLY/ CTRLY + + COMMON /CTRL_LEVEL/ LEVEL + DATA LEVEL /0/ + + IF (LEVEL.EQ.0) CALL LIB$DISABLE_CTRL(CTRLY,) + LEVEL = LEVEL + 1 + + RETURN + END + + + + + SUBROUTINE CLEANUP_BULLFILE +C +C SUBROUTINE CLEANUP_BULLFILE +C +C FUNCTION: Searches for empty space in bulletin file and deletes it. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + CHARACTER FILENAME*132,BUFFER*128 + + CALL OPEN_BULLDIR_SHARED + +C +C NOTE: Can't use READDIR for reading header since it'll spawn a +C BULL/CLEANUP. (Fooey). +C + + DO WHILE (REC_LOCK(IER)) + READ (2,KEYID=0,KEY=HEADER_KEY,IOSTAT=IER) BULLDIR_HEADER + END DO + + IF (NEMPTY.EQ.0) THEN ! No cleanup necessary + CALL CLOSE_BULLDIR + RETURN + ELSE IF (NEMPTY.GT.0) THEN + + CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) + ! Set protection to (SYSTEM:RWED,OWNER:RWED,,) + + OPEN (UNIT=11,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + 1 STATUS='UNKNOWN',IOSTAT=IER,DISPOSE='DELETE', + 1 RECORDTYPE='FIXED',RECORDSIZE=32, + 1 FORM='UNFORMATTED',INITIALSIZE=((NBLOCK-NEMPTY)*128)/512) + ! Compressed version is number 1 + + IF (IER.NE.0) THEN + WRITE (6,'('' Cannot open temporary file for'' + & ,'' compressing '',A)') FOLDER(:TRIM(FOLDER)) + CALL ERRSNS(IDUMMY,IER) + IF (IER1.EQ.0) THEN + WRITE (6,'('' IOSTAT error = '',I)') IER + ELSE + CALL SYS_GETMSG(IER1) + END IF + CALL CLOSE_BULLDIR + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + END IF + + CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL', + & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL') + + CALL OPEN_BULLFIL_SHARED ! Open bulletin file + + NBLOCK = 0 + + DO I=1,NBULL ! Copy bulletins to new file + CALL READDIR(I,IER) + ICOUNT = BLOCK + DO J=1,LENGTH + NBLOCK = NBLOCK + 1 + DO WHILE (REC_LOCK(IER1)) + READ(1'ICOUNT,IOSTAT=IER1) BUFFER + END DO + IF (IER1.NE.0) THEN ! This file is corrupt + NBLOCK = NBLOCK - 1 + NBULL = I - 1 + GO TO 100 + END IF + WRITE(11) BUFFER + ICOUNT = ICOUNT + 1 + END DO + END DO + +100 CALL CLOSE_BULLFIL + ELSE IF (NEMPTY.EQ.-1) THEN + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + RETURN + END IF + + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', + & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+1 ) + + IF (IER.NE.0) THEN + OPEN (UNIT=12,FILE=FOLDER_FILE(1:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + IF (IER.NE.0) THEN + CLOSE (UNIT=11) + CALL CLOSE_BULLDIR + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + RETURN + END IF + END IF + + CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR', + & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR') + + NEMPTY = 0 + WRITE (12,IOSTAT=IER) BULLDIR_HEADER ! Write directory header + + NBLOCK = 0 ! Update directory entry pointers + DO I=1,NBULL + CALL READDIR(I,IER) + BLOCK = NBLOCK + 1 + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE (12,IOSTAT=IER) BULLDIR_ENTRY + NBLOCK = NBLOCK + LENGTH + END DO + + CLOSE (UNIT=12,STATUS='KEEP') + CLOSE (UNIT=11,STATUS='KEEP') + + CALL CLOSE_BULLDIR + CALL OPEN_BULLDIR ! Open with no sharing + + NEMPTY = -1 ! Copying done, indicate that in case of crash + WRITE (2,IOSTAT=IER) BULLDIR_HEADER ! Write new directory header + + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', + & '*.BULLFIL') + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLFIL;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', + & '*.BULLDIR') + CALL CLOSE_BULLDIR_DELETE + IER = 1 + DO WHILE (IER) + IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.BULLDIR;-1') + END DO + IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', + & '*.*;1') + + CALL SYS$SETDFPROT(CUR_DEF_PROT,) + + RETURN + END + + + + + SUBROUTINE CLEANUP_DIRFILE(DELETE_ENTRY) +C +C SUBROUTINE CLEANUP_DIRFILE +C +C FUNCTION: Reorder directory file after deletions. +C Is called either directly after a deletion, or is +C called if it is detected that a deletion was not fully +C completed due to the fact that the deleting process +C was abnormally terminated. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + CHARACTER*11 DATE_SAVE,EXDATE_SAVE + CHARACTER*11 TIME_SAVE,EXTIME_SAVE + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + DATE_SAVE = DATE + TIME_SAVE = TIME + EXDATE_SAVE = EXDATE + EXTIME_SAVE = EXTIME + + NBULL = -NBULL ! Negative # Bulls signals deletion in progress + MOVE_TO = 0 ! Moving directory entries starting here + MOVE_FROM = 0 ! Moving directory entries from here + I = DELETE_ENTRY ! Start search point for first deleted entries + DO WHILE (MOVE_TO.EQ.0.AND.I.LE.NBULL) + CALL READDIR(I,IER) + IF (IER.NE.I+1) THEN ! Have we found a deleted entry? + MOVE_TO = I ! If so, start moving entries to here + J=I+1 ! Search for next entry in file + DO WHILE (MOVE_FROM.EQ.0.AND.J.LE.NBULL) + CALL READDIR(J,IER) + IF (IER.EQ.J+1) MOVE_FROM = J + J = J + 1 + END DO + IF (MOVE_FROM.EQ.0) THEN ! There are no more entries + NBULL = I - 1 ! so just update number of bulletins + CALL WRITEDIR(0,IER) + RETURN + END IF + LENGTH = -LENGTH ! Indicate starting point by writing + CALL WRITEDIR(I,IER) ! next entry into deleted entry + FIRST_DELETE = I ! with negative length + MOVE_FROM = MOVE_FROM + 1 ! Set up pointers to move rest of + MOVE_TO = MOVE_TO + 1 ! the entries + ELSE IF (LENGTH.LT.0) THEN ! If negative length found, deletion + FIRST_DELETE = I ! was previously in progress + J = I ! Try to find where entry came from + CALL INIT_QUEUE(ENTRY_Q1,BULLDIR_ENTRY) + ENTRY_Q = ENTRY_Q1 + DO K=J,NBULL + CALL READDIR(K,IER) + IF (IER.EQ.K+1) THEN + CALL WRITE_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + END IF + END DO + ENTRY_QLAST = ENTRY_Q + ENTRY_Q2 = ENTRY_Q1 + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q2.NE.ENTRY_QLAST) + CALL READ_QUEUE(%VAL(ENTRY_Q2),ENTRY_Q,BULLDIR_ENTRY) + ENTRY_Q2 = ENTRY_Q + BLOCK_SAVE = BLOCK + MSG_NUM_SAVE = MSG_NUM + DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q.NE.ENTRY_QLAST) + ! Search for duplicate entries + CALL READ_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) + IF (BLOCK_SAVE.EQ.BLOCK) THEN + MOVE_TO = MSG_NUM_SAVE + 1 + MOVE_FROM = MSG_NUM + 1 + END IF + END DO + ! If no duplicate entry found for this + ! entry, see if one exists for any + END DO ! of the other entries + END IF + I = I + 1 + END DO + + IF (I.LE.NBULL) THEN ! Move reset of entries if necessary + IF (MOVE_FROM.GT.0) THEN + DO J=MOVE_FROM,NBULL + CALL READDIR(J,IER) + IF (IER.EQ.J+1) THEN ! Skip any other deleted entries + CALL WRITEDIR(MOVE_TO,IER) + MOVE_TO = MOVE_TO + 1 + END IF + END DO + END IF + DO J=MOVE_TO,NBULL ! Delete empty records at end of file + CALL READDIR(J,IER) + DELETE(UNIT=2,IOSTAT=IER) + END DO + NBULL = MOVE_TO - 1 ! Update # bulletin count + END IF + + CALL READDIR(FIRST_DELETE,IER) + IF (IER.EQ.FIRST_DELETE+1.AND.LENGTH.LT.0) THEN + LENGTH = -LENGTH ! Fix entry which has negative length + CALL WRITEDIR(FIRST_DELETE,IER) + END IF + + CALL WRITEDIR(0,IER) + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + DATE = DATE_SAVE + TIME = TIME_SAVE + EXDATE = EXDATE_SAVE + EXTIME = EXTIME_SAVE + + RETURN + END + + + SUBROUTINE SHOW_FLAGS +C +C SUBROUTINE SHOW_FLAGS +C +C FUNCTION: Show user flags. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + +C +C Find user entry in BULLUSER.DAT to obtain flags. +C + IF (REMOTE_SET.NE.3) THEN + CALL OPEN_BULLUSER_SHARED ! Open user file + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry + ELSE IF (NEWS_FIND_SUBSCRIBE().GT.FOLDER_MAX) THEN + WRITE (6,'('' ERROR: NEWS FOLDER is not subscribed.'')') + RETURN + END IF + + WRITE (6,'('' For the selected folder '',A)') + & FOLDER_NAME(1:TRIM(FOLDER_NAME)) + + IF (REMOTE_SET.NE.3.AND.TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' NOTIFY is set.'')') + END IF + + IF (TEST_SET_FLAG(FOLDER_NUMBER).AND. + & (.NOT.TEST_BRIEF_FLAG(FOLDER_NUMBER))) THEN + WRITE (6,'('' READNEW is set.'')') + ELSE IF (TEST_BRIEF_FLAG(FOLDER_NUMBER).AND. + & TEST_SET_FLAG(FOLDER_NUMBER)) THEN + WRITE (6,'('' BRIEF is set.'')') + ELSE IF (TEST_BRIEF_FLAG(FOLDER_NUMBER).AND. + & .NOT.TEST_SET_FLAG(FOLDER_NUMBER)) THEN + WRITE (6,'('' SHOWNEW is set.'')') + ELSE IF (REMOTE_SET.EQ.3.OR. + & .NOT.TEST2(NOTIFY_FLAG,FOLDER_NUMBER)) THEN + WRITE (6,'('' No flags are set.'')') + END IF + + IF (REMOTE_SET.NE.3) CALL CLOSE_BULLUSER + + RETURN + END + + + SUBROUTINE SET2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(2) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBSET(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + SUBROUTINE CLR2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + FLAG(F_POINT) = IBCLR(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + LOGICAL FUNCTION TEST2(FLAG,NUMBER) + + IMPLICIT INTEGER (A-Z) + + INTEGER FLAG(3) + + F_POINT = NUMBER/32 + 1 + TEST2 = BTEST(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) + + RETURN + END + + + + + INTEGER FUNCTION GETUSERS(USERNAME,TERMINAL) +C +C FUNCTION GETUSERS +C +C FUNCTION: +C To get names of all users that are logged in. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($JPIDEF)' + +!*** MODULE $PSCANDEF *** + PARAMETER pscan$_BEGIN = '00000000'X + PARAMETER pscan$_ACCOUNT = '00000001'X + PARAMETER pscan$_AUTHPRI = '00000002'X + PARAMETER pscan$_CURPRIV = '00000003'X + PARAMETER pscan$_GRP = '00000004'X + PARAMETER pscan$_HW_MODEL = '00000005'X + PARAMETER pscan$_HW_NAME = '00000006'X + PARAMETER pscan$_JOBPRCCNT = '00000007'X + PARAMETER pscan$_JOBTYPE = '00000008'X + PARAMETER pscan$_MASTER_PID = '00000009'X + PARAMETER pscan$_MEM = '0000000A'X + PARAMETER pscan$_MODE = '0000000B'X + PARAMETER pscan$_NODE_CSID = '0000000C'X + PARAMETER pscan$_NODENAME = '0000000D'X + PARAMETER pscan$_OWNER = '0000000E'X + PARAMETER pscan$_PRCCNT = '0000000F'X + PARAMETER pscan$_PRCNAM = '00000010'X + PARAMETER pscan$_PRI = '00000011'X + PARAMETER pscan$_PRIB = '00000012'X + PARAMETER pscan$_STATE = '00000013'X + PARAMETER pscan$_STS = '00000014'X + PARAMETER pscan$_TERMINAL = '00000015'X + PARAMETER pscan$_UIC = '00000016'X + PARAMETER pscan$_USERNAME = '00000017'X + PARAMETER pscan$_GETJPI_BUFFER_SIZE = '00000018'X + PARAMETER pscan$_END = '00000019'X + PARAMETER pscan$k_type = '00000081'X + PARAMETER pscan$M_OR = '00000001'X + PARAMETER pscan$M_BIT_ALL = '00000002'X + PARAMETER pscan$M_BIT_ANY = '00000004'X + PARAMETER pscan$M_GEQ = '00000008'X + PARAMETER pscan$M_GTR = '00000010'X + PARAMETER pscan$M_LEQ = '00000020'X + PARAMETER pscan$M_LSS = '00000040'X + PARAMETER pscan$M_PREFIX_MATCH = '00000080'X + PARAMETER pscan$M_WILDCARD = '00000100'X + PARAMETER pscan$M_CASE_BLIND = '00000200'X + PARAMETER pscan$M_EQL = '00000400'X + PARAMETER pscan$M_NEQ = '00000800'X + STRUCTURE /item_specific_flags/ + PARAMETER pscan$S_OR = 1 + PARAMETER pscan$V_OR = 0 + PARAMETER pscan$S_BIT_ALL = 1 + PARAMETER pscan$V_BIT_ALL = 1 + PARAMETER pscan$S_BIT_ANY = 1 + PARAMETER pscan$V_BIT_ANY = 2 + PARAMETER pscan$S_GEQ = 1 + PARAMETER pscan$V_GEQ = 3 + PARAMETER pscan$S_GTR = 1 + PARAMETER pscan$V_GTR = 4 + PARAMETER pscan$S_LEQ = 1 + PARAMETER pscan$V_LEQ = 5 + PARAMETER pscan$S_LSS = 1 + PARAMETER pscan$V_LSS = 6 + PARAMETER pscan$S_PREFIX_MATCH = 1 + PARAMETER pscan$V_PREFIX_MATCH = 7 + PARAMETER pscan$S_WILDCARD = 1 + PARAMETER pscan$V_WILDCARD = 8 + PARAMETER pscan$S_CASE_BLIND = 1 + PARAMETER pscan$V_CASE_BLIND = 9 + PARAMETER pscan$S_EQL = 1 + PARAMETER pscan$V_EQL = 10 + PARAMETER pscan$S_NEQ = 1 + PARAMETER pscan$V_NEQ = 11 + BYTE %FILL (2) + END STRUCTURE + + CHARACTER USERNAME*(*),TERMINAL*(*) + + DATA CONTEXT/0/ + + IF (CONTEXT.EQ.0) THEN + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST_WITH_RET(0,PSCAN$_NODE_CSID,0,PSCAN$M_NEQ) + CALL ADD_2_ITMLST(0,PSCAN$_MODE,JPI$K_INTERACTIVE) + CALL END_ITMLST(PSCAN_ITMLST) ! Get address of itemlist + + IER = SYS$PROCESS_SCAN(CONTEXT,%VAL(PSCAN_ITMLST)) + END IF + + CALL INIT_ITMLST ! Initialize item list + ! Now add items to list + CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) + CALL ADD_2_ITMLST(LEN(TERMINAL),JPI$_TERMINAL,%LOC(TERMINAL)) + CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist + + IER = 1 + TERMINAL(1:1) = CHAR(0) + DO WHILE (IER.AND.TERMINAL(1:1).EQ.CHAR(0)) + ! Get next interactive process + IER = SYS$GETJPIW(,CONTEXT,,%VAL(GETJPI_ITMLST),,,,) + ! Get next process. + END DO + + IF (.NOT.IER) CONTEXT = 0 + + GETUSERS = IER + + RETURN + END + + + + + + SUBROUTINE OPEN_USERINFO +C +C SUBROUTINE OPEN_USERINFO +C +C FUNCTION: Opens the file in SYS$LOGIN which contains user information. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /USERINFO/ USERINFO_READ,OLD_LAST_READ_BTIM(2,FOLDER_MAX) + COMMON /USERINFO/ OLD_LAST_SYS_BTIM(2,FOLDER_MAX) + COMMON /USERINFO/ OLD_LAST_NEWS_READ(2,FOLDER_MAX) + DATA USERINFO_READ /.FALSE./ + + EQUIVALENCE (LAST_READ_BTIM(1,1),LAST(1,1)) + DIMENSION LAST(2,FOLDER_MAX) + + INTEGER TODAY_BTIM(2) + + CALL OPEN_BULLINF_SHARED + + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME,LAST + + IF (IER.EQ.0) THEN ! Check to see if dates all in future + CALL SYS_BINTIM('-',TODAY_BTIM) ! Get today's date + DO I=1,FOLDER_MAX + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,I),TODAY_BTIM) + IF (DIFF.GE.0) THEN ! Must have been in a time wrap + LAST_READ_BTIM(1,I) = TODAY_BTIM(1) + LAST_READ_BTIM(2,I) = TODAY_BTIM(2) + END IF + END DO + END IF + + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2 ! Is this BULLCP process? + & .AND.CONFIRM_USER(USERNAME).NE.0) THEN ! Not real user? + USERNAME = 'DECNET' + READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME,LAST + END IF + + IF (IER.NE.0) THEN + OPEN (UNIT=10,FILE='SYS$LOGIN:BULLETIN.INF',STATUS='OLD', + & RECORDTYPE='FIXED',FORM='UNFORMATTED',IOSTAT=IER) + INQUIRE(UNIT=10,RECORDSIZE=INF_SIZE) + IF (IER.EQ.0) THEN + READ (10) + & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,INF_SIZE/2) + CLOSE (UNIT=10,STATUS='DELETE') + ELSE + CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file + CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Find user's info + CALL CLOSE_BULLUSER + IF (IER.NE.0.AND.TEST_BULLCP().EQ.2) THEN ! BULLCP process? + CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's date + CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) + CALL READ_USER_FILE_HEADER(IER) + NEW_FLAG(1) = 143 + NEW_FLAG(2) = 0 + CALL WRITE_USER_FILE_NEW(IER) + END IF + IF (IER.EQ.0) THEN + DO I=1,FOLDER_MAX + LAST_READ_BTIM(1,I) = READ_BTIM(1) + LAST_READ_BTIM(2,I) = READ_BTIM(2) + END DO + END IF + END IF + IF (IER.EQ.0) WRITE (9,IOSTAT=IER) USERNAME,LAST + END IF + + LU = TRIM(USERNAME) + USERNAME(LU:LU) = CHAR(128.OR.ICHAR(USERNAME(LU:LU))) + READ (9,KEY=USERNAME,IOSTAT=IER1) USERNAME,LAST_SYS_BTIM + USERNAME(LU:LU) = CHAR(127.AND.ICHAR(USERNAME(LU:LU))) + IF (IER1.NE.0) THEN + DO I=1,FOLDER_MAX + LAST_SYS_BTIM(1,I) = 0 + LAST_SYS_BTIM(2,I) = 0 + END DO + END IF + + USERNAME(LU:LU) = CHAR(128.OR.ICHAR(USERNAME(LU:LU))) + IF (LU.GT.1) THEN + USERNAME(LU-1:LU-1) = CHAR(128.OR.ICHAR(USERNAME(LU-1:LU-1))) + ELSE + USERNAME(2:2) = CHAR(128.OR.ICHAR(USERNAME(2:2))) + END IF + READ (9,KEY=USERNAME,IOSTAT=IER1) USERNAME,LAST_NEWS_READ + USERNAME(LU:LU) = CHAR(127.AND.ICHAR(USERNAME(LU:LU))) + IF (LU.GT.1) THEN + USERNAME(LU-1:LU-1) = CHAR(127.AND.ICHAR(USERNAME(LU-1:LU-1))) + ELSE + USERNAME(2:2) = CHAR(127.AND.ICHAR(USERNAME(2:2))) + END IF + IF (IER1.NE.0) THEN + DO I=1,FOLDER_MAX + LAST_NEWS_READ(1,I) = 0 + LAST_NEWS_READ(2,I) = 0 + END DO + END IF + + CALL CLOSE_BULLINF + + CALL LIB$MOVC3(FOLDER_MAX*2*4,LAST_READ_BTIM,OLD_LAST_READ_BTIM) + CALL LIB$MOVC3(FOLDER_MAX*2*4,LAST_SYS_BTIM,OLD_LAST_SYS_BTIM) + CALL LIB$MOVC3(FOLDER_MAX*2*4,LAST_NEWS_READ,OLD_LAST_NEWS_READ) + + USERINFO_READ = .TRUE. + + RETURN + END + + + + SUBROUTINE UPDATE_USERINFO +C +C SUBROUTINE UPDATE_USERINFO +C +C FUNCTION: Updates the latest message read times for each folder. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLUSER.INC' + + COMMON /USERINFO/ USERINFO_READ,OLD_LAST_READ_BTIM(2,FOLDER_MAX) + COMMON /USERINFO/ OLD_LAST_SYS_BTIM(2,FOLDER_MAX) + COMMON /USERINFO/ OLD_LAST_NEWS_READ(2,FOLDER_MAX) + + EQUIVALENCE (LAST_READ_BTIM(1,1),LAST(1,1)) + DIMENSION LAST(2,FOLDER_MAX) + + IF (.NOT.USERINFO_READ) RETURN + + DIFF = .FALSE. + FNUM = 1 + + DO WHILE (.NOT.DIFF.AND.FNUM.LE.FOLDER_MAX) + DIFF = LAST_READ_BTIM(1,FNUM).NE.OLD_LAST_READ_BTIM(1,FNUM) + IF (.NOT.DIFF) THEN + DIFF = LAST_READ_BTIM(2,FNUM).NE.OLD_LAST_READ_BTIM(2,FNUM) + END IF + FNUM = FNUM + 1 + END DO + + DIFF1 = .FALSE. + FNUM = 1 + + DO WHILE (.NOT.DIFF1.AND.FNUM.LE.FOLDER_MAX) + DIFF1 = LAST_SYS_BTIM(1,FNUM).NE.OLD_LAST_SYS_BTIM(1,FNUM) + IF (.NOT.DIFF1) THEN + DIFF1 = LAST_SYS_BTIM(2,FNUM).NE.OLD_LAST_SYS_BTIM(2,FNUM) + END IF + FNUM = FNUM + 1 + END DO + + DIFF2 = .FALSE. + FNUM = 1 + + DO WHILE (.NOT.DIFF2.AND.FNUM.LE.FOLDER_MAX) + DIFF2 = LAST_NEWS_READ(1,FNUM).NE.OLD_LAST_NEWS_READ(1,FNUM) + IF (.NOT.DIFF2) THEN + DIFF2 = LAST_NEWS_READ(2,FNUM).NE.OLD_LAST_NEWS_READ(2,FNUM) + END IF + FNUM = FNUM + 1 + END DO + + IF (.NOT.(DIFF.OR.DIFF1.OR.DIFF2)) RETURN + + CALL OPEN_BULLINF_SHARED + + IF (DIFF) THEN + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) REWRITE (9,IOSTAT=IER) USERNAME,LAST + END IF + + IF (DIFF1) THEN + LU = TRIM(USERNAME) + USERNAME(LU:LU) = CHAR(128.OR.ICHAR(USERNAME(LU:LU))) + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (9,IOSTAT=IER) USERNAME,LAST_SYS_BTIM + ELSE + WRITE (9,IOSTAT=IER) USERNAME,LAST_SYS_BTIM + END IF + USERNAME(LU:LU) = CHAR(127.AND.ICHAR(USERNAME(LU:LU))) + END IF + + IF (DIFF2) THEN + LU = TRIM(USERNAME) + USERNAME(LU:LU) = CHAR(128.OR.ICHAR(USERNAME(LU:LU))) + IF (LU.GT.1) THEN + USERNAME(LU-1:LU-1) = CHAR(128.OR.ICHAR(USERNAME(LU-1:LU-1))) + ELSE + USERNAME(2:2) = CHAR(128.OR.ICHAR(USERNAME(2:2))) + END IF + READ (9,KEY=USERNAME,IOSTAT=IER) + IF (IER.EQ.0) THEN + REWRITE (9,IOSTAT=IER) USERNAME,LAST_NEWS_READ + ELSE + WRITE (9,IOSTAT=IER) USERNAME,LAST_NEWS_READ + END IF + IF (LU.GT.1) THEN + USERNAME(LU-1:LU-1) = CHAR(127.AND.ICHAR(USERNAME(LU-1:LU-1))) + ELSE + USERNAME(2:2) = CHAR(127.AND.ICHAR(USERNAME(2:2))) + END IF + END IF + + CALL CLOSE_BULLINF + + RETURN + END + + + INTEGER FUNCTION SYS_BINTIM(TIME,BTIM) + + IMPLICIT INTEGER (A-Z) + + INTEGER BTIM(2) + + CHARACTER*(*) TIME + + IF (TRIM(TIME).EQ.20) THEN + SYS_BINTIM = SYS$BINTIM(TIME//'.00',BTIM) + ELSE + SYS_BINTIM = SYS$BINTIM(TIME,BTIM) + END IF + + RETURN + END + + + + + SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C SUBROUTINE NEW_MESSAGE_NOTIFICATION +C +C FUNCTION: +C +C Update user's last read bulletin date. If new bulletins have been +C added since the last time bulletins have been read, position bulletin +C pointer so that next bulletin read is the first new bulletin, and +C alert user. If READNEW set and no new bulletins, just exit. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /READIT/ READIT + + COMMON /POINT/ BULL_POINT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH + COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) + COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE + CHARACTER*1 SEPARATE + + COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM + + COMMON /LOGIN_BTIM/ LOGIN_BTIM_SAVE(2) + + COMMON /COMMAND_LINE/ INCMD + CHARACTER*132 INCMD + + IF (INCMD(:4).EQ.'SHOW') THEN + CALL READ_IN_FOLDERS ! Read folder info + ELSE IF (.NOT.LOGIN_SWITCH) THEN + LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) + LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) + CALL UPDATE_READ(0) ! Update login time + IF (CLI$PRESENT('SELECT_FOLDER')) THEN + CALL SELECT_FOLDER(.TRUE.,IER) + IF (IER) RETURN + END IF + CALL READ_IN_FOLDERS ! Read folder info + ELSE + LOGIN_SWITCH = .FALSE. ! So LOGIN_FOLDER entry doesn't + END IF ! think it's called via LOGIN + + FOLDER_Q = SAVE_FOLDER_Q1 + + DO I = 1,SAVE_FOLDER_NUM + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + CALL CLR2(NEW_MSG,FOLDER_NUMBER) ! Clear new message flag + IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + CALL SET2(NEW_MSG,FOLDER_NUMBER) + ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & (FOLDER_NUMBER.GT.0.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND.READIT.EQ.1)) THEN + IF (READIT.EQ.1.AND.SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM, + & F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.READIT.EQ.1) THEN + IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & NEW_FLAG(2).NE.-1) THEN + DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + END IF + IF (FOLDER_BBOARD(:2).EQ.'::'.AND.DIFF.GE.0) THEN + IER = MINUTE_DIFF(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) + IF (IER.LE.15) DIFF = -1 + END IF + END IF + END IF + IF (F_NBULL.GT.0.AND.(DIFF.LT.0.OR.(READIT.EQ.1.AND. + & BTEST(FOLDER_FLAG,7)))) THEN ! If new unread messages + CALL SET2(NEW_MSG,FOLDER_NUMBER) ! Set new message flag + END IF + END IF + END DO + + FOLDER_Q = SAVE_FOLDER_Q1 + + IF (READIT.EQ.0) THEN ! If not in READNEW mode + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + NEW_MESS = .FALSE. + DO I = 1,SAVE_FOLDER_NUM-1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0) THEN ! Are there unread messages? + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_NOSYS_BTIM) + IF (DIFF.GT.0) THEN ! Unread non-system messages? + DIFF = COMPARE_BTIM(LOGIN_BTIM,F_NEWEST_BTIM) + ! No. Unread system messages? + IF (DIFF.GT.0) THEN ! No, update last read time. + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = + & F_NEWEST_BTIM(2) + END IF + END IF + IF (DIFF.LT.0) THEN + WRITE (6,'('' There are new messages in '', + & ''folder '',A,''.'',$)') FOLDER(1:TRIM(FOLDER)) + NEW_MESS = .TRUE. + END IF + END IF + END IF + END DO + CALL NEWS_NEW_NOTIFICATION(NEWS_MESS) + IF (INCMD(:4).EQ.'SHOW') THEN + SAVE_FOLDER_Q1 = 0 + RETURN + END IF + IF (NEW_MESS.OR.NEWS_MESS) THEN + WRITE (6,'('' Type SELECT followed by foldername to'', + & '' read above messages.'')') + END IF + SAVE_FOLDER_Q1 = 0 + FOLDER_NUMBER = 0 + CALL SELECT_FOLDER(.FALSE.,IER) + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN + CALL FIND_NEWEST_BULL ! See if there are new messages + IF (BULL_POINT.NE.-1) THEN + WRITE(6,'('' Type READ to read new GENERAL messages.'')') + NEW_COUNT = F_NBULL - BULL_POINT + DIG = 0 + DO WHILE (NEW_COUNT.GT.0) + NEW_COUNT = NEW_COUNT / 10 + DIG = DIG + 1 + END DO + WRITE(6,'('' There are '',I,'' new messages.'')') + & F_NBULL - BULL_POINT ! Alert user if new bulletins + ELSE + BULL_POINT = 0 + LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) + LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) + END IF + END IF + ELSE ! READNEW mode. + DO I = 1,SAVE_FOLDER_NUM + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN + CALL SELECT_FOLDER(.FALSE.,IER) + IF (IER) THEN + IF (SYSTEM_SWITCH.AND. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN + DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,F_NEWEST_BTIM) + ELSE + DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & F_NEWEST_BTIM) + IF (BTEST(FOLDER_FLAG,7)) DIFF = -1 + IF (DIFF.LT.0.AND.TEST2(BRIEF_FLAG,FOLDER_NUMBER) + & .AND.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + IF (DIFF.LT.0) THEN + IF (FOLDER_NUMBER.GT.0) CALL LOGIN_FOLDER + IF (BULL_POINT.NE.-1.OR.NEW_FLAG(2).EQ.-1.OR. + & .NOT.TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) + & WRITE (6,'('' There are new messages in folder '' + & ,A,''.'')') FOLDER(1:TRIM(FOLDER)) + ELSE + WRITE (6,'('' There are new messages in folder '' + & ,A,''.'')') FOLDER(1:TRIM(FOLDER)) + END IF + DIFF = 0 + END IF + END IF + IF (DIFF.LT.0) THEN + IF (FOLDER_NUMBER.GT.0) CALL LOGIN_FOLDER + IF (BULL_POINT.NE.-1) THEN + IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN + SAVE_BULL_POINT = BULL_POINT + REDO = .TRUE. + DO WHILE (REDO) + REDO = .FALSE. + CALL READNEW(REDO) + IF (REDO) CALL REDISPLAY_DIRECTORY + BULL_POINT = SAVE_BULL_POINT + END DO + END IF + END IF + END IF + END IF + END IF + END DO + CALL NEWS_NEW_NOTIFICATION(NEWS_MESS) + CALL EXIT + END IF + + RETURN + END + + + + + SUBROUTINE READ_IN_FOLDERS + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM + DATA SAVE_FOLDER_Q1/0/ + + COMMON /READIT/ READIT + + COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) + + COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA + COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) + + CALL INIT_QUEUE(SAVE_FOLDER_Q1,FOLDER_COM) + FOLDER_Q = SAVE_FOLDER_Q1 + + CALL OPEN_BULLFOLDER_SHARED ! Go find folders + + SAVE_FOLDER_NUM = 0 + + FOLDER_NUMBER = 0 + CALL READ_FOLDER_FILE_KEYNUM(FOLDER_NUMBER,IER) + DO WHILE (IER.EQ.0) + SAVE_FOLDER_NUM = SAVE_FOLDER_NUM + 1 + IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 + & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN + ELSE IF ((NEW_FLAG(1).LT.142.OR.NEW_FLAG(1).GT.143).AND. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. + & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN + CALL CHANGE_FLAG_NOCMD(0,3) + CALL SET_VERSION + ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. + & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. + & (FOLDER_NUMBER.GT.0.AND.(BTEST(FOLDER_FLAG,2).OR. + & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)).AND.READIT.EQ.1)) THEN +C +C Unknown problem caused system folder flag in folder file to disappear +C so this tests to see if the flag has disappeared and resets if needed. +C + IF (TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND. + & .NOT.BTEST(FOLDER_FLAG,2)) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,2) + CALL REWRITE_FOLDER_FILE + ELSE IF (.NOT.TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND. + & BTEST(FOLDER_FLAG,2)) THEN + CALL MODIFY_SYSTEM_LIST(1) + END IF + END IF + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + CALL READ_FOLDER_FILE_KEYNUM_GT(FOLDER_NUMBER,IER) + END DO + + CALL CLOSE_BULLFOLDER + + FOLDER_Q = SAVE_FOLDER_Q1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) + + RETURN + END + + + + + SUBROUTINE DISCONNECT_REMOTE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + WRITE (6,'('' ERROR: Connection to remote folder disconnected.'')') + + FOLDER_NUMBER = -1 + FOLDER1 = 'GENERAL' + + CALL SELECT_FOLDER(.FALSE.,IER) + + WRITE (6,'('' Resetting to GENERAL folder.'')') + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/bulletin8.for b/decus/vax91b/gce91b/net91b/bulletin8.for new file mode 100644 index 0000000..11bd330 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin8.for @@ -0,0 +1,1884 @@ +C +C BULLETIN8.FOR, Version 6/22/91 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: MIT PFC VAX-11/780, 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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(MAXLINK) + INTEGER*2 WRITE_IOSB + LOGICAL*1 WRITE_BUF + + CHARACTER NAMEDESC*9 /'BULLETIN1'/ + CHARACTER NAMEDESC1*4 /'NNTP'/ + + DIMENSION NFBDESC(2) + LOGICAL*1 NFB(5) + + EXTERNAL IO$_ACPCONTROL + + 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 + + IF (.NOT.GATEWAY_ONLY) THEN + IER = SYS$CREMBX(%VAL(0),MBX_CHAN,%VAL(132),%VAL(528),,, + & 'BULL_MBX') + IF (.NOT.IER) CALL EXIT(IER) + + IER = SYS$ASSIGN('_NET:',DCL_CHAN,,'BULL_MBX') ! Assign net device + IF (.NOT.IER) CALL EXIT(IER) + + IER = SYS$QIOW(,%VAL(DCL_CHAN),IO$_ACPCONTROL,,,, + & NFBDESC,NAMEDESC,,,,) + IF (.NOT.IER) CALL EXIT(IER) + + 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 EXIT(IER) + + IER = SYS$ASSIGN('_NET:',DCL_CHAN1,,'BULL_MBX1') + IF (.NOT.IER) CALL EXIT(IER) + + IER = SYS$QIOW(,%VAL(DCL_CHAN1),IO$_ACPCONTROL,,,, + & NFBDESC,NAMEDESC1,,,,) + IF (.NOT.IER) CALL EXIT(IER) + + CALL SYS$SETAST(%VAL(0)) + CALL READ_MBX(DCL_CHAN1) + CALL SYS$SETAST(%VAL(1)) + END IF + + DO I=1,MAXLINK + CALL LIB$GET_EF(READ_EFS(I)) + CALL LIB$GET_EF(WRITE_EFS(I)) + END DO + + IF (GATEWAY_ONLY) CALL SYS$HIBER() + + RETURN + END + + + SUBROUTINE SETDEFAULT(USERNAME) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LNMDEF)' + + INCLUDE '($PSLDEF)' + + INCLUDE '($UAIDEF)' + + CHARACTER DEFDIR*64,DEFDEV*16,USERNAME*(*),ACCOUNT*9 + 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 EXIT(IER) + + RETURN + + END + + + + + SUBROUTINE MBX_AST(DCL_CHAN_NUM) + + IMPLICIT INTEGER (A-Z) + + INCLUDE '($MSGDEF)' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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*6,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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + EXTERNAL READ_AST + + EXTERNAL IO$_READVBLK + + IER = SYS$QIO(%VAL(READ_EFS(UNIT_INDEX)),%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 = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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*25,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).GT.0) THEN + IER = SYS$QIO(%VAL(WRITE_EFS(UNIT_INDEX)), + & %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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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.15) THEN + CALL NEWS_SET_CHAN(NNTP_CHANS(UNIT_INDEX)) + IER = NEWS_WRITE_PACKET_BULLCP(READ_EFS(UNIT_INDEX), + & 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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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 = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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(WRITE_EFS(UNIT_INDEX)), + & %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 = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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),READ_EFS(MAXLINK),COUNT + INTEGER*2 READ_IOSB + LOGICAL*1 READ_BUF + + COMMON /ANY_ACTIVITY/ CONNECT_COUNT + DATA CONNECT_COUNT /0/ + + COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN,MBX_CHAN1,DCL_CHAN1 + + COMMON /NNTP/ NNTP_CHANS(MAXLINK) + + CHARACTER*(*) USERNAME,FROMNAME + + EXTERNAL IO$_ACCESS,IO$M_ABORT,NEWS_SOCKET_AST + + CONNECT_COUNT = CONNECT_COUNT + 1 + + 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_ASSIGN() + IF (IER) THEN + NNTP_CHANS(UNIT_INDEX) = NEWS_GET_CHAN() + WRITE_IOSB(1,UNIT_INDEX) = 1 + IER = NEWS_SOCKET_BULLCP(WRITE_EFS(UNIT_INDEX), + & 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 = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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(WRITE_EFS(UNIT_INDEX), + & 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 = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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),READ_EFS(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 = 10 + + COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) + COMMON /PROCBUF/ WRITE_EFS(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),READ_EFS(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*25,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).GT.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 = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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))) + + CALL UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + 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 TIMBUF*13,MIN*2 + DATA TIMBUF/'0 00:00:00.00'/ + + EXTERNAL CHECK_CONNECTIONS + + CALL LIB$GET_EF(WAITEFN) + + TIMBUF(6:7) = MIN + + IER=SYS$BINTIM(TIMBUF,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 = 10 + + COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLUSER.INC' + + PARAMETER MAXLINK = 10 + + COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) + COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),READ_EFS(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*25,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 + CHARACTER*(BRDCST_LIMIT) BMESSAGE + + 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*53 + CHARACTER NODENAME*6,BULLCP_USER*12,INQUEUE*128 + + EQUIVALENCE (BUFFER,CMD_TYPE),(BUFFER,INQUEUE) + + INTEGER BULLCP_PRIV(2) + + BULLCP_PRIV(1) = PROCPRIV(1) + BULLCP_PRIV(2) = PROCPRIV(2) + + ILEN = READ_IOSB(2,UNIT_INDEX) + CALL LIB$MOVC3(ILEN,READ_BUF(1,UNIT_INDEX),%REF(BUFFER)) + + REC_SAVE(UNIT_INDEX) = 0 + USERNAME = USER_SAVE(UNIT_INDEX) + FOLDER = FOLDERNAME(UNIT_INDEX) + FOLDER_NUMBER = FOLDER_NUM(UNIT_INDEX) + NODENAME = NODE_SAVE(UNIT_INDEX) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,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) THEN ! Do we need priv info? + IF (PROCPRIV(1).EQ.0.AND.PROCPRIV(2).EQ.0) THEN + CALL GET_USER_PRIV(USERNAME,PRIV_SAVE(1,UNIT_INDEX)) + PROCPRIV(1) = PRIV_SAVE(1,UNIT_INDEX) + PROCPRIV(2) = PRIV_SAVE(2,UNIT_INDEX) + IF ( (PROCPRIV(1).AND.NEEDPRIV(1)).EQ.0.AND. + & (PROCPRIV(2).AND.NEEDPRIV(2)).EQ.0) THEN + CALL CHECK_BULLETIN_PRIV(USERNAME) + PRIV_SAVE(1,UNIT_INDEX) = PROCPRIV(1) + PRIV_SAVE(2,UNIT_INDEX) = PROCPRIV(2) + END IF + END IF + 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:1))) + CALL WRITE_CHAN(4,BUFFER,UNIT_INDEX,IER1) + ELSE + CALL LIB$MOVC3(4,0,%REF(BUFFER(1: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:1))) + CALL LIB$MOVC3(4,READ_ONLY,%REF(BUFFER(5: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13:13))) + ELSE + CALL LIB$MOVC3(8,LAST_READ_BTIM(1,FOLDER_NUMBER+1), + & %REF(BUFFER(9: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:9))) + CALL LIB$MOVC3(4,0,%REF(BUFFER(13: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: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(53,%REF(BUFFER(5:5)),%REF(DESCRIP)) + CALL LIB$MOVC3(11,%REF(BUFFER(58:58)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(69:69)),%REF(EXTIME)) + CALL LIB$MOVC3(4,%REF(BUFFER(80:80)),SYSTEM) + 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(84:84)),BROAD) + IF (BROAD.AND..NOT.SETPRV_PRIV().AND..NOT.OPER_PRIV()) THEN + BROAD = 0 + END IF + CALL LIB$MOVC3(4,%REF(BUFFER(88:88)),BELL) + CALL LIB$MOVC3(4,%REF(BUFFER(92:92)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(97:97)),CLUSTER) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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 + 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 (1) + 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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + IF (ICOUNT.GE.0) THEN + CALL READDIR(ICOUNT,IER) + ELSE + CALL LIB$MOVC3(8,%REF(BUFFER(9:9)),%REF(MSG_KEY(1:1))) + CALL READDIR_KEYGE(IER) + END IF + CALL CLOSE_BULLDIR + CALL LIB$MOVC3(4,IER,%REF(BUFFER(1: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:5)),SBULL) + CALL LIB$MOVC3(4,%REF(BUFFER(9:9)),EBULL) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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:5)),BULL_DELETE) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:5)),ICOUNT) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + 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) + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR + CALL LIB$MOVC3(53,%REF(BUFFER(5:5)),%REF(DESCRIP_TEMP)) + CALL LIB$MOVC3(4,%REF(BUFFER(58:58)),ICOUNT) + 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(53,%REF(BUFFER(62:62)),%REF(DESCRIP)) + CALL LIB$MOVC3(4,%REF(BUFFER(115:115)),%REF(MSGTYPE)) + CALL LIB$MOVC3(11,%REF(BUFFER(119:119)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(130:130)),%REF(EXTIME)) + 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:5)),BULL_DELETE) + DESCRIP_TEMP = BUFFER(9:61) + 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(11,%REF(BUFFER(62:62)),%REF(EXDATE)) + CALL LIB$MOVC3(11,%REF(BUFFER(73:73)),%REF(EXTIME)) + 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 + FOLDER_FILE = + & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER + CALL OPEN_BULLDIR_SHARED + CALL READDIR(0,IER) + CALL GET_NEWEST_MSG(%REF(BUFFER(5: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: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:5)),BLENGTH) + CALL LIB$MOVC3(4,%REF(BUFFER(9: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:13)), + & %VAL(SCRATCH(UNIT_INDEX)+START-1)) + ELSE + CALL LIB$MOVC3(BLENGTH,%VAL(SCRATCH(UNIT_INDEX)), + & %REF(BMESSAGE(1:1))) + CALL LIB$MOVC3(4,%REF(BUFFER(13:13)),ALL) + CALL LIB$MOVC3(4,%REF(BUFFER(17:17)),CLUSTER) + CALL LIB$FREE_VM(BRDCST_LIMIT,SCRATCH(UNIT_INDEX)) + IF (ILEN.GT.20) THEN + CALL LIB$MOVC3(4,%REF(BUFFER(21:21)),FOLDER_NUMBER) + FOLDER = BUFFER(25:) + GO TO 100 + ELSE IF (SETPRV_PRIV().OR.OPER_PRIV()) THEN + CALL BROADCAST(ALL,CLUSTER) + END IF + END IF + END IF + +1000 PROCPRIV(1) = BULLCP_PRIV(1) + PROCPRIV(2) = BULLCP_PRIV(2) + + RETURN + END + + + + SUBROUTINE UPDATE_REMOTE_USERINFO(UNIT_INDEX) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + PARAMETER MAXLINK = 10 + + 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*25,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) THEN + PROCPRIV(1) = NEEDPRIV(1) + PROCPRIV(2) = NEEDPRIV(2) + END IF + 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') + REC_LOCK = 1 + 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) + + CHARACTER*80 MESSAGE + + 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 + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER LOCAL_NODE*32,NODE_TEMP*256,PASSWORD*31,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 diff --git a/decus/vax91b/gce91b/net91b/bulletin9.for b/decus/vax91b/gce91b/net91b/bulletin9.for new file mode 100644 index 0000000..072dfb8 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/bulletin9.for @@ -0,0 +1,1802 @@ +C +C BULLETIN9.FOR, Version 6/18/91 +C Purpose: Contains subroutines for the bulletin board utility program. +C Environment: VAX/VMS +C Usage: Invoked by the BULLETIN command. +C Programmer: Mark R. London +C +C Copyright (c) 1990 +C Property of Massachusetts Institute of Technology, Cambridge MA 02139. +C This program cannot be copied or distributed in any form for non-MIT +C use without specific written approval of MIT Plasma Fusion Center +C Management. +C + SUBROUTINE DELETE_NODE +C +C SUBROUTINE DELETE_NODE +C +C FUNCTION: Deletes files sent via ADD/NODES at remote hosts. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, + & NODE_ERROR,POINT_NODE + CHARACTER*32 NODES(10) + LOGICAL LOCAL_NODE_FOUND,NODE_ERROR + + CHARACTER INLINE*80 + + CALL GET_NODE_INFO + + IF (NODE_ERROR) GO TO 940 + + IF (NODE_NUM.EQ.0.OR.LOCAL_NODE_FOUND) THEN + WRITE (6,'('' ERROR: Cannot specify local node.'')') + GO TO 999 + END IF + + IER = CLI$GET_VALUE('SUBJECT',DESCRIP) + + DO POINT_NODE=1,NODE_NUM ! Write out command to nodes + NLEN = TRIM(NODES(POINT_NODE)) ! Length of node name + INLINE = 'DELETE/SUBJECT="'//DESCRIP(:TRIM(DESCRIP)) + WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE + READ (POINT_NODE+9,'(A)',ERR=940,END=940) INLINE + IF (INLINE.EQ.'END') THEN + WRITE (6,'('' Message successfully deleted from node '',A)') + & NODES(POINT_NODE) + ELSE + WRITE (6,'('' Error while deleting message to node '',A)') + & NODES(POINT_NODE) + WRITE (6,'(A)') INLINE + END IF + END DO + + GO TO 999 + +910 WRITE (6,1010) + GO TO 999 + +940 WRITE (6,1015) NODES(POINT_NODE) + +999 DO WHILE (NODE_NUM.GT.0) + CLOSE(UNIT=9+NODE_NUM) + NODE_NUM = NODE_NUM - 1 + END DO + + RETURN + +1010 FORMAT (' ERROR: Deletion aborted.') +1015 FORMAT (' ERROR: Unable to reach node ',A) + + END + + + + + SUBROUTINE SET_FOLDER_FLAG(SETTING,FLAG,FLAGNAME) +C +C SUBROUTINE SET_FOLDER_FLAG +C +C FUNCTION: Sets or clears specified flag for folder +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*(*) FLAGNAME + + IF (REMOTE_SET.EQ.3) THEN + WRITE (6,'('' ERROR: Command invalid for folder.'')') + ELSE IF (FLAG.EQ.7.AND..NOT.SETPRV_PRIV()) THEN + WRITE (6,'('' ERROR: Privileges required for this command.'')') + ELSE IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + IF (SETTING) THEN + FOLDER_FLAG = IBSET(FOLDER_FLAG,FLAG) + ELSE + FOLDER_FLAG = IBCLR(FOLDER_FLAG,FLAG) + END IF + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + + WRITE (6,'(1X,A,'' has been modified for folder.'')') + & FLAGNAME + ELSE + WRITE (6,'(1X,'' You are not authorized to modify '',A)') + & FLAGNAME//'.' + END IF + + RETURN + END + + + + + SUBROUTINE SET_FOLDER_EXPIRE_LIMIT(LIMIT) +C +C SUBROUTINE SET_FOLDER_EXPIRE_LIMIT +C +C FUNCTION: Sets folder expiration limit. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLFILES.INC' + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + IF (REMOTE_SET.EQ.3) THEN + WRITE (6,'('' ERROR: Command invalid for folder. '')') + ELSE IF (LIMIT.LT.0) THEN + WRITE (6,'('' ERROR: Invalid expiration length specified.'')') + ELSE IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN + CALL OPEN_BULLFOLDER ! Open folder file + + CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) + + F_EXPIRE_LIMIT = LIMIT + + CALL REWRITE_FOLDER_FILE + + CALL CLOSE_BULLFOLDER + WRITE (6,'('' Folder expiration date modified.'')') + ELSE + WRITE (6,'('' You are not allowed to modify folder.'')') + END IF + + RETURN + END + + + + + + SUBROUTINE MERGE + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE + + ENTRY INITIALIZE_MERGE(IER1) + + DO WHILE (FILE_LOCK(IER1,IER2)) + OPEN (UNIT=24,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) + & //'.TMPDIR',STATUS='NEW',FORM='UNFORMATTED', + & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, + & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', + & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') + END DO + + IF (IER1.NE.0) RETURN + + NBULL = 0 + + WRITE(24,IOSTAT=IER1) BULLDIR_HEADER + CALL CONVERT_HEADER_FROMBIN + + TO_POINTER = 1 + + RETURN + + ENTRY ADD_MERGE_TO(IER1) + + IER1 = 0 + + DO WHILE (IER1.EQ.0) + + BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY + + CALL READDIR(TO_POINTER,IER) + + DIFF = COMPARE_BTIM(%REF(BULLDIR_ENTRY_SAVE),MSG_BTIM) + IF (DIFF.LT.0.OR.TO_POINTER+1.NE.IER) THEN + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + CALL CONVERT_ENTRY_FROMBIN + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(24,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + + BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE + END DO + + CLOSE (UNIT=24) + + RETURN + + ENTRY ADD_MERGE_FROM(IER1) + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) + IF (DIFF.GT.0) THEN + NEWEST_EXDATE = EXDATE + NEWEST_EXTIME = EXTIME + ELSE IF (DIFF.EQ.0) THEN + DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) + IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME + END IF + + IF ((SYSTEM.AND.4).EQ.4) THEN + SHUTDOWN = SHUTDOWN + 1 + SHUTDOWN_DATE = DATE + SHUTDOWN_TIME = TIME + END IF + + BLOCK = NBLOCK - LENGTH + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(24,IOSTAT=IER1) BULLDIR_ENTRY + + RETURN + + ENTRY ADD_MERGE_REST(IER1) + + CALL UPDATE_LOGIN(.TRUE.) + + DO WHILE (IER1.EQ.0) + + CALL READDIR(TO_POINTER,IER) + IF (TO_POINTER+1.NE.IER) THEN + READ (24,KEYID=0,KEY=0,IOSTAT=IER1) + CALL CONVERT_HEADER_TOBIN + REWRITE(24,IOSTAT=IER1) BULLDIR_HEADER + IF (IER1.EQ.0) THEN + CLOSE (UNIT=24,DISPOSE='KEEP') + CALL LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// + & '.TMPDIR',FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR') + ELSE + CLOSE (UNIT=24) + END IF + RETURN + END IF + + NBULL = NBULL + 1 + MSG_NUM = NBULL + + CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) + WRITE(24,IOSTAT=IER1) BULLDIR_ENTRY + + NEWEST_DATE = DATE + NEWEST_TIME = TIME + + TO_POINTER = TO_POINTER + 1 + END DO + + CLOSE (UNIT=24) + + RETURN + END + + + + + SUBROUTINE SET_NOKEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /KEYPAD/ KEYPAD_MODE + + INCLUDE '($SMGDEF)' + + KEYPAD_MODE = 0 + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'SET KEYPAD',) + + RETURN + END + + + + + + SUBROUTINE SET_KEYPAD + + IMPLICIT INTEGER (A-Z) + + COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID + + COMMON /KEYPAD/ KEYPAD_MODE + + INCLUDE '($SMGDEF)' + + KEYPAD_MODE = 1 + + TERM = SMG$M_KEY_TERMINATE + + IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1) + + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF1',,,,'GOLD') + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'HELP',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2','GOLD',TERM,'SET NOKEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3',,,'EXTRACT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3','GOLD',,'FILE ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4',,TERM,'SHOW KEYPAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4','GOLD',TERM, + & 'SHOW KEYPAD/PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0',,TERM, + & 'SHOW FOLDER/FULL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0','GOLD',TERM,'SHOW FLAGS',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1',,TERM,'BACK',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1','GOLD',TERM,'NEXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2',,TERM,'PRINT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2','GOLD',TERM,'PRINT/NONOTIFY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3',,TERM,'DIR',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3','GOLD',TERM,'DIR/FOLDER',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4',,TERM,'CURRENT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4','GOLD',TERM,'CURRENT/EDIT ',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5',,TERM,'RESPOND',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5','GOLD',TERM,'RESP/EDIT/EXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP6',,TERM,'LAST',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7',,TERM,'ADD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7','GOLD',TERM,'ADD/EDIT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8',,TERM,'REPLY',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8','GOLD',TERM,'REPL/EDIT/EXT',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9',,TERM,'MAIL',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9','GOLD',TERM,'MAIL/NOHEAD',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS',,TERM,'READ/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS','GOLD',TERM,'SHOW NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA',,TERM,'DIR/NEW',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA','GOLD',TERM,'INDEX',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD',,TERM,'DELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD','GOLD',TERM,'UNDELETE',) + IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'ENTER','GOLD',,'SELECT ',) + + RETURN + END + + + + SUBROUTINE SHOW_KEYPAD(LIBRARY) + + IMPLICIT INTEGER (A-Z) + EXTERNAL LIB$PUT_OUTPUT,PRINT_OUTPUT + CHARACTER*(*) LIBRARY + + INCLUDE '($HLPDEF)' + + IF (CLI$PRESENT('PRINT')) THEN + OPEN (UNIT=8,STATUS='NEW',FILE='SYS$LOGIN:KEYPAD.DAT', + & IOSTAT=IER) + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR WHILE OPENING FILE TO PRINTER.'')') + ELSE + CALL LBR$OUTPUT_HELP(PRINT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + CLOSE (UNIT=8,DISP='PRINT/DELETE') + END IF + ELSE + CALL LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,'KEYPAD' + & ,LIBRARY,HLP$M_HELP) + END IF + + RETURN + END + + INTEGER FUNCTION PRINT_OUTPUT(INPUT) + IMPLICIT INTEGER (A-Z) + CHARACTER*(*) INPUT + WRITE (8,'(1X,A)',IOSTAT=IER) INPUT(:TRIM(INPUT)) + IF (IER.EQ.0) PRINT_OUTPUT = 1 + RETURN + END + + + + SUBROUTINE OUTPUT_HELP(PARAMETER,LIBRARY) +C +C SUBROUTINE OUTPUT_HELP +C +C FUNCTION: +C To create interactive help session. Prompting is enabled. +C INPUTS: +C PARAMETER - Character string. Optional input parameter +C containing a list of help keys. +C LIBRARY - Character string. Name of help library. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($LBRDEF)' + + COMMON /HELP/ HELP_PAGE,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID,OTHERINFO + CHARACTER*80 HELP_INPUT + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + EXTERNAL PUT_OUTPUT + + CHARACTER*(*) LIBRARY,PARAMETER + + CHARACTER*80 PROMPT + + DATA DISPLAY_ID/0/,KEYBOARD_ID/0/ + + IF (KEYBOARD_ID.EQ.0) THEN + IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) + IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) + END IF + + CALL STR$TRIM(HELP_INPUT,PARAMETER,HELP_INPUT_LEN) ! Trim input + + CALL LBR$INI_CONTROL(LINDEX,LBR$C_READ) ! Init library read + CALL LBR$OPEN(LINDEX,LIBRARY) ! Specify library name + + DO I=1,10 ! Initialize key lengths + KEYL(I) = 0 + END DO + + NKEY = 0 ! Number of help keys + + DO WHILE (1) ! Do until CTRL-Z entered or no more keys + + HELP_PAGE = 0 ! Init line counter + NEED_ERASE = .TRUE. ! Need to erase screen + + OLD_NKEY = NKEY ! Save old key count + EXACT = .TRUE. ! Exact key match + + DO WHILE (NKEY.LT.10.AND.HELP_INPUT_LEN.GT.0.AND. + & HELP_INPUT(:1).NE.'?') + ! Break input into keys + NKEY = NKEY + 1 ! Increment key counter + + DO WHILE (HELP_INPUT(1:1).EQ.' '.AND.HELP_INPUT_LEN.GT.0) + HELP_INPUT = HELP_INPUT(2:HELP_INPUT_LEN) ! Strip spaces + HELP_INPUT_LEN = HELP_INPUT_LEN - 1 ! at start of input + END DO + + NEXT_KEY = 2 + + DO WHILE (NEXT_KEY.LE.HELP_INPUT_LEN ! Search for + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.' ' ! space or + & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.'/') ! backslash + NEXT_KEY = NEXT_KEY + 1 ! indicating start of next key + END DO + + IF (NEXT_KEY.GT.HELP_INPUT_LEN) THEN ! Found the last key + KEY(NKEY) = HELP_INPUT(:HELP_INPUT_LEN) ! Key string + KEYL(NKEY) = HELP_INPUT_LEN ! Key length + HELP_INPUT_LEN = 0 + ELSE ! Found the next key + KEY(NKEY) = HELP_INPUT(:NEXT_KEY-1) + HELP_INPUT = HELP_INPUT(NEXT_KEY:HELP_INPUT_LEN) + KEYL(NKEY) = NEXT_KEY - 1 + HELP_INPUT_LEN = HELP_INPUT_LEN - NEXT_KEY + 1 + END IF + END DO + HELP_INPUT_LEN = 0 + IER = LBR$GET_HELP(LINDEX,,PUT_OUTPUT,, ! Display help + & KEY(1)(:KEYL(1)),KEY(2)(:KEYL(2)), + & KEY(3)(:KEYL(3)),KEY(4)(:KEYL(4)),KEY(5)(:KEYL(5)), + & KEY(6)(:KEYL(6)),KEY(7)(:KEYL(7)),KEY(8)(:KEYL(8)), + & KEY(9)(:KEYL(9)),KEY(10)(:KEYL(10))) + + IF (IER.EQ.0.AND.HELP_INPUT_LEN.GT.0) IER = 1 + ! IER = 0 special case means input given to full screen prompt + + IF (KEY(NKEY).EQ.'*'.OR..NOT.EXACT) THEN ! If not exact match + DO I=OLD_NKEY+1,NKEY ! then don't update + KEYL(I) = 0 ! new keys + END DO + NKEY = OLD_NKEY + END IF + + IF (IER.AND.NKEY.GT.0.AND.OTHERINFO.EQ.0) THEN ! No subtopics? + KEYL(NKEY) = 0 ! Back up one key level + NKEY = NKEY - 1 + END IF + + DO WHILE (HELP_INPUT_LEN.EQ.0.AND.IER.AND.NKEY.GE.0) + IF (NKEY.EQ.0) THEN ! If top level, prompt for topic + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Topic? ',HELP_INPUT_LEN) + ELSE ! If not top level, prompt for subtopic + LPROMPT = 0 ! Create subtopic prompt line + DO I=1,NKEY ! Put spaces in between keys + PROMPT = PROMPT(:LPROMPT)//KEY(I)(:KEYL(I))//' ' + LPROMPT = LPROMPT + KEYL(I) + 1 + END DO + PROMPT = PROMPT(:LPROMPT)//'Subtopic? ' + LPROMPT = LPROMPT + 10 + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,PROMPT(:LPROMPT),HELP_INPUT_LEN) + END IF + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) + IF (IER.AND.HELP_INPUT_LEN.EQ.0) THEN ! If RETURN entered + KEYL(NKEY) = 0 ! Back up one key level + NKEY = NKEY - 1 + END IF + END DO + + IF (.NOT.IER.OR.NKEY.LT.0) THEN ! If CTRL-Z above top level, + CALL LIB$PUT_OUTPUT(' ') ! Skip line + CALL LBR$CLOSE(LINDEX) ! then close library, + RETURN ! and end help session. + END IF + + END DO + + END + + + + INTEGER FUNCTION PUT_OUTPUT(INPUT,INFO,DATA,LEVEL) +C +C FUNCTION PUT_OUTPUT +C +C FUNCTION: +C Output routine for input from LBR$GET_HELP. Displays +C help text on terminal with full screen prompting. +C INPUTS: +C INPUT - Character string. Line of input text. +C INFO - Longword. Contains help flag bits. +C DATA - Longword. Not presently used. +C LEVEL - Longword. Contains current key level. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE '($HLPDEF)' + + COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT + CHARACTER*20 KEY(10) + DIMENSION KEYL(10) + + COMMON /HELP/ HELP_PAGE,HELP_INPUT,HELP_INPUT_LEN + COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID,OTHERINFO + CHARACTER*80 HELP_INPUT + + COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING + + CHARACTER INPUT*(*) + + CHARACTER SPACES*20 + DATA SPACES /' '/ + + OTHERINFO = INFO.AND.HLP$M_OTHERINFO + + IF ((INFO.AND.HLP$M_NOHLPTXT).NE.0) THEN ! Key cannot be found + NEED_ERASE = .FALSE. ! Don't erase screen + IF (HELP_PAGE.EQ.0) THEN ! If first line of help text + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were inputted, as they are + END DO ! not valid, as no match + NKEY = OLD_NKEY ! could be found. + END IF + ELSE IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0.AND.NKEY.GT.0.AND. + & LEVEL.GT.OLD_NKEY.AND.KEY(NKEY)(:KEYL(NKEY)).NE.'*'.AND. + & %LOC(INPUT).NE.0) THEN ! If text contains key names + ! Update if not wildcard search and they are new keys + IF (KEYL(LEVEL).GT.0) THEN ! If key already updated + EXACT = .FALSE. ! Must be more than one match possible + END IF ! so indicate not exact match. + START_KEY = 1 ! String preceeding spaces. + DO WHILE (INPUT(START_KEY:START_KEY).EQ.' ') + START_KEY = START_KEY + 1 + END DO + KEY(LEVEL) = INPUT(START_KEY:) ! Store new key + CALL STR$TRIM(KEY(LEVEL),KEY(LEVEL),KEYL(LEVEL)) ! & key length + ELSE IF (HELP_PAGE.EQ.0) THEN ! If first line of text, + DO I=OLD_NKEY+1,NKEY ! remove any new keys that + KEYL(I) = 0 ! were just inputted, allowing + END DO ! this routine to fill them. + END IF + + IF (NEED_ERASE) THEN ! Need to erase screen? + IER = LIB$ERASE_PAGE(1,1) ! i.e. start of new topic. + NEED_ERASE = .FALSE. + END IF + + HELP_PAGE = HELP_PAGE + 1 ! Increment screen counter + IF (PAGING.AND.HELP_PAGE.GT.PAGE_LENGTH-2) THEN ! End of page? + HELP_PAGE = 0 ! Reinitialize screen counter + CALL LIB$PUT_OUTPUT(' ') ! Skip line and prompt for next screen + IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, + & HELP_INPUT,'Press RETURN to continue ... ',HELP_INPUT_LEN) + CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) ! Trim input + IF (.NOT.IER.OR.HELP_INPUT_LEN.GT.0) THEN ! CTRL-Z or Text input? + EXACT = .TRUE. ! If more than one match was found and being + ! displayed, text input specifies that the + ! current displayed match is desired. + PUT_OUTPUT = 0 ! Stop any more of current help display. + ELSE ! Else if RETURN entered + IER = LIB$ERASE_PAGE(1,1) ! Erase display + NSPACES = LEVEL*2 ! Number of spaces to indent output + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + ! Key name lines are indented 2 less than help description. + IF (NSPACES.GT.0) THEN ! Add spaces if present to output + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE ! Else just output text. + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + HELP_PAGE = 1 ! Increment page counter. + END IF + ELSE ! Else if not end of page + NSPACES = LEVEL*2 ! Just output text line + IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 + IF (NSPACES.GT.0) THEN + PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) + ELSE + PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) + END IF + END IF + + RETURN + END + + + + + SUBROUTINE SHOW_VERSION + + IMPLICIT INTEGER (A-Z) + + CHARACTER VERSION*10,DATE*23 + + CALL READ_HEADER(VERSION,DATE) + + WRITE (6,'(A)') ' BULLETIN Version '//VERSION(:TRIM(VERSION)) + + WRITE (6,'(A)') ' Linked on '//DATE(:TRIM(DATE)) + + RETURN + END + + + + + SUBROUTINE FULL_DIR(INDEX_COUNT) +C +C Add INDEX command to BULLETIN, display directories of ALL +C folders. Added per request of a faculty member for his private +C board. Changes to BULLETIN.FOR should be fairly obvious. +C +C Brian Nelson, Brian@uoft02.bitnet (or .ccnet, node 8.2) +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + INCLUDE 'BULLFILES.INC' + INCLUDE 'BULLFOLDER.INC' + INCLUDE 'BULLUSER.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /TAGS/ BULL_TAG,READ_TAG + + DATA FOLDER_Q1/0/ + + BULL_POINT = 0 + + IF (NUM_FOLDERS.GT.0.AND..NOT.CLI$PRESENT('RESTART') + & .AND.INDEX_COUNT.EQ.1) THEN + INDEX_COUNT = 2 + DIR_COUNT = 0 + END IF + + IF (INDEX_COUNT.EQ.1) THEN + CALL INIT_QUEUE(FOLDER_Q1,FOLDER1_COM) + + FOLDER_Q = FOLDER_Q1 + + SUBSCRIBE = CLI$PRESENT('SUBSCRIBE') + IF (SUBSCRIBE) THEN + CALL NEWS_GET_SUBSCRIBE(0,F1_END) + SUBNUM = 1 + CALL OPEN_BULLNEWS_SHARED + ELSE + CALL OPEN_BULLFOLDER_SHARED + END IF + + NUM_FOLDERS = 0 + IER = 0 + DO WHILE (IER.EQ.0) ! Copy all bulletins from file + IF (SUBSCRIBE) THEN + IER = 1 + DO WHILE (SUBNUM.NE.0.AND.IER.NE.0) + CALL NEWS_GET_SUBSCRIBE(SUBNUM,F1_END) + IF (SUBNUM.NE.0) THEN + CALL READ_FOLDER_FILE_KEYNUM_TEMP(SUBNUM,IER) + IF (IER.NE.0) SUBNUM = -1 + END IF + END DO + IF (SUBNUM.EQ.0) IER = 1 + ELSE + CALL READ_FOLDER_FILE_TEMP(IER) + END IF + IF (IER.EQ.0) THEN + IF (BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN + FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) + & //FOLDER1 + CALL CHECK_ACCESS + & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', + & USERNAME,READ_ACCESS,-1) + ELSE + READ_ACCESS = 1 + END IF + IF (READ_ACCESS) THEN + NUM_FOLDERS = NUM_FOLDERS + 1 + CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + END IF + END IF + END DO + + CALL CLOSE_BULLFOLDER ! We don't need file anymore + + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + WRITE (6,1000) + IF (SUBSCRIBE) THEN + WRITE (6,1025) + ELSE + WRITE (6,1020) + END IF + DO J = 1,NUM_FOLDERS + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + IF (SUBSCRIBE) THEN + WRITE (6,1035) FOLDER1_DESCRIP(:72),F1_NBULL + ELSE + WRITE (6,1030) FOLDER1,F1_NBULL, + & FOLDER1_DESCRIP(:MIN(TRIM(FOLDER1_DESCRIP),46)) + END IF + END DO + WRITE (6,1060) + FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header + INDEX_COUNT = 2 + DIR_COUNT = 0 + READ_TAG = .FALSE. + IF (CLI$PRESENT('MARKED')) THEN + READ_TAG = 1 + IBSET(0,1) + ELSE IF (CLI$PRESENT('SEEN')) THEN + READ_TAG = 1 + IBSET(0,2) + ELSE IF (CLI$PRESENT('UNMARKED').OR.CLI$PRESENT + & ('MARKED').EQ.%LOC(CLI$_NEGATED)) THEN + READ_TAG = 1 + IBSET(0,1) + IBSET(0,3) + ELSE IF (CLI$PRESENT('UNSEEN').OR.CLI$PRESENT + & ('SEEN').EQ.%LOC(CLI$_NEGATED)) THEN + READ_TAG = 1 + IBSET(0,2) + IBSET(0,3) + END IF + RETURN + ELSE IF (INDEX_COUNT.EQ.2) THEN + IF (DIR_COUNT.LE.0) THEN + F1_NBULL = 0 + DIR_COUNT = 0 + DO WHILE (NUM_FOLDERS.GT.0.AND.F1_NBULL.EQ.0) + NUM_FOLDERS = NUM_FOLDERS - 1 + CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) + IF (F1_NBULL.GT.0) THEN + FOLDER_NUMBER = -1 + CALL SELECT_FOLDER(.FALSE.,IER) + IF (.NOT.IER) F1_NBULL = 0 + END IF + END DO + + IF (F1_NBULL.EQ.0) THEN + WRITE (6,1050) + INDEX_COUNT = 0 + RETURN + END IF + END IF + + IF (READ_TAG) THEN + CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) + END IF + + CALL DIRECTORY(DIR_COUNT) + IF (DIR_COUNT.GT.0) RETURN + + IF (NUM_FOLDERS.GT.0) THEN + WRITE (6,1040) + ELSE + INDEX_COUNT = 0 + END IF + END IF + + RETURN + +1000 FORMAT (' The following folders are present'/) +1020 FORMAT (' Name Count Description'/) +1025 FORMAT (' Name',70X,'Count'/) +1030 FORMAT (1X,A,1X,I6,1X,A) +1035 FORMAT (1X,A,1X,I6) +1040 FORMAT (' Type Return to continue to the next folder...') +1050 FORMAT (' End of folder search.') +1060 FORMAT (' Type Return to continue...') + + END + + + + + + SUBROUTINE SHOW_USER +C +C SUBROUTINE SHOW_USER +C +C FUNCTION: Shows information for specified users. +C + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLUSER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /POINT/ BULL_POINT + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + COMMON /BULLPAR/ BULL_PARAMETER,LEN_P + CHARACTER*64 BULL_PARAMETER + + COMMON /CTRLC_FLAG/ FLAG + + DIMENSION NOLOGIN_BTIM(2),START_BTIM(2) + + CHARACTER DATETIME*17 + + DIMENSION LAST(2,FOLDER_MAX) + INTEGER*2 LAST2(4,FOLDER_MAX) + EQUIVALENCE (LAST,LAST2) + + ALL = CLI$PRESENT('NOLOGIN').OR.CLI$PRESENT('ALL') + & .OR.CLI$PRESENT('LOGIN') + + SETPRV = SETPRV_PRIV() ! SETPRV_PRIV rewrites TEMP_USER + + IF (.NOT.ALL) THEN + IER = CLI$GET_VALUE('USERNAME',TEMP_USER) + IF (.NOT.IER) TEMP_USER = USERNAME + END IF + + IF (.NOT.SETPRV.AND.(ALL.OR.USERNAME.NE.TEMP_USER)) THEN + WRITE (6,'('' ERROR: No privs to use command.'')') + RETURN + END IF + + CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) + + FOLDER_PRESENT = CLI$PRESENT('FOLDER') + + IF (FOLDER_PRESENT) THEN + IER = CLI$GET_VALUE('FOLDER',FOLDER1_NAME) + IF (.NOT.IER) FOLDER1_NAME = FOLDER_NAME + NEWS = INDEX(FOLDER1_NAME,'.').GT.0.OR.(FOLDER1_NAME(:1) + & .GE.'a'.AND.FOLDER1_NAME(:1).LE.'z') + IF (.NOT.NEWS) THEN + CALL OPEN_BULLFOLDER_SHARED + ELSE + CALL OPEN_BULLNEWS_SHARED + CALL LOWERCASE(FOLDER1_NAME) + END IF + CALL READ_FOLDER_FILE_KEYNAME_TEMP + & (FOLDER1_NAME(:TRIM(FOLDER1_NAME)),IER) + CALL CLOSE_BULLFOLDER + IF (IER.NE.0) THEN + WRITE (6,'('' ERROR: Folder not found.'')') + RETURN + END IF + END IF + + SINCE = CLI$PRESENT('SINCE').OR.CLI$PRESENT('START') + IF (CLI$GET_VALUE('SINCE',BULL_PARAMETER,LEN_P)) THEN + IF (.NOT.NEWS) THEN + IER = SYS_BINTIM(BULL_PARAMETER,START_BTIM) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Invalid date specified.'')') + RETURN + END IF + ELSE + WRITE (6,'('' ERROR: /SINCE not valid with NEWS group.'')') + RETURN + END IF + ELSE IF (CLI$GET_VALUE('START',BULL_PARAMETER,LEN_P)) THEN + IF (NEWS) THEN + IER = OTS$CVT_TI_L(BULL_PARAMETER(:LEN_P), + & STARTMSG,,%VAL(1)) + IF (.NOT.IER) THEN + WRITE (6,'('' ERROR: Invalid number specified.'')') + RETURN + END IF + ELSE + WRITE (6,'('' ERROR: /START not valid with folder.'')') + RETURN + END IF + ELSE IF (SINCE) THEN + IF (BULL_POINT.EQ.0) THEN + WRITE (6,'('' ERROR: No current message.'')') + RETURN + ELSE IF (NEWS) THEN + STARTMSG = BULL_POINT + ELSE + START_BTIM(1) = MSG_BTIM(1) + START_BTIM(2) = MSG_BTIM(2) + END IF + ELSE IF (.NOT.NEWS) THEN + CALL SYS_BINTIM('6-NOV-1956 00:00:00.00',START_BTIM) + ELSE + STARTMSG = 1 + END IF + + CALL DISABLE_CTRL + CALL DECLARE_CTRLC_AST + IF (FOLDER_PRESENT) THEN + CALL OPEN_BULLINF_SHARED + IER = 0 + DO WHILE (IER.EQ.0.AND.FLAG.NE.1) + IF (ALL) THEN + DO WHILE (REC_LOCK(IER)) + READ (9,IOSTAT=IER) TEMP_USER,LAST + END DO + ELSE + IF (NEWS) THEN + LU = TRIM(TEMP_USER) + TEMP_USER(LU:LU) = CHAR(128.OR.ICHAR(TEMP_USER(LU:LU))) + IF (LU.GT.1) THEN + TEMP_USER(LU-1:LU-1) = + & CHAR(128.OR.ICHAR(TEMP_USER(LU-1:LU-1))) + ELSE + TEMP_USER(2:2) = CHAR(128.OR.ICHAR(TEMP_USER(2:2))) + END IF + END IF + DO WHILE (REC_LOCK(IER)) + READ (9,KEY=TEMP_USER,IOSTAT=IER) TEMP_USER,LAST + END DO + END IF + UNLOCK 9 + IF (IER.EQ.0) THEN + LU = TRIM(TEMP_USER) + I = MAX(LU,2) + DO WHILE (I.GT.0.AND..NOT.BTEST(ICHAR(TEMP_USER(I:I)),7)) + I = I - 1 + END DO + IF (NEWS.AND.I.GE.LU.AND.I.NE.1.AND. + & BTEST(ICHAR(TEMP_USER(I-1:I-1)),7)) THEN + TEMP_USER(I:I) = CHAR(ICHAR(TEMP_USER(I:I)).AND.127) + TEMP_USER(I-1:I-1) = + & CHAR(ICHAR(TEMP_USER(I-1:I-1)).AND.127) + I = 0 + NEWSMSG = 1 + DO WHILE (LAST2(1,NEWSMSG).NE.NEWS_FOLDER1_NUMBER + & .AND.NEWSMSG.LE.FOLDER_MAX) + NEWSMSG = NEWSMSG + 1 + END DO + IF (NEWSMSG.LE.FOLDER_MAX) THEN + FOUND = LAST(2,NEWSMSG).GE.STARTMSG + ELSE + FOUND = .FALSE. + END IF + ELSE IF (.NOT.NEWS.AND.I.EQ.0) THEN + FOUND = COMPARE_BTIM + & (START_BTIM,LAST(1,FOLDER1_NUMBER+1)).LE.0 + ELSE + FOUND = .FALSE. + END IF + IF (FOUND.AND.NEWS) THEN + WRITE (6,'(1X,A,'' latest message read '', + & I,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)),LAST(2,NEWSMSG) + ELSE IF (FOUND) THEN + CALL SYS$ASCTIM(,DATETIME,LAST(1,FOLDER1_NUMBER+1),) + WRITE (6,'(1X,A,'' latest message read '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)),DATETIME + ELSE IF (.NOT.ALL) THEN + WRITE (6,'('' User has never read or not subscribed'', + & '' to specified folder.'')') + END IF + END IF + IF (.NOT.ALL) THEN + IF (IER.NE.0) THEN + WRITE (6,'('' User info does not exist.'')') + END IF + IER = 2 + END IF + END DO + CALL CLOSE_BULLINF + ELSE IF (.NOT.ALL) THEN + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) + IF (IER.EQ.0) THEN + IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN + WRITE (6,'('' NOLOGIN set for specified user.'')') + ELSE + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'('' User last logged in at '',A,''.'')') + & DATETIME + END IF + ELSE + WRITE (6,'('' Entry for specified user not found.'')') + END IF + CALL CLOSE_BULLUSER + ELSE + CALL OPEN_BULLUSER_SHARED + CALL READ_USER_FILE(IER) + DO WHILE (IER.EQ.0.AND.FLAG.NE.1) + CALL READ_USER_FILE(IER) + IF (IER.EQ.0.AND.TEMP_USER(:1).NE.':'.AND. + & TEMP_USER(:1).NE.'*') THEN + IER1 = COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM) + IF (.NOT.CLI$PRESENT('LOGIN').AND.IER1.GE.0) THEN + WRITE (6,'('' NOLOGIN set for '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)) + ELSE IF (.NOT.CLI$PRESENT('NOLOGIN').AND.IER1.LT.0.AND. + & COMPARE_BTIM(START_BTIM,LOGIN_BTIM).LE.0) THEN + CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) + WRITE (6,'(1X,A,'' last logged in at '',A,''.'')') + & TEMP_USER(:TRIM(TEMP_USER)),DATETIME + END IF + END IF + END DO + CALL CLOSE_BULLUSER + END IF + CALL CANCEL_CTRLC_AST + CALL ENABLE_CTRL + + RETURN + END + + + + + SUBROUTINE INIT_MESSAGE_ADD(IN_FOLDER,IN_FROM,IN_DESCRIP,IER) +C +C SUBROUTINE INIT_MESSAGE_ADD +C +C FUNCTION: Opens specified folder in order to add message. +C +C INPUTS: +C IN_FOLDER - Character string containing folder name +C IN_FROM - Character string containing name of owner of message. +C If empty, the message is searched for either a +C Reply-to: field or a From: field. If none, then +C the owner of the process is used. If IN_FROM +C ends with a %, it is assumed that it is simply +C the prefix that should be when responding to the +C address via MAIL. I.e. the PMDF interface sends +C IN%, so when the From: field is found, the message +C owner becomes IN%"from-address". +C IN_DESCRIP - Character string containing subject of message. +C If empty, the message is searched for a line +C which starts with "Subj:" or "Subject:". +C OUTPUTS: +C IER - Error status. True if properly connected to folder. +C False if folder not found. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLFILES.INC' + + INCLUDE 'BULLFOLDER.INC' + + INCLUDE 'BULLDIR.INC' + + COMMON /BCP/ BULLCP + LOGICAL BULLCP + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + DATA LPRO/0/ + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + CHARACTER*(*) IN_FOLDER,IN_FROM,IN_DESCRIP + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + COMMON /MAIN_HEADER_INFO/ INEXDATE + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + COMMON /LAST_BUFFER/ OLD_BUFFER + CHARACTER*(LINE_LENGTH) OLD_BUFFER + + COMMON /OLD_BUFFER/ OLD_BUFFER_FROM,OLD_BUFFER_SUBJ + DATA OLD_BUFFER_FROM /.FALSE./, OLD_BUFFER_SUBJ /.FALSE./ + + BULLCP = 1 ! Inhibit folder cleanup subprocess + + CALL OPEN_BULLFOLDER ! Get folder file + + CALL READ_FOLDER_FILE_KEYNAME(IN_FOLDER(:TRIM(IN_FOLDER)),IER) + + CALL CLOSE_BULLFOLDER + + IF (IER.NE.0) THEN + CALL ERRSNS(IDUMMY,IER) + RETURN + ELSE + IER = 1 + END IF + + ENTRY INIT_MESSAGE_ADD_BBOARD(IN_FROM,IN_DESCRIP,IER) + + TEXT = .FALSE. ! No text written, as of yet + + FIRST_BREAK = .TRUE. + + IF (FOLDER_NUMBER.EQ.0) THEN ! If GENERAL folder + FOLDER_SET = .FALSE. ! indicate it + ELSE ! Else it's another folder + FOLDER_SET = .TRUE. ! indicate it + END IF + + FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// + & FOLDER ! set folder file names + + ENTRY INIT_MESSAGE_ADD_DIGEST(IN_FROM,IN_DESCRIP,IER) + + CALL OPEN_BULLDIR ! Open directory file + + CALL OPEN_BULLFIL ! Open data file + + CALL READDIR(0,IER1) ! Get NBLOCK + IF (IER1.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 + + NBLOCK = NBLOCK + 1 + LENGTH = NBLOCK ! Initialize line count + + LEN_FROM = TRIM(IN_FROM) + + IF (IN_FROM(LEN_FROM:LEN_FROM).EQ.'%') THEN ! Just protocol + PROTOCOL = IN_FROM(:LEN_FROM)//'"' + LPRO = LEN_FROM + 1 + LEN_FROM = 0 + END IF + + IF (LEN_FROM.GT.0) THEN + INFROM = IN_FROM + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_FROM(INFROM,LEN_FROM) + ELSE IF (INDEX(INFROM,'%"').GT.0) THEN ! Store any protocol + LPRO = INDEX(INFROM,'%"') + 1 + PROTOCOL = INFROM(:LPRO) + END IF + LEN_DESCRP = TRIM(IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + ELSE + OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH,IOSTAT=IER1) + IF (IER1.NE.0) THEN + OPEN (UNIT=3,STATUS='SCRATCH',FILE='BULL.SCR', + & FORM='FORMATTED',RECL=LINE_LENGTH) + END IF + SAVE_IN_DESCRIP = IN_DESCRIP + SAVE_IN_FROM = ' ' + END IF + + OLD_BUFFER = ' ' + + OLD_BUFFER_SUBJ = .FALSE. + OLD_BUFFER_FROM = .FALSE. + + INEXDATE = .FALSE. + + RETURN + END + + + + SUBROUTINE WRITEOUT_STORED + + CHARACTER*255 BUFFER + + REWIND (UNIT=3) + + IER = 0 + DO WHILE (IER.EQ.0) + READ (3,'(A)',IOSTAT=IER) BUFFER + IF (IER.EQ.0) THEN + CALL WRITE_MESSAGE_LINE(BUFFER) + END IF + END DO + + CLOSE (UNIT=3) + + RETURN + END + + + + SUBROUTINE WRITE_MESSAGE_LINE(BUFFER) +C +C SUBROUTINE WRITE_MESSAGE_LINE +C +C FUNCTION: Writes one line of message into folder. +C +C INPUTS: +C BUFFER - Character string containing line to be put into message. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + COMMON /MAIN_HEADER_INFO/ INEXDATE + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + DATA FIRST_BREAK/.TRUE./ + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + CHARACTER*(*) BUFFER + + COMMON /LAST_BUFFER/ OLD_BUFFER + CHARACTER*(LINE_LENGTH) OLD_BUFFER + + COMMON /OLD_BUFFER/ OLD_BUFFER_FROM,OLD_BUFFER_SUBJ + + COMMON /DATE/ DATE_LINE + CHARACTER*(LINE_LENGTH) DATE_LINE + + CHARACTER*23 TODAY + + LEN_BUFFER = TRIM(BUFFER) + + IF (LEN_FROM.EQ.0) THEN + WRITE (3,'(A)') BUFFER(:LEN_BUFFER) + IF (OLD_BUFFER_FROM.AND.((BUFFER(:1).EQ.' '.AND. + & LEN_BUFFER.GT.1).OR.INDEX(BUFFER,': ').EQ.0)) THEN + SAVE_IN_FROM = + & SAVE_IN_FROM(:TRIM(SAVE_IN_FROM))//BUFFER(:LEN_BUFFER) + RETURN + ELSE IF (OLD_BUFFER_SUBJ.AND.((BUFFER(:1).EQ.' '.AND. + & LEN_BUFFER.GT.1).OR.INDEX(BUFFER,': ').EQ.0)) THEN + INDESCRIP = + & INDESCRIP(:TRIM(INDESCRIP))//BUFFER(:LEN_BUFFER) + LDESCR = LDESCR + LEN_BUFFER + RETURN + ELSE IF (BUFFER(:5).EQ.'From:') THEN + IF (LEN_BUFFER.GE.7) SAVE_IN_FROM = BUFFER(7:) + OLD_BUFFER_FROM = .TRUE. + OLD_BUFFER_SUBJ = .FALSE. + RETURN + ELSE IF (BUFFER(:9).EQ.'Subject: ') THEN + LDESCR = LEN_BUFFER - 9 + INDESCRIP = BUFFER(10:) + OLD_BUFFER_SUBJ = .TRUE. + OLD_BUFFER_FROM = .FALSE. + RETURN + ELSE IF (BUFFER(:9).EQ.'Reply-to:'.AND.SAVE_IN_FROM.EQ.' ') THEN + IF (LEN_BUFFER.GE.11) SAVE_IN_FROM = BUFFER(11:) + OLD_BUFFER_FROM = .TRUE. + OLD_BUFFER_SUBJ = .FALSE. + RETURN + ELSE IF (LEN_BUFFER.EQ.0) THEN + IF (SAVE_IN_FROM.EQ.' ') CALL GETUSER(SAVE_IN_FROM) + LEN_FROM = TRIM(SAVE_IN_FROM) + IF (LEN_FROM.GT.0) THEN + OLD_BUFFER_FROM = .FALSE. + INFROM = SAVE_IN_FROM + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_FROM(INFROM,LEN_FROM) + ELSE IF (INDEX(INFROM,'%"').GT.0) THEN + LPRO = INDEX(INFROM,'%"') + 1 + PROTOCOL = INFROM(:LPRO) + END IF + IF (LDESCR.GT.0) THEN + LEN_DESCRP = LDESCR + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + ELSE + LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = SAVE_IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + END IF + CALL WRITEOUT_STORED + END IF + END IF + OLD_BUFFER_FROM = .FALSE. + OLD_BUFFER_SUBJ = .FALSE. + RETURN + END IF + IF (BTEST(FOLDER_FLAG,5)) THEN + IF (INDEX(BUFFER,'-------------').EQ.1) THEN + BREAK = .TRUE. + DO I=1,LEN_BUFFER + IF (BUFFER(I:I).NE.'-') BREAK = .FALSE. + END DO + ELSE + BREAK = .FALSE. + END IF + IF (BREAK) THEN + IF (.NOT.FIRST_BREAK) THEN + CALL FINISH_MESSAGE_ADD + CALL INIT_MESSAGE_ADD_DIGEST(INFROM,INDESCRIP,IER) + ELSE + FIRST_BREAK = .FALSE. + END IF + LFROM = 0 + LDESCR = 0 + RETURN + ELSE IF (.NOT.FIRST_BREAK) THEN + IF (LDESCR.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + LDESCR = LEN_BUFFER - 9 + CALL STORE_DESCRP(BUFFER(10:),LDESCR) + IF (LFROM.EQ.0) THEN + LFROM = LEN_FROM + CALL STORE_FROM(INFROM,LFROM) + END IF + ELSE IF (BUFFER(:6).EQ.'From: ') THEN + LFROM = LEN_BUFFER - 6 + IF (LFROM.LE.0) THEN + LFROM = TRIM(SAVE_IN_FROM) + IF (LPRO.GT.0) THEN + LFROM = LFROM + LPRO + 1 + CALL STORE_FROM(PROTOCOL(:LPRO)// + & SAVE_IN_FROM//'"',LFROM) + ELSE + CALL STORE_FROM(SAVE_IN_FROM,LFROM) + END IF + ELSE IF (LPRO.GT.0) THEN + LFROM = LFROM + LPRO + 1 + CALL STORE_FROM(PROTOCOL(:LPRO)// + & BUFFER(7:LEN_BUFFER)//'"',LFROM) + ELSE + CALL STORE_FROM(BUFFER(7:),LFROM) + END IF + END IF + RETURN + END IF + ELSE + RETURN + END IF + END IF + + IF (LEN_BUFFER.EQ.0) THEN ! If empty line + CALL STORE_BULL(1,' ',NBLOCK) ! just store one space + ELSE + IF (LEN_DESCRP.EQ.0) THEN + IF (BUFFER(:9).EQ.'Subject: ') THEN + DESCRIP = BUFFER(INDEX(BUFFER,' ')+1:) + LEN_DESCRP = LEN_BUFFER + END IF + END IF + IF (.NOT.INEXDATE) THEN + IF (BUFFER(:9).EQ.'Expires: '.OR. + & BUFFER(:11).EQ.'X-Expires: ') THEN + I = INDEX(BUFFER,' ')+1 + NODATE = .FALSE. + DO J=I,LEN_BUFFER + IF (BUFFER(J:J).EQ.','.OR.BUFFER(J:J).EQ.'-') THEN + BUFFER(J:J) = ' ' + END IF + END DO + CALL STR$UPCASE(BUFFER(I:),BUFFER(I:)) + NODATE = .TRUE. + I = INDEX(BUFFER,' ')+1 + EXDATE(3:3) = '-' + EXDATE(7:7) = '-' + DO WHILE (I.LE.LEN_BUFFER) + IF (BUFFER(I:I).GE.'0'.AND.BUFFER(I:I).LE.'9') THEN + IF (NODATE) THEN + IF (INDEX(BUFFER(I:),' ').EQ.2) THEN + EXDATE(1:2) = '0'//BUFFER(I:I) + I = I + 1 + ELSE + EXDATE(1:2) = BUFFER(I:I+1) + I = I + 2 + END IF + NODATE = .FALSE. + ELSE + IF (LEN_BUFFER-I.EQ.1.OR. + & INDEX(BUFFER(I:),' ').EQ.3) THEN ! No century? + IER = SYS$ASCTIM(,TODAY,,) ! Get today's date + YEAR = INDEX(TODAY(6:),'-') + EXDATE(8:) = TODAY(6+YEAR:7+YEAR)//BUFFER(I:I+1) + I = I + 2 + ELSE + EXDATE(8:) = BUFFER(I:I+3) + I = I + 4 + END IF + END IF + ELSE IF (BUFFER(I:I).GE.'A'.AND.BUFFER(I:I).LE.'Z') THEN + EXDATE(4:6) = BUFFER(I:I+2) + I = I + 3 + ELSE + I = I + 1 + END IF + END DO + INEXDATE = .TRUE. + END IF + END IF + CALL STORE_BULL(MIN(LEN_BUFFER,LINE_LENGTH),BUFFER,NBLOCK) + TEXT = .TRUE. + END IF + + RETURN + END + + + + + SUBROUTINE FINISH_MESSAGE_ADD +C +C SUBROUTINE FINISH_MESSAGE_ADD +C +C FUNCTION: Writes message entry into directory file and closes folder +C +C NOTE: Only should be run if INIT_MESSAGE_ADD was successful. +C + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /DIGEST/ LDESCR,FIRST_BREAK + + COMMON /TEXT_PRESENT/ TEXT + + COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP + COMMON /MAIN_HEADER_INFO/ INEXDATE + CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP + + COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM + CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM + + CHARACTER*23 TODAY + + DIMENSION BIN_EXTIME(2) + + IF (LEN_FROM.EQ.0) THEN + CALL GETUSER(FROM) + INFROM = FROM + LEN_FROM = TRIM(INFROM) + LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) + IF (LEN_DESCRP.GT.0) THEN + INDESCRIP = SAVE_IN_DESCRIP + IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN + CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) + END IF + ELSE + DESCRIP = ' ' + END IF + CALL WRITEOUT_STORED + END IF + + CALL FLUSH_BULL(NBLOCK) + + CALL CLOSE_BULLFIL ! Finished adding bulletin + + IF ((BTEST(FOLDER_FLAG,5).AND.LDESCR.EQ.0).OR. ! End of digest msg + & .NOT.TEXT) THEN ! or no message text found + CALL CLOSE_BULLDIR ! then don't add message entry + RETURN + END IF + + EXTIME = '00:00:00.00' + IF (INEXDATE) THEN + IER = SYS_BINTIM(EXDATE//' '//EXTIME,BIN_EXTIME) + IF (IER) THEN ! If good date format + IER = SYS$ASCTIM(,TODAY,,) ! Get today's date + IER = COMPARE_DATE(EXDATE,TODAY(:11)) ! Compare date with today's + IF ((IER.GT.F_EXPIRE_LIMIT.AND.F_EXPIRE_LIMIT.GT.0) ! Too great? + & .OR.IER.LE.0) THEN ! or expiration date not future + INEXDATE = .FALSE. ! Don't use it + END IF + ELSE + INEXDATE = .FALSE. ! Don't use it + END IF + END IF + + IF (.NOT.INEXDATE) THEN + IF (FOLDER_BBEXPIRE.EQ.-1) THEN ! Folder has expiration time? + EXDATE = '5-NOV-2000' ! no, so set date far in future + SYSTEM = 2 ! indicate permanent message + ELSE ! Else set expiration date + CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) + SYSTEM = 0 + END IF + END IF + + LENGTH = NBLOCK - LENGTH + 1 ! Number of records + + CALL ADD_ENTRY ! Add the new directory entry + + CALL CLOSE_BULLDIR ! Totally finished with add + + CALL UPDATE_FOLDER + + RETURN + END + + + + + SUBROUTINE STORE_FROM(IFROM,LEN_INFROM) + + IMPLICIT INTEGER (A-Z) + + COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO + CHARACTER*12 PROTOCOL + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) IFROM + + CHARACTER*(LINE_LENGTH) INFROM + + INFROM = IFROM + + IF (LPRO.GT.0) THEN ! Protocol present? + I = INDEX(INFROM,'%"') + 2 ! Make usable for VMS MAIL + IF (I.EQ.2) THEN + INFROM = PROTOCOL(:LPRO)//INFROM(:LEN_INFROM)//'"' + I = LPRO + 1 + LEN_INFROM = LEN_INFROM + LPRO + 1 + END IF + DO WHILE (I.LT.LEN_INFROM) + IF (INFROM(I:I).EQ.'"') THEN + INFROM(I:I) = '''' + ELSE IF (INFROM(I:I).EQ.'\') THEN + INFROM(I+1:) = '\'//INFROM(I+1:) + LEN_INFROM = LEN_INFROM + 1 + I = I + 1 + ELSE IF (INFROM(I:I).EQ.''''.AND. + & INDEX(INFROM,'@').GT.I) THEN + INFROM(I:) = '\s'//INFROM(I+1:) + LEN_INFROM = LEN_INFROM + 1 + I = I + 2 + END IF + I = I + 1 + END DO + END IF + + DO I=1,LEN_INFROM ! Remove control characters + IF (INFROM(I:I).LT.' ') INFROM(I:I) = ' ' + END DO + + DO WHILE (LEN_INFROM.GT.0.AND.INFROM(:1).EQ.' ') + INFROM = INFROM(2:) + LEN_INFROM = LEN_INFROM - 1 + END DO + + TWO_SPACE = INDEX(INFROM,' ') + DO WHILE (TWO_SPACE.GT.0.AND.TWO_SPACE.LT.LEN_INFROM) + INFROM = INFROM(:TWO_SPACE)//INFROM(TWO_SPACE+2:) + LEN_INFROM = LEN_INFROM - 1 + TWO_SPACE = INDEX(INFROM,' ') + END DO + + CALL STORE_BULL(6+LEN_INFROM,'From: '//INFROM(:LEN_INFROM), + & NBLOCK) + + IF (INDEX(INFROM,'%"').GT.0) ! Strip off protocol program + & INFROM = INFROM(INDEX(INFROM,'%"')+2:) + + IF (INDEX(INFROM,'::').GT.0) ! Strip off node name + & INFROM = INFROM(INDEX(INFROM,'::')+2:) ! I.e. HOST::USER + + CALL GET_FROM(INFROM,LEN_INFROM) + + RETURN + END + + + SUBROUTINE GET_FROM(INFROM,LEN_INFROM) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) INFROM + + DO WHILE (INDEX(INFROM,'!').GT.0.AND. ! Unix address go backwards. + & INDEX(INFROM,'!').LT.INDEX(INFROM,'@')) + INFROM = INFROM(INDEX(INFROM,'!')+1:) ! I.e. host!user + END DO + + DO WHILE (INDEX(INFROM,'<').GT.0.AND. ! Name may be of form + & INDEX(INFROM,'@').GT.INDEX(INFROM,'<')) + INFROM = INFROM(INDEX(INFROM,'<')+1:)! personal-name + END DO + + DO WHILE (INDEX(INFROM,'(').GT.0.AND. ! personal-name (net-name) + & INDEX(INFROM,'@').GT.INDEX(INFROM,'(')) + INFROM = INFROM(INDEX(INFROM,'(')+1:) + END DO + + I = 1 ! Trim username to start at first alpha character + DO WHILE (I.LE.LEN_INFROM.AND.(INFROM(I:I).EQ.' '.OR. + & INFROM(I:I).EQ.'%'.OR.INFROM(I:I).EQ.'.'.OR. + & INFROM(I:I).EQ.'@'.OR.INFROM(I:I).EQ.'<'.OR. + & INFROM(I:I).EQ.'\'.OR. + & INFROM(I:I).EQ.'"'.OR.INFROM(I:I).EQ.'''')) + I = I + 1 + END DO + INFROM = INFROM(I:) + + I = 1 ! Trim username to end at a alpha character + DO WHILE (I.LE.12.AND.INFROM(I:I).NE.' '.AND. + & INFROM(I:I).NE.'%'.AND.INFROM(I:I).NE.'.'.AND. + & INFROM(I:I).NE.'@'.AND.INFROM(I:I).NE.'<'.AND. + & INFROM(I:I).NE.'\'.AND. + & INFROM(I:I).NE.'"'.AND.INFROM(I:I).NE.'''') + I = I + 1 + END DO + FROM = INFROM(:I-1) + + DO J=2,I-1 + IF ((FROM(J:J).GE.'A'.AND.FROM(J:J).LE.'Z').AND. + & ((FROM(J-1:J-1).GE.'A'.AND.FROM(J-1:J-1).LE.'Z').OR. + & (FROM(J-1:J-1).GE.'a'.AND.FROM(J-1:J-1).LE.'z'))) THEN + FROM(J:J) = CHAR(ICHAR(FROM(J:J))-ICHAR('A')+ICHAR('a')) + END IF + END DO + + RETURN + END + + + + + SUBROUTINE STORE_DESCRP(INDESCRIP,LEN_DESCRP) + + IMPLICIT INTEGER (A-Z) + + INCLUDE 'BULLDIR.INC' + + CHARACTER*(*) INDESCRIP + + CALL CONVERT_TABS(INDESCRIP,LEN_DESCRP) + + DO I=1,LEN_DESCRP ! Remove control characters + IF (INDESCRIP(I:I).LT.' ') INDESCRIP(I:I) = ' ' + END DO + + DO WHILE (LEN_DESCRP.GT.0.AND.INDESCRIP(:1).EQ.' ') + INDESCRIP = INDESCRIP(2:) + LEN_DESCRP = LEN_DESCRP - 1 + END DO + + IF (LEN_DESCRP.GT.LEN(DESCRIP)) THEN + ! Is length > allowable subject length? + CALL STORE_BULL(6+LEN_DESCRP,'Subj: '// + & INDESCRIP(:LEN_DESCRP),NBLOCK) + END IF + + DESCRIP = INDESCRIP(:MIN(LEN_DESCRP,LEN(DESCRIP))) + + RETURN + END + + + + + + SUBROUTINE STRIP_HEADER(BUFFER,BLEN,IER) +C +C SUBROUTINE STRIP_HEADER +C +C FUNCTION: Indicates whether line is part of mail message header. +C +C INPUTS: +C BUFFER - Character string containing input line of message. +C BLEN - Length of character string. If = 0, initialize subroutine. +C +C OUTPUTS: +C IER - If true, line should be stripped. Else, end of header. +C + IMPLICIT INTEGER (A - Z) + + INCLUDE 'BULLDIR.INC' + + INCLUDE 'BULLFOLDER.INC' + + COMMON /DATE/ DATE_LINE + CHARACTER*(LINE_LENGTH) DATE_LINE + + COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT + + CHARACTER*(*) BUFFER + + IF (TRIM(BUFFER).EQ.0) THEN + ! If STRIP not set for folder or empty line + IER = .FALSE. + CONT_LINE = .FALSE. + RETURN + END IF + + IF (BLEN.EQ.0) THEN + DATE_LINE = ' ' + CONT_LINE = .FALSE. + END IF + + IER = .TRUE. + + IF (CONT_LINE.AND.(BUFFER(:1).EQ.' '.OR. ! If line is continuation + & BUFFER(:1).EQ.CHAR(9))) RETURN ! of previous header line + + I = 1 + DO WHILE (I.LE.BLEN.AND.BUFFER(I:I).NE.' ') + IF (BUFFER(I:I).EQ.':') THEN ! Header line found + CONT_LINE = .TRUE. ! Next line might be continuation + IF (REMOTE_SET.NE.3.AND.BUFFER(:5).EQ.'Date:') THEN + DATE_LINE = 'Message sent'//BUFFER(5:BLEN) + IF (DATE_LINE(TRIM(DATE_LINE):).NE.'.') THEN + DATE_LINE(TRIM(DATE_LINE)+1:) = '.' + END IF + END IF + RETURN + ELSE + I = I + 1 + END IF + END DO + + IER = .FALSE. + CONT_LINE = .FALSE. + + RETURN + END diff --git a/decus/vax91b/gce91b/net91b/mx.com b/decus/vax91b/gce91b/net91b/mx.com new file mode 100644 index 0000000..991d7a6 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/mx.com @@ -0,0 +1,958 @@ +$set nover +$copy/log sys$input BUILD_MX_BULL.COM +$deck +$ save_verify = 'f$verify(0)' +$! +$! Command file to build MX_BULL (MX SITE transport for BULLETIN) +$! +$ say := write sys$output +$ if f$trnlnm("BULL_SOURCE") .eqs. "" +$ then say "BULL_SOURCE logical not defined; must point to BULL.OLB directory" +$ exit +$ endif +$ say "Compiling MX_BULL...." +$ cc mx_bull +$ say "Linking MX_BULL...." +$ link/notrace mx_bull,bull_source:BULL.OLB/LIB,sys$input/option +SYS$SHARE:VAXCRTL.EXE/SHARE +$ say "Build of MX_BULL.EXE completed" +$ exit f$verify(save_verify).or.1 +$eod +$copy/log sys$input MX_BULL.C +$deck +#module MX_BULL "01-001" +/* + * + * Program: MX_BULL + * + * Author: Hunter Goatley + * Academic Computing, STH 226 + * Western Kentucky University + * Bowling Green, KY 42101 + * goathunter@wkuvx1.bitnet + * 502-745-5251 + * + * Date: March 8, 1991 + * + * Functional description: + * + * This program serves as an MX SITE transport to transfer incoming + * mail files to UALR's BULLETIN. + * + * The MX_SITE delivery agent takes messages routed to a SITE path and + * feeds them into a subprocess that executes a command procedure named + * MX_EXE:SITE_DELIVER.COM. There are three parameters passed to the + * the command procedure: + * + * P1 - The name of a temporary file containing the message + * text, including all of the RFC822 headers + * (corresponding to the DATA part of an SMTP + * transaction). + * P2 - The name of a temporary file containing a list of + * a messages recipients, which corresponds to the + * RCPT_TO addresses of an SMTP transaction. + * P3 - The RFC822 address of the sender of the message, + * which corresponds to the MAIL FROM address of an + * SMTP transaction. + * + * This program expects the same parameters, except that the third + * parameter is optional. If the third parameter is omitted, BULLETIN + * will scan the RFC822 headers in the message for a "From:" line. + * If the third parameter is specified, it is expected to be a file + * specification. It is assumed that SITE_DELIVER.COM has written the + * address to this file. + * + * The logical MX_BULLETIN_POSTMASTER can be defined as a local + * username to receive error notices. If BULLETIN returns an error + * while trying to add a message, and the MX_BULLETIN_POSTMASTER + * is defined as a valid local username, the message will be mailed + * to that user for further handling. + * + * MX_BULLETIN_POSTMASTER must be defined system-wide in executive mode: + * + * $ DEFINE/SYS/EXEC MX_BULLETIN_POSTMASTER GOATHUNTER + * + * Modification history: + * + * 01-001 Hunter Goatley 14-MAR-1991 14:41 + * Added scan_for_from_line, which scans the message's RFC822 + * headers for the "From:" line. General cleanup on a few + * routines. MX_BULL now provides an RESPOND-able address in + * BULLETIN. + * + * 01-000 Hunter Goatley 8-MAR-1991 07:20 + * Genesis. + * + */ + +/* Include all needed structures and constants */ + +#include descrip +#include lib$routines +#include libdef +#include lnmdef +#include maildef +#include rms +#include ssdef +#include str$routines +#include string + +/* Declare the external BULLETIN routines that we call */ + +unsigned long int INIT_MESSAGE_ADD(); +unsigned long int WRITE_MESSAGE_LINE(); +unsigned long int FINISH_MESSAGE_ADD(); + +/* Define some macros to make things a little easier */ + +#define rms_get(rab) ((rms_status = SYS$GET(rab))) +#define err_exit(stat) {traceerr(stat); return(stat);} +#define vms_errchk2() if(!(vms_status&1)) err_exit(vms_status); +#define vms_errchk(func) {vms_status=func; vms_errchk2();} + +#define tracemsg(msg) if (trace) printf("MX_BULL: %s\n",msg); +#define traceerr(msg) if (trace) printf("MX_BULL: Error status %%X%08x\n",msg); + +/* Define some global variables to make things easy */ + +struct FAB msgfab; /* FAB for message text */ +struct RAB msgrab; /* RAB for message text */ +struct FAB rcptfab; /* FAB for recipients file */ +struct RAB rcptrab; /* RAB for recipients file */ +struct FAB fromfab; /* FAB for FROM file */ +struct RAB fromrab; /* RAB for FROM file */ +char msgbuf[512]; /* Input buffer for msgrab */ +char rcptbuf[512]; /* Input buffer for rcptrab */ +char frombuf[512]; /* Input buffer for frombuf */ +short trace; +unsigned long int rms_status; /* Status of RMS calls */ +unsigned long int vms_status; /* Status of other calls */ + +static $DESCRIPTOR(lnm_table,"LNM$SYSTEM_TABLE"); + +#define itmlstend {0,0,0,0} /* An empty item list */ +typedef struct itmlst /* An item list structure */ +{ + short buffer_length; + short item_code; + long buffer_address; + long return_length_address; +} ITMLST; + +ITMLST + nulllist[] = {itmlstend}; + +ITMLST + address_itmlst[] = { /* MAIL$SEND_ADD_ADDRESS */ + {0, MAIL$_SEND_USERNAME, 0, 0}, + itmlstend}, + bodypart_itmlst[] = { /* MAIL$SEND_ADD_BODYPART */ + {0, MAIL$_SEND_RECORD, 0, 0}, + itmlstend}, + attribute_itmlst[] = { /* MAIL$SEND_ADD_ATTRIBUTE */ + {0, MAIL$_SEND_TO_LINE, 0, 0}, + {0, MAIL$_SEND_FROM_LINE, 0, 0}, + {0, MAIL$_SEND_SUBJECT, 0, 0}, + itmlstend} + ; + +ITMLST + trnlnm_itmlst[] = { /* $TRNLNM item list */ + {0, LNM$_STRING, 0, 0}, + itmlstend} + ; + + +/* + * + * Function: open_file_rms + * + * Functional description: + * + * This routine opens a sequential text file in VMS "normal text" file + * format. It uses RMS to open the file. + * + * Inputs: + * + * infab - Address of the input FAB + * inrab - Address of the input RAB + * buff - Address of the input buffer + * filename - Address of the filename to open (ASCIZ) + * + * Outputs: + * + * fab and rab are modified if file is opened. + * + * Returns: + * + * RMS status + * + */ +unsigned long int +open_file_rms (struct FAB *infab, struct RAB *inrab, char *buff, char *filename) +{ + unsigned long int rms_status; + + *infab = cc$rms_fab; /* Initialize the FAB */ + *inrab = cc$rms_rab; /* Initialize the RAB */ + infab->fab$b_fns = strlen(filename); /* Set filename length */ + infab->fab$l_fna = filename; /* Set filename address */ + infab->fab$b_fac = FAB$M_GET; /* GET access only */ + infab->fab$b_shr = FAB$M_SHRGET+FAB$M_SHRPUT+FAB$M_SHRUPD; + inrab->rab$l_fab = infab; /* Let RAB point to FAB */ + inrab->rab$b_rac = RAB$C_SEQ; /* Sequential file access */ + inrab->rab$w_usz = 512; /* Record size is 512 bytes */ + inrab->rab$l_ubf = buff; /* Read to this buffer */ + + rms_status = SYS$OPEN (infab); /* Open the file */ + if (!(rms_status & 1)) /* If an error occurs, return */ + return (rms_status); /* ... a status */ + rms_status = SYS$CONNECT (inrab); /* Connect the RAB */ + return (rms_status); /* Return the RMS status */ +} + +/* + * + * Function: init_sdesc + * + * Functional description: + * + * Initialize a static string descriptor. + * + * Inputs: + * + * sdesc - Address of the descriptor to initialize + * (of type struct dsc$descriptor_s) + * string - Address of null-terminated string the descriptor describes + * + * Outputs: + * + * sdesc - Descriptor passed as sdesc is initialized + * + */ +void +init_sdesc (struct dsc$descriptor_s *sdesc, char *string) +{ + sdesc->dsc$w_length = strlen(string); /* Set the length */ + sdesc->dsc$b_dtype = DSC$K_DTYPE_T; /* Type is text */ + sdesc->dsc$b_class = DSC$K_CLASS_S; /* Class is static */ + sdesc->dsc$a_pointer = string; /* Point to the string */ +} + +/* + * + * Function: add_to_bulletin_folder + * + * Functional description: + * + * Adds a message to a BULLETIN folder by calling the external + * BULLETIN routines INIT_MESSAGE_ADD, WRITE_MESSAGE_LINE, and + * FINISH_MESSAGE_ADD. + * + * The following constants are (may be) passed to INIT_MESSAGE_ADD: + * + * Subject = "" Causes BULLETIN to scan RFC822 headers for + * a "Subject:" or "Subj:" line + * From = "MX%" Causes BULLETIN to scan RFC822 headers for + * a "Reply-to:" or "From:" line + * + * Inputs: + * + * filerab - Address of the message file's RAB + * folder - Address of a string descriptor for the name of the folder + * from - Address of a string descriptor for the "From:" address + * + * Outputs: + * + * None. + * + * Returns: + * + * unsigned long int - RMS status of call to INIT_MESSAGE_ADD + * + */ +unsigned long int +add_to_bulletin_folder(struct RAB *filerab, void *folder, void *from) +{ + unsigned long int bull_status; /* Status from INIT_MESSAGE_ADD */ + struct dsc$descriptor_s msg_line; /* Descriptor for a line of the msg */ + static $DESCRIPTOR(subject,""); /* Subject is "" */ + + /* Call BULLETIN routine to initialize adding the message */ + + INIT_MESSAGE_ADD (folder, from, &subject, &bull_status); + + if (!(bull_status & 1)){ /* Error? */ + return(bull_status); + } + + /* Loop reading message lines until end-of-file. For each line read, + create a string descriptor for it and call the BULLETIN routine to + add the line. */ + + while (rms_get(filerab) != RMS$_EOF){ /* Loop until EOF */ + filerab->rab$l_rbf[filerab->rab$w_rsz] = 0; /* End byte = NULL */ + init_sdesc(&msg_line, filerab->rab$l_rbf); /* Now build desc. */ + WRITE_MESSAGE_LINE (&msg_line); /* Add to BULLETIN */ + } + + FINISH_MESSAGE_ADD(); /* Call BULLETIN routine to finish */ + + tracemsg("Message added to folder"); + return(SS$_NORMAL); /* Return success to caller */ +} + + +/* + * + * Function: scan_for_from_line + * + * Functional description: + * + * The routine scans the message's RFC822 headers for the "From:" line. + * It parses out the address by extracting the
. + * + * This routine was necessary because letting BULLETIN find the "From:" + * line was resulting in a non-RESPONDable address for MX. For example, + * BULLETIN was creating: + * + * From: MX%"Hunter Goatley, WKU " + * + * but MX needs + * + * From: MX%"" + * + * Inputs: + * + * filerab - Address of the message file's RAB + * + * Outputs: + * + * final_from - Address of a character buffer to receive the final address + * + * Returns: + * + * unsigned long int - binary success/failure status + * + * Side effects: + * + * The message file is rewound so that subsequent GETs start at the + * beginning of the message. + * + */ +unsigned long int +scan_for_from_line(struct RAB *filerab, char *final_from) +{ + unsigned long int scan_status; /* Status from INIT_MESSAGE_ADD */ + struct dsc$descriptor_s msg_line; /* Descriptor for a line of the msg */ + char whole_from_line[512]; /* The assembled "From:" line */ + char *filebuffer; /* Pointer to the input buffer */ + int i, j, x; /* Work variables */ + + scan_status = SS$_NORMAL; /* Assume success */ + whole_from_line[0] = '\0'; /* Initialize work buffer */ + + /* Loop reading message lines until end-of-file or first null line, + which should signal the end of the RFC822 header. For each line read, + check to see if we've located the "From:" line. + */ + + filebuffer = filerab->rab$l_ubf; /* Init buffer ptr */ + while ((rms_get(filerab) != RMS$_EOF) && /* Loop until EOF */ + ((x = filerab->rab$w_rsz) != 0)){ /* or null record */ + filebuffer[x] = '\0'; /* Set NULL byte */ + if (strncmp(filebuffer,"From:",5)==0){ /* Is it the "From:"? */ + + /* Found "From:" line */ + tracemsg("Found \042From:\042 line in RFC822 header"); + strcpy(whole_from_line,filebuffer); /* Copy to work buff */ + + /* The "From:" line may actually be split over several lines. + In such cases, the remaining lines are indented by 6 spaces. + To handle this, loop reading records until one is read that + doesn't begin with a blank. As each record is read, it is + trimmed and tacked on to whole_from_line, so we end up with + the entire "From:" line in one buffer. */ + + while((rms_get(filerab) != RMS$_EOF) && /* Read rest of From: */ + (filebuffer[0] == ' ')){ /* ... line */ + for (i = 0; filebuffer[i] == ' '; ++i); /* Step over blanks */ + strcat(whole_from_line,&filebuffer[i]); /* Tack it on end */ + } + + /* Now have the whole "From:" line in whole_from_line. Since + the real address is enclosed in "<>", look for it by + searching for the last "<" and reading up to the ">". */ + + i = strrchr(whole_from_line,'<'); /* Find last "<" */ + if (i != 0){ /* Found it.... */ + j = strchr(i,'>'); /* Find last ">" */ + j = j-i+1; /* Calc addr length */ + } + else{ + j = strlen(whole_from_line)-6; /* Don't count From: */ + i = &whole_from_line + 6; /* in string length */ + } + if (j < 0){ /* If neg., error */ + tracemsg("Error - unable to locate from address"); + strcpy(final_from,""); /* Return null string */ + scan_status = 0; /* Set error status */ + } + else { + tracemsg("Found sender's address in RFC822 header"); + strncpy(final_from, i, j); /* Copy to caller */ + } + } + } + + SYS$REWIND(filerab); /* Rewind the file to the beginning */ + return(scan_status); /* Return success to caller */ +} + + +/* + * + * Function: forward_to_postmaster + * + * Functional description: + * + * If an error occurs trying to write a message to a BULLETIN folder, + * this routine is called to forward the message to the local + * postmaster. + * + * Inputs: + * + * filerab - Address of the message file's RAB + * folder - Address of a string descriptor for the name of the folder + * from - Address of a string descriptor for the "From:" address + * status - Address of longword containing the BULLETIN error code + * + * Outputs: + * + * None. + * + * Returns: + * + * unsigned long int - binary status of call to INIT_MESSAGE_ADD + * + * Side effects: + * + * The message file is rewound so that subsequent calls to this routine + * can be made (in case the message is to be written to several folders). + * + */ +unsigned long int +forward_to_postmaster(struct RAB *filerab, void *folder, void *from, int status) +{ + struct dsc$descriptor_s msg_line; /* Descriptor for a line of the msg */ + struct dsc$descriptor_s subject; + char subject_buf[256]; + char postmaster[256]; int postmaster_len; + char status_msg_buf[256]; int status_msg_len; + struct dsc$descriptor_s status_msg; + static $DESCRIPTOR(faostr,"Failed BULLETIN message for folder !AS"); + static $DESCRIPTOR(MXBULL,"MX->SITE (BULLETIN delivery)"); + static $DESCRIPTOR(postmaster_lnm,"MX_BULLETIN_POSTMASTER"); + int send_context = 0; int x; int y; + + static char *error_msgs[] = { + {"Error delivering message to BULLETIN folder. BULLETIN error status:"}, + {""}, + {""}, + {"Original message text follows:"}, + {"--------------------------------------------------"} + }; + + trnlnm_itmlst[0].buffer_length = 255; + trnlnm_itmlst[0].buffer_address = &postmaster; + trnlnm_itmlst[0].return_length_address = &postmaster_len; + + SYS$TRNLNM( 0, &lnm_table, &postmaster_lnm, 0, trnlnm_itmlst); + if (postmaster_len == 0) /* If logical is not defined, */ + return(SS$_NORMAL); /* then pretend it worked */ + + tracemsg("Forwarding message to local postmaster...."); + subject.dsc$w_length = 255; + subject.dsc$a_pointer = &subject_buf; + SYS$FAO(&faostr, &subject, &subject, folder); /* Format the subject */ + + address_itmlst[0].buffer_length = postmaster_len; /* To: */ + address_itmlst[0].buffer_address = &postmaster; /* To: */ + attribute_itmlst[0].buffer_length = postmaster_len; /* To: */ + attribute_itmlst[0].buffer_address = &postmaster; /* To: */ + attribute_itmlst[1].buffer_length = MXBULL.dsc$w_length; /* From: */ + attribute_itmlst[1].buffer_address = MXBULL.dsc$a_pointer; /* From: */ + attribute_itmlst[2].buffer_length = subject.dsc$w_length; /* Subject:*/ + attribute_itmlst[2].buffer_address = subject.dsc$a_pointer; /* Subject:*/ + + vms_errchk(mail$send_begin(&send_context, &nulllist, &nulllist)); + vms_errchk(mail$send_add_address(&send_context, &address_itmlst, + &nulllist)); + vms_errchk(mail$send_add_attribute(&send_context, &attribute_itmlst, + &nulllist)); + + for (x = 0; x < 5; x++){ + bodypart_itmlst[0].buffer_length = strlen(error_msgs[x]); + bodypart_itmlst[0].buffer_address = error_msgs[x]; + vms_errchk(mail$send_add_bodypart(&send_context, + &bodypart_itmlst, &nulllist)); + if (x == 1){ + status_msg.dsc$w_length = 256; + status_msg.dsc$b_dtype = DSC$K_DTYPE_T; + status_msg.dsc$b_class = DSC$K_CLASS_S; + status_msg.dsc$a_pointer = &status_msg_buf; + y = SYS$GETMSG (status, &status_msg, &status_msg, 15, 0); + if (!(y & 1)) + sprintf(status_msg_buf,"Error code is %%X%08x",status); + else + status_msg_buf[status_msg.dsc$w_length] = '\0'; + bodypart_itmlst[0].buffer_length = strlen(status_msg_buf); + bodypart_itmlst[0].buffer_address = &status_msg_buf; + vms_errchk(mail$send_add_bodypart(&send_context,&bodypart_itmlst, + &nulllist)); + } + } + + while (rms_get(filerab) != RMS$_EOF){ /* Loop until EOF */ + bodypart_itmlst[0].buffer_length = filerab->rab$w_rsz; + bodypart_itmlst[0].buffer_address = filerab->rab$l_rbf; + vms_errchk(mail$send_add_bodypart(&send_context, + &bodypart_itmlst, &nulllist)); + } + + vms_errchk(mail$send_message(&send_context, &nulllist, &nulllist)); + vms_errchk(mail$send_end(&send_context, &nulllist, &nulllist)); + + tracemsg("Message forwarded to postmaster...."); +} + + +/* + * + * Function: log_accounting + * + * Functional description: + * + * This routine will write an accounting record for the message. + * + * Inputs: + * + * folder - Address of a string descriptor for the name of the folder + * from - Address of a string descriptor for the "From:" address + * status - Address of longword containing the BULLETIN error code + * + * Outputs: + * + * None. + * + * Returns: + * + * unsigned long int - RMS status + * + */ +unsigned long int +log_accounting(void *folder, void *from, int bull_status) +{ + struct FAB accfab; + struct RAB accrab; + static $DESCRIPTOR(MX_BULL_ACCNTNG,"MX_BULLETIN_ACCNTNG"); + static $DESCRIPTOR(faostr, + "!%D MX_BULL: FOLDER=\042!AS\042, ORIGIN=\042!AS\042, STATUS=%X!XL"); + char outbufbuf[256]; + struct dsc$descriptor_s outbuf = {256, DSC$K_DTYPE_T, DSC$K_CLASS_S, + &outbufbuf}; + + int status; + static char bullacc[] = "MX_BULLETIN_ACC"; + static char bullaccdef[] = "MX_SITE_DIR:.DAT"; + + status = SYS$TRNLNM( 0, &lnm_table, &MX_BULL_ACCNTNG, 0, 0); + if (!(status & 1)) + return(SS$_NORMAL); + + tracemsg("Writing accounting information to accounting log...."); + accfab = cc$rms_fab; + accrab = cc$rms_rab; + accfab.fab$b_fns = strlen(bullacc); /* Set filename length */ + accfab.fab$l_fna = &bullacc; /* Set filename address */ + accfab.fab$b_dns = strlen(bullaccdef); /* Set filename length */ + accfab.fab$l_dna = &bullaccdef; /* Set filename address */ + accfab.fab$b_fac = FAB$M_PUT; /* PUT access only */ + accfab.fab$b_shr = FAB$M_SHRGET+FAB$M_SHRPUT+FAB$M_SHRUPD; + accfab.fab$b_rfm = FAB$C_VAR; /* Variable length records */ + accfab.fab$b_rat = FAB$M_CR; /* Normal "text" rat */ + accrab.rab$l_fab = &accfab; /* Let RAB point to FAB */ + accrab.rab$b_rac = RAB$C_SEQ; /* Sequential file access */ + + status = SYS$OPEN (&accfab); /* Try to open the file */ + if (status & 1) /* Success? */ + accrab.rab$l_rop = RAB$M_EOF; /* Set to EOF */ + else /* Couldn't open, so create */ + status = SYS$CREATE (&accfab); /* ... a new one */ + if (status & 1){ /* If either was OK... */ + status = SYS$CONNECT (&accrab); /* Connect the RAB */ + if (status == RMS$_EOF) /* RMS$_EOF status is OK */ + status = RMS$_NORMAL; /* Change it to NORMAL */ + if (!(status & 1)){ /* If any error occurred */ + tracemsg("Unable to open accounting file"); + traceerr(status); + SYS$CLOSE (&accfab); /* Close the file */ + return(status); /* And return the error */ + } + } + else + return(status); + + SYS$FAO(&faostr, &outbuf, &outbuf, 0, folder, from, bull_status); + accrab.rab$w_rsz = outbuf.dsc$w_length; + accrab.rab$l_rbf = outbuf.dsc$a_pointer; + SYS$PUT (&accrab); + SYS$CLOSE (&accfab); +} + +/* + * + * Main routine + * + */ +main(int argc, char *argv[]) +{ + struct dsc$descriptor_s folder; /* Descriptor for the folder name */ + struct dsc$descriptor_s from_user; /* Descriptor for "From:" line */ + static $DESCRIPTOR(MX_SITE_DEBUG,"MX_SITE_DEBUG"); + + char *from_line; /* Pointer to dynamic "From:" buffer */ + char *folder_name; /* Pointer to folder name in rcptbuf */ + char *atsign; /* Pointer to "@" in rcptbuf */ + int x; /* Work variable */ + unsigned long int bull_status; /* Status from add_to_bulletin_folder */ + + --argc; /* Don't count the program name */ + if ((argc != 2) && (argc != 3)) { /* If too many or too few args, */ + exit(LIB$_WRONUMARG); /* ... exit with error status */ + } + + vms_status = SYS$TRNLNM( 0, &lnm_table, &MX_SITE_DEBUG, 0, 0); + if (vms_status & 1) + trace = 1; + else + trace = 0; + + /* Open all input files */ + + tracemsg("Opening message file...."); + vms_errchk(open_file_rms (&msgfab, &msgrab, &msgbuf, argv[1])); + tracemsg("Opening recipients file...."); + vms_errchk(open_file_rms (&rcptfab, &rcptrab, &rcptbuf, argv[2])); + + if (argc == 2){ + tracemsg("Using sender address from RFC822 headers...."); + scan_for_from_line(&msgrab, &frombuf); + } + else { + tracemsg("Opening sender address file...."); + vms_errchk(open_file_rms (&fromfab, &fromrab, &frombuf, argv[3])); + + tracemsg("Reading sender address from file...."); + rms_get(&fromrab); /* Read the from line */ + if (!(rms_status & 1)) /* Exit if an error occurred */ + err_exit(rms_status); + + /* Set the end of the record read, then initialize the descriptor for it */ + frombuf[fromrab.rab$w_rsz] = 0; + + SYS$CLOSE(&fromfab); + } /* End of "if (argc == 2)"... */ + + /* frombuf now has the sender's address in it */ + + if (strlen(frombuf) == 0) { + tracemsg("Unable to find sender's address, using MX%"); + init_sdesc(&from_user, "MX%"); + } + else{ + + /* Now add the MX% prefix and the double quotes */ + from_line = malloc(4 + strlen(frombuf) + 1 + 1); /* Allocate memory */ + + /* Make the string repliable through MX by adding MX%"" to it */ + strcpy(from_line,"MX%\042"); + strcat(from_line,frombuf); + strcat(from_line,"\042"); + if (trace) + printf("MX_BULL: Sender's address is %s\n", from_line); + init_sdesc (&from_user, from_line); /* Create a string descriptor */ + } + /* + Read through all the recipients, writing the message to all BULLETIN + folders (identified by checking for @BULLETIN in the address). + */ + rms_get(&rcptrab); /* Read a recipient */ + while ((rms_status & 1) & (rms_status != RMS$_EOF)){ + tracemsg("Looking for BULLETIN folder...."); + folder_name = &rcptbuf; /* Point to receipt buffer */ + if (folder_name[0] == '<'){ /* If line begins with "<" */ + ++folder_name; /* bump over it and check */ + atsign = strchr(rcptbuf,'@'); /* for a "@" */ + if (atsign != 0){ /* If "@" was found, */ + if (strncmp(atsign,"@BULLETIN",9)==0){/* Is it @BULLETIN? */ + x = atsign - folder_name; /* Length of folder name */ + folder_name[x] = 0; /* Terminate folder name */ + init_sdesc (&folder, folder_name); /* Initialize descriptor */ + str$upcase(&folder, &folder); /* Convert to uppercase */ + if (trace) + printf("MX_BULL: Found BULLETIN folder \042%s\042....\n", + folder_name); + tracemsg("Adding message to BULLETIN folder...."); + bull_status = add_to_bulletin_folder (&msgrab, &folder, &from_user); + if (!(bull_status & 1)){ + traceerr(bull_status); + vms_errchk(forward_to_postmaster(&msgrab, &folder, &from_user, + bull_status)); + } + log_accounting(&folder, &from_user, bull_status); + SYS$REWIND(&msgrab); /* Rewind the file for next folder */ + + } + } + } + rms_get(&rcptrab); /* Read next recipient */ + } + + + /* Close the RMS files */ + + SYS$CLOSE(&msgfab); SYS$CLOSE(&rcptfab); + + tracemsg("BULLETIN message processed"); + exit(SS$_NORMAL); /* Always return success */ + +} +$eod +$copy/log sys$input MX_BULL.TXT +$deck + MX_BULL + An MX SITE transport + March 14, 1991 + +MX_BULL is a transport between MX and BULLETIN, a VMS bulletin board program +by Mark London at MIT. It is designed to be called as an MX SITE transport, +letting MX write messages into BULLETIN folders as they are processed, instead +of routing the messages to MAIL.MAI files for each folder. + +The following files make up the MX_BULL distribution: + + BUILD_MX_BULL.COM Command procedure to build MX_BULL.EXE + MX_BULL.C VAX C source code for MX_BULL + MX_BULL.TXT This file + MX_BULL_SITE_DELIVER.COM SITE_DELIVER.COM for MX_BULL + +The current version is 01-001. + + +WHAT IS BULLETIN? +----------------- +BULLETIN is a VMS bulletin board written by Mark London at MIT that allows +multiple users to access a common message base. Messages are divided into +folders, which work much like VMS Mail folders. Using MX_BULL, messages can +be routed from Internet/Bitnet mailing lists directly to BULLETIN folders, +allowing all (or some) users on a system to access the mailing lists without +individual subscriptions. This can cut down on the number of incoming +Bitnet/Internet mail messages significantly, since only one copy of a message +need be sent to a site. + +BULLETIN can be found on a number of the DECUS VAX SIG tapes, including the +Fall 1990 tapes. It can also be retrieved by sending a mail message to +BULLETIN@NERUS.PFC.MIT.EDU. The body of the message must contain one of +the following commands: + + SEND ALL Sends all bulletin files. + SEND filename Sends the specified file. + BUGS Sends a list of the latest bug fixes. + HELP or INFO Sends a brief description of BULLETIN. + + +BUILDING MX_BULL.EXE +-------------------- +MX_BULL is written in VAX C and can be compiled by executing BUILD_MX_BULL.COM. + +MX_BULL must be linked with the BULLETIN object library, BULL.OLB. The +build procedure for MX_BULL expects the logical BULL_SOURCE to point to the +BULLETIN library. You must define this logical (or edit the .COM file) +before building MX_BULL. + + +INSTALLING MX_BULL +------------------ +To install MX_BULL, perform the following steps: + +1. Using MCP, define a path named BULLETIN as a SITE transport: + + MCP> DEFINE PATH "BULLETIN" SITE + +2. Using MCP, define a rewrite rule early in the list (this should actually + be done using CONFIG.MCP so that the order is correct): + + MCP> DEFINE REWRITE_RULE "<{folder}@BULLETIN>" "<{folder}@BULLETIN>" + +3. If you don't have a SITE transport already defined, simply copy + MX_BULL_SITE_DELIVER.COM to MX_EXE:SITE_DELIVER.COM. + + If you do have a SITE transport defined, you'll need to merge the MX_BULL + stuff into the existing MX_EXE:SITE_DELIVER.COM. + +4. Reset the MX routers by using MCP RESET/ALL, or shutting down MX and + restarting it. + +Once these steps have been completed, MX_BULL is set up to begin delivering +messages to BULLETIN. + + +ROUTING MESSAGES TO BULLETIN +---------------------------- +Messages are routed to BULLETIN folders by addressing mail to +MX%"folder@BULLETIN", where "folder" is the name of the target BULLETIN +folder. For example, the following commands would send a message from VMS +Mail to the BULLETIN folder GENERAL (on the local system): + + $ MAIL + MAIL> SEND + To: MX%"GENERAL@BULLETIN" + Subj: This is a test.... + ..... + +The message is sent to the MX router, which in turn sends it to the MX SITE +agent, since the @BULLETIN path was defined as a SITE path. + +To facilitate the automatic delivery of messages to BULLETIN folders, you +should set up forwarding addresses for each of the BULLETIN folders: + + MAIL> SET FORWARD/USER=GENERAL MX%"""GENERAL@BULLETIN""" + MAIL> SET FORWARD/USER=MX-LIST MX%"""MX-LIST@BULLETIN""" + +Mail addressed to GENERAL or MX-LIST will automatically be forwarded to +BULLETIN via MX_BULL. + +To subscribe to a Bitnet/Internet mailing list and have the messages delivered +to BULLETIN, use MX's MLFAKE to send a subscription request on behalf of the +BULLETIN folder. For example, the user to specify would be: + + MLFAKE/USER=MX-LIST .... + +(Alternatively, you could create a dummy account named MX-LIST (or whatever +the list name is) that exists only long enough to send the request via MAIL.) + +Once added to the lists, incoming mail addressed to MX-LIST will get forwarded +to MX%"MX-LIST@BULLETIN", which will invoke MX_BULL. For example, an incoming +message to my local BULLETIN folder would be addressed to: + + MX-LIST@WKUVX1.bitnet + +Since I have MX-LIST forwarded to MX%"MX-LIST@BULLETIN", the message is routed +to the BULLETIN folder. + +To try to illustrate the process, assume the node is WKUVX1.bitnet. We've +subscribed a fake local user, INFO-VAX, to the MX mailing list; mail forwarding +has been set up for INFO-VAX to send it to MX%"INFO-VAX@BULLETIN". When mail +arrives addressed to INFO-VAX@WKUVX1.BITNET, the MX Router passes the message +to the Local agent, which discovers that the mail is forwarded to +MX%"INFO-VAX@BULLETIN". The message is then sent back to the Router, which +finds that BULLETIN is defined as a SITE path, so the message is passed to +MX->SITE, which in turn calls MX_BULL. + + +MX_BULL ACCOUNTING AND DEBUGGING +-------------------------------- +MX_BULL accounting is enabled with the system logical MX_BULLETIN_ACCNTNG: + + $ DEFINE/SYS/EXEC MX_BULLETIN_ACCNTNG TRUE + +This will cause MX_BULL to create MX_SITE_DIR:MX_BULLETIN_ACC.DAT. The +logical MX_BULLETIN_ACC can be defined system-wide to change the name of the +file: + + $ DEFINE/SYS/EXEC MX_BULLETIN_ACC LOCALDISK:[DIR]MX_BULL.ACCOUNTING + +To generate debugging logs in MX_SITE_DIR:, define the system logical +MX_SITE_DEBUG. + + +ERRORS WRITING TO BULLETIN +-------------------------- +By default, MX_BULL_SITE_DELIVER.COM always returns success to the MX SITE +agent. This was done to avoid bouncing network mail back to a mailing list. +In order to be notified in case of problems writing the message to BULLETIN, +you can define a system logical MX_BULLETIN_POSTMASTER to be a local +username to receive failed MX_BULL transactions: + + $ DEFINE/SYS/EXEC MX_BULLETIN_POSTMASTER GOATHUNTER + +If BULLETIN returns an error, MX_BULL will forward the message (via the +callable VMS Mail interface) to GOATHUNTER. + + +BULLETIN AND "From:" ADDRESSES +------------------------------ +If you use the return address supplied by the MX SITE agent, the return address +for BULLETIN messages will look something like the following: + + From: MX%"@WKUVX1.BITNET:I-AMIGA@UBVM.BITNET" + +By default, MX_BULL_SITE_DELIVER.COM is set up to ignore the sender's address. +If you want to use the MX SITE-supplied address, simply modify the following +line in MX_BULL_SITE_DELIVER.COM: + + $ USE_SITE_FROM = 0 !Change to 1 to use MX sender's address + +If the sender's address is ignored (again, the default), MX_BULL will search +the RFC822 headers in the message for the "From:" line. It then pulls out +the sender's address in a format suitable for using the RESPOND command in +BULLETIN. This lets users easily RESPOND to the sender of a message, or +POST a message to the list itself. + +Note: MX_BULL just uses the address it's given. Some addresses are gatewayed +to death, leaving a bad address on the "From:" line. This frequently happens +with messages coming via UUCP through Internet to Bitnet, etc. + + +AUTHOR INFORMATION +------------------ +MX_BULL was written by: + + Hunter Goatley, VMS Systems Programmer, WKU + + E-mail: goathunter@wkuvx1.bitnet + Voice: 502-745-5251 + + U.S. Mail: Academic Computing, STH 226 + Western Kentucky University + Bowling Green, KY 42101 +$eod +$copy/log sys$input MX_BULL_SITE_DELIVER.COM +$deck +$! +$! SITE_DELIVER.COM for MX_BULL +$! +$! Author: Hunter Goatley, goathunter@wkuvx1.bitnet +$! Date: March 11, 1991 +$! +$! By default, MX_BULL will tell BULLETIN to search the RFC822 headers +$! in the message for a "Reply-to:" or "From:" line. If you want MX_BULL +$! to use the P3 as the "From:" line, simply set USE_SITE_FROM to 1. +$! +$ USE_SITE_FROM = 0 !Change to 1 to use P3 +$ mxbull :== $mx_exe:mx_bull.exe +$! +$ set noon +$ if f$trnlnm("SYS$SCRATCH").eqs."" then define SYS$SCRATCH MX_SITE_DIR: +$ if USE_SITE_FROM !Use P3 as "From:"? +$ then create mx_site_dir:sitesender.addr; !If so, write it out to a file +$ open/append tmp mx_site_dir:sitesender.addr; !... to make sure DCL +$ write tmp p3 !... doesn't mess it up +$ close tmp !... +$ mxbull 'p1' 'p2' mx_site_dir:sitesender.addr +$ delete/nolog mx_site_dir:sitesender.addr; +$ else mxbull 'p1' 'p2' !Just let BULLETIN find "From:" +$ endif +$ exit 1 !Always return success +$eod diff --git a/decus/vax91b/gce91b/net91b/pmdf.com b/decus/vax91b/gce91b/net91b/pmdf.com new file mode 100644 index 0000000..4bfb470 --- /dev/null +++ b/decus/vax91b/gce91b/net91b/pmdf.com @@ -0,0 +1,1029 @@ +$set nover +$copy/log sys$input BULLETIN_MASTER.PAS +$deck +%INCLUDE 'PMDF_ROOT:[SRC]ATTRIB.INC' +PROGRAM bulletin_master (output, outbound, + %INCLUDE 'PMDF_ROOT:[SRC]APFILES.INC', + %INCLUDE 'PMDF_ROOT:[SRC]MMFILES.INC', + %INCLUDE 'PMDF_ROOT:[SRC]QUFILES.INC'); + +(*******************************************************************) +(* *) +(* Authors: Ned Freed (ned@ymir.bitnet) *) +(* Mark London (mrl%mit.mfenet@nmfecc.arpa) *) +(* 8/18/88 *) +(* *) +(*******************************************************************) + + CONST + %INCLUDE 'PMDF_ROOT:[SRC]UTILCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]OSCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]APCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]MMCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]HECONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]LOGCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]SYCONST.INC' + + TYPE + %INCLUDE 'PMDF_ROOT:[SRC]UTILTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]OSTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]APTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]SYTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]MMTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]HETYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]LOGTYPE.INC' + + string = varying [alfa_size] of char; + + VAR + %INCLUDE 'PMDF_ROOT:[SRC]UTILVAR.INC' + %INCLUDE 'PMDF_ROOT:[SRC]OSVAR.INC' + %INCLUDE 'PMDF_ROOT:[SRC]APVAR.INC' + %INCLUDE 'PMDF_ROOT:[SRC]QUVAR.INC' + %INCLUDE 'PMDF_ROOT:[SRC]MMVAR.INC' + %INCLUDE 'PMDF_ROOT:[SRC]HEVAR.INC' + %INCLUDE 'PMDF_ROOT:[SRC]LOGVAR.INC' + + outbound : text; + + (* Place to store the channel we are servicing *) + mail_channel : mm_channel_ptr := nil; + + (* MM status control flag *) + + mm_status : (uninitialized, initialized, sending) := uninitialized; + + filename : vstring; + + (* Place to store the protocol that we are providing/servicing *) + protocol_name : varying [10] of char; + + %INCLUDE 'PMDF_ROOT:[SRC]UTILDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]OSDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]APDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]HEDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]LOGDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]MMDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]QUDEF.INC' + + (* Declare interface routines to BULLETIN *) + + procedure INIT_MESSAGE_ADD ( + in_folder : [class_s] packed array [l1..u1 : integer] of char; + in_from : [class_s] packed array [l2..u2 : integer] of char; + in_descrip : [class_s] packed array [l3..u3 : integer] of char; + var ier : boolean); extern; + + procedure WRITE_MESSAGE_LINE ( + in_line : [class_s] packed array [l1..u1 : integer] of char); extern; + + procedure FINISH_MESSAGE_ADD; extern; + + PROCEDURE warn_master (message : varying [len1] of char); + + BEGIN (* warn_master *) + writeln; + os_write_datetime (output); + writeln (message); + END; (* warn_master *) + + (* abort program. *) + + PROCEDURE abort_master (message : varying [len1] of char); + + BEGIN (* abort_master *) + warn_master (message); + halt; + END; (* abort_master *) + +(* activate_mm fires up the MM package and performs related startup chores. *) + +function activate_mm (is_master : boolean) : rp_replyval; + +var + mm_init_reply : rp_replyval; found : boolean; mail_chan_text : ch_chancode; + stat : integer; + +begin (* activate_mm *) + (* Set up the name of the protocol we are servicing/providing *) + stat := $TRNLOG (lognam := 'PMDF_PROTOCOL', + rslbuf := protocol_name.body, + rsllen := protocol_name.length); + if (not odd (stat)) or (stat = SS$_NOTRAN) then protocol_name := 'IN%'; + mm_status := initialized; + mm_init_reply := mm_init; + mail_chan_text := ' '; + stat := $TRNLOG (lognam := 'PMDF_CHANNEL', rslbuf := mail_chan_text); + if (not odd (stat)) or (stat = SS$_NOTRAN) then + mail_chan_text := 'l '; + if rp_isgood (mm_init_reply) then begin + mail_channel := mm_lookup_channel (mail_chan_text); + if mail_channel = nil then mail_channel := mm_local_channel; + end else mail_channel := mm_local_channel; + activate_mm := mm_init_reply; +end; (* activate_mm *) + + (* initialize outbound, mm_ and qu_ *) + + PROCEDURE init; + + VAR fnam : vstring; + i : integer; + + BEGIN (* init *) + os_jacket_access := true; + (* Initialize subroutine packages *) + IF rp_isbad (activate_mm (false)) THEN + abort_master ('Can''t initialize MM_ routines'); + IF rp_isbad (qu_init) THEN + abort_master ('Can''t initialize QU_ routines'); + fnam.length := 0; + IF NOT os_open_file (outbound, fnam, exclusive_read) THEN + abort_master ('Can''t open outbound file'); + END; (* init *) + + +procedure return_bad_messages (var bad_address : vstring); + +label + 100; + +var + line : vstring; + bigline : bigvstring; result : rp_bufstruct; + pmdfenvelopefrom : vstring; + temp_line : vstringlptr; + + procedure try_something (rp_error : integer; routine : string); + + begin (* try_something *) + if rp_isbad (rp_error) then begin + mm_wkill; mm_status := initialized; goto 100; + end; + end; (* try_something *) + +begin (* return_bad_messages *) + if mm_status = uninitialized then + try_something (activate_mm (false), 'mm_init'); + mm_status := sending; + try_something (mm_sbinit, 'mm_sbinit'); + initstring (line, 'postmaster@ ', 11); + catvstring (line, mm_local_channel^.official_hostname); + try_something (mm_winit (mail_channel^.chancode, line), 'mm_winit'); + initstring (line, + 'postmaster ', 10); + try_something (mm_wadr (mail_channel^.official_hostname, + line), 'mm_wadr'); + try_something (mm_rrply (result), 'mm_rrply'); + try_something (result.rp_val, 'mm_rrply structure return'); + try_something (mm_waend, 'mm_waend'); + initstring (line, 'From: PMDF Mail Server '); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'To: Postmaster ', 14); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'Subject: Undeliverable mail ', 27); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'Date: ', 6); + os_cnvtdate (line); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + line.length := 1; line.body[1] := chr (chr_lf); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'The message could not be delivered to: ', 38); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + line.length := 1; line.body[1] := chr (chr_lf); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'Addressee: ', 11); + catvstring (line, bad_address); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'Reason: No such bulletin folder. ', 32); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + line.length := 1; line.body[1] := chr (chr_lf); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, '----------------------------------------', 40); + catchar (line, chr (chr_lf)); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + try_something (qu_rkill, 'qu_rkill'); + try_something (qu_rinit (filename, pmdfenvelopefrom), 'qu_rinit'); + while rp_isgood (qu_radr (line)) do begin end; + while rp_isgood (qu_rtxt (bigline)) do + try_something (mm_bigwtxt (bigline), 'mm_wtxt'); + mm_status := initialized; + try_something (mm_wtend, 'mm_wtend'); + try_something (mm_rrply (result), 'mm_rrply'); + try_something (result.rp_val, 'mm_rrply structure return'); +100: +end; (* return_bad_messages *) + + (* submit messages to BULLETIN *) + + PROCEDURE dosubmit; + + VAR fromaddr, toaddr, tombox, name : vstring; + retval : rp_replyval; + line : bigvstring; + ier, done : boolean; + i : integer; + + BEGIN (* dosubmit *) + WHILE NOT eof (outbound) DO BEGIN + readvstring (outbound, filename, 0); + IF rp_isgood (qu_rinit (filename, fromaddr)) THEN BEGIN + done := false; + FOR i := 1 TO fromaddr.length DO + fromaddr.body[i] := upper_case (fromaddr.body[i]); + IF rp_isgood (qu_radr (toaddr)) THEN BEGIN + REPEAT + retval := qu_radr (name); + UNTIL rp_isbad (retval); + mm_parse_address (toaddr, name, tombox, TRUE, FALSE, 0); + FOR i := 1 TO tombox.length DO + tombox.body[i] := upper_case (tombox.body[i]); + INIT_MESSAGE_ADD (substr (tombox.body, 1, tombox.length), + protocol_name,' ', ier); +(* The parameter with 'IN%', causes bulletin to search for the From line: *) +(* substr (fromaddr.body, 1, fromaddr.length), *) + IF ier THEN BEGIN + WHILE rp_isgood (qu_rtxt (line)) DO BEGIN + IF line.length > 0 THEN line.length := pred (line.length); + WRITE_MESSAGE_LINE (substr (line.body, 1, line.length)); + END; (* while *) + FINISH_MESSAGE_ADD; + done := true; + END ELSE BEGIN + warn_master ('Error opening folder ' + + substr (tombox.body, 1, tombox.length)); + return_bad_messages(tombox); + done := true; + END; + END + ELSE warn_master ('Can''t read To: address in file ' + + substr (filename.body, 1, filename.length)); + if done then qu_rend else qu_rkill; + END + ELSE warn_master ('Can''t open queue file ' + + substr (filename.body, 1, filename.length)); + END; (* while *) + END; (* dosubmit *) + + BEGIN (* bulletin_master *) + init; + dosubmit; + mm_end (true); + qu_end; + END. (* bulletin_master *) +$eod +$copy/log sys$input BULLETIN_MASTER.PAS_V32 +$deck +%INCLUDE 'PMDF_ROOT:[SRC]ATTRIB.INC' +PROGRAM bulletin_master (%INCLUDE 'PMDF_ROOT:[SRC]APFILES.INC' + %INCLUDE 'PMDF_ROOT:[SRC]MMFILES.INC' + %INCLUDE 'PMDF_ROOT:[SRC]QUFILES.INC' + outbound); + +(*******************************************************************) +(* *) +(* Authors: Ned Freed (ned@ymir.claremont.edu) *) +(* Mark London (mrl@nerus.pfc.mit.edu) *) +(* 12/28/90 *) +(* *) +(*******************************************************************) + + CONST + %INCLUDE 'PMDF_ROOT:[SRC]UTILCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]OSCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]APCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]SYCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]HECONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]MMCONST.INC' + %INCLUDE 'PMDF_ROOT:[SRC]LOGCONST.INC' + + TYPE + %INCLUDE 'PMDF_ROOT:[SRC]UTILTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]OSTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]APTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]SYTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]HETYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]MMTYPE.INC' + %INCLUDE 'PMDF_ROOT:[SRC]LOGTYPE.INC' + + string = varying [alfa_size] of char; + + VAR +(* %INCLUDE 'PMDF_ROOT:[SRC]UTILVAR.INC' *) + %INCLUDE 'PMDF_ROOT:[SRC]OSVAR.INC' +(* %INCLUDE 'PMDF_ROOT:[SRC]APVAR.INC' *) +(* %INCLUDE 'PMDF_ROOT:[SRC]QUVAR.INC' *) + %INCLUDE 'PMDF_ROOT:[SRC]MMVAR.INC' +(* %INCLUDE 'PMDF_ROOT:[SRC]HEVAR.INC' *) +(* %INCLUDE 'PMDF_ROOT:[SRC]LOGVAR.INC' *) + + outbound : text; + fromaddr, filename : vstring; + bull_chan : mm_channel_ptr; + bull_chan_text : ch_chancode; + protocol_name : varying [10] of char; + + %INCLUDE 'PMDF_ROOT:[SRC]UTILDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]OSDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]APDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]HEDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]LOGDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]SYDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]MMDEF.INC' + %INCLUDE 'PMDF_ROOT:[SRC]QUDEF.INC' + + (* Declare interface routines to BULLETIN *) + + procedure INIT_MESSAGE_ADD ( + in_folder : [class_s] packed array [l1..u1 : integer] of char; + in_from : [class_s] packed array [l2..u2 : integer] of char; + in_descrip : [class_s] packed array [l3..u3 : integer] of char; + var ier : boolean); extern; + + procedure WRITE_MESSAGE_LINE ( + in_line : [class_s] packed array [l1..u1 : integer] of char); extern; + + procedure FINISH_MESSAGE_ADD; extern; + + PROCEDURE warn_master (message : varying [len1] of char); + + BEGIN (* warn_master *) + writeln (os_output_file^); + os_write_datetime (os_output_file^); + writeln (os_output_file^, message); + END; (* warn_master *) + + (* initialize outbound, mm_ and qu_ *) + + PROCEDURE init; + + VAR fnam : vstring; + i, stat : integer; + + BEGIN (* init *) + os_insure_open_output; + os_jacket_access := true; + (* Initialize subroutine packages *) + IF rp_isbad (mm_init) THEN + mm_abort_program (os_output_file^, + 'Can''t initialize MM_ ', 20, true); + IF rp_isbad (qu_init) THEN + mm_abort_program (os_output_file^, + 'Can''t initialize QU_ ', 20, false); + bull_chan := mm_my_channel (bull_chan_text); + (* Set up the name of the protocol we are servicing/providing *) + stat := $TRNLOG (lognam := 'PMDF_PROTOCOL', + rslbuf := protocol_name.body, + rsllen := protocol_name.length); + IF (not odd (stat)) OR (stat = SS$_NOTRAN) THEN protocol_name := 'IN%'; + fnam.length := 0; + IF NOT os_open_file (outbound, fnam, exclusive_read) THEN + mm_abort_program (os_output_file^, + 'Can''t open outbound file ', 24, false); + END; (* init *) + + PROCEDURE return_bad_messages (var bad_address : vstring); + + LABEL + 100; + + VAR + line, errorsto : vstring; + bigline : bigvstring; result : rp_bufstruct; + header : he_header; + i : integer; + + PROCEDURE try_something (rp_error : integer; routine : string); + + BEGIN (* try_something *) + IF rp_isbad (rp_error) THEN BEGIN + warn_master ('Routine ' + routine + ' failed while returning message.'); + mm_wkill; goto 100; + END; (* if *) + end; (* try_something *) + + BEGIN (* return_bad_messages *) + he_init_header (header); + try_something (mm_sbinit, 'mm_sbinit'); + initstring (line, 'postmaster@ ', 11); + catvstring (line, mm_local_channel^.official_hostname); + try_something (mm_winit (bull_chan_text, line), 'mm_winit'); + try_something (qu_rbtxt, 'qu_rbtxt'); + try_something (he_read_header (header, qu_rtxt), 'he_read_header'); + errorsto.length := 0; + IF header[he_errors_to] <> NIL THEN WITH header[he_errors_to]^ DO + IF ltext.length <= ALFA_SIZE THEN BEGIN + errorsto.length := ltext.length; + FOR i := 1 TO errorsto.length DO errorsto.body[i] := ltext.body[i]; + END; (* if *) + IF errorsto.length > 0 THEN BEGIN + try_something (mm_wadr (mm_local_channel^.official_hostname, errorsto), + 'mm_wadr'); + try_something (mm_rrply (result), 'mm_rrply'); + END + ELSE result.rp_val := RP_NO; + IF rp_isbad (result.rp_val) THEN BEGIN + copyvstring (errorsto, fromaddr); + try_something (mm_wadr (mm_local_channel^.official_hostname, + fromaddr), 'mm_wadr'); + try_something (mm_rrply (result), 'mm_rrply'); + END; (* if *) + IF bull_chan^.sendpost or rp_isbad (result.rp_val) THEN BEGIN + initstring (line, + 'postmaster ', 10); + try_something (mm_wadr (bull_chan^.official_hostname, line), 'mm_wadr'); + try_something (mm_rrply (result), 'mm_rrply'); + try_something (result.rp_val, 'mm_rrply structure return'); + END; (* if *) + try_something (mm_waend, 'mm_waend'); + initstring (line, 'From: PMDF Mail Server '); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'To: ', 4); + catvstring (line, errorsto); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'Subject: Undeliverable bulletin ', 31); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'Date: ', 6); + os_catdatetime (line); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + line.length := 1; line.body[1] := chr (chr_lf); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'The message could not be delivered to: ', 38); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + line.length := 1; line.body[1] := chr (chr_lf); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'Addressee: ', 11); + catvstring (line, bad_address); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, 'Reason: No such bulletin folder. ', 32); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + line.length := 1; line.body[1] := chr (chr_lf); + try_something (mm_wtxt (line), 'mm_wtxt'); + initstring (line, '----------------------------------------', 40); + catchar (line, chr (chr_lf)); + catchar (line, chr (chr_lf)); + try_something (mm_wtxt (line), 'mm_wtxt'); + try_something (he_write_header (header, mm_bigwtxt), 'he_write_header'); + line.length := 1; line.body[1] := chr (chr_lf); + try_something (mm_wtxt (line), 'mm_wtxt'); + WHILE rp_isgood (qu_rtxt (bigline)) DO + try_something (mm_bigwtxt (bigline), 'mm_wtxt'); + try_something (mm_wtend, 'mm_wtend'); + try_something (mm_rrply (result), 'mm_rrply'); + try_something (result.rp_val, 'mm_rrply structure return'); + 100: + END; (* return_bad_messages *) + + (* submit messages to BULLETIN *) + + PROCEDURE dosubmit; + + VAR toaddr, tombox, name : vstring; + retval : rp_replyval; + line : bigvstring; + ier, done : boolean; + i : integer; + chan_dummy : mm_channel_ptr; + + BEGIN (* dosubmit *) + WHILE NOT eof (outbound) DO BEGIN + readvstring (outbound, filename, 0); + IF rp_isgood (qu_rinit (filename, fromaddr)) THEN BEGIN + done := false; + IF rp_isgood (qu_radr (toaddr)) THEN BEGIN + REPEAT + retval := qu_radr (name); + UNTIL rp_isbad (retval); + chan_dummy := mm_parse_address (toaddr, name, tombox, + TRUE, FALSE, 0, 0); + FOR i := 1 TO tombox.length DO + tombox.body[i] := upper_case (tombox.body[i]); + INIT_MESSAGE_ADD (substr (tombox.body, 1, tombox.length), + protocol_name, ' ', ier); + IF ier THEN BEGIN + WHILE rp_isgood (qu_rtxt (line)) DO BEGIN + IF line.length > 0 THEN line.length := pred (line.length); + WRITE_MESSAGE_LINE (substr (line.body, 1, line.length)); + END; (* while *) + FINISH_MESSAGE_ADD; + done := true; + END + ELSE BEGIN + warn_master ('Error opening folder ' + + substr (tombox.body, 1, tombox.length)); + return_bad_messages (tombox); + done := true; + END; + END + ELSE warn_master ('Can''t read To: address in file ' + + substr (filename.body, 1, filename.length)); + IF done THEN qu_rend ELSE qu_rkill (true); + END + ELSE warn_master ('Can''t open queue file ' + + substr (filename.body, 1, filename.length)); + END; (* while *) + END; (* dosubmit *) + + BEGIN (* bulletin_master *) + init; + dosubmit; + mm_end (true); + qu_end; + END. (* bulletin_master *) +$eod +$copy/log sys$input MASTER.COM +$deck +$ ! MASTER.COM - Initiate delivery of messages queued on a channel +$ ! +$ ! Modification history and parameter definitions are at the end of this file. +$ ! +$ set noon +$ ! +$ ! Clean up and set up channel name, if on hold just exit +$ ! +$ channel_name = f$edit(p1, "COLLAPSE,LOWERCASE") +$ hold_list = "," + f$edit(f$logical("PMDF_HOLD"), "COLLAPSE,LOWERCASE") + "," +$ if f$locate("," + channel_name + ",", hold_list) .lt. - + f$length(hold_list) then exit +$ define/process pmdf_channel "''channel_name'" +$ ! +$ ! Save state information, set up environment properly +$ ! +$ save_directory = f$environment("DEFAULT") +$ set default pmdf_root:[queue] +$ save_protection = f$environment("PROTECTION") +$ set protection=(s:rwed,o:rwed,g,w)/default +$ save_privileges = f$setprv("NOSHARE") +$ ! +$ if f$logical("PMDF_DEBUG") .eqs. "" then on control_y then goto out +$ ! +$ ! Create listing of messages queued on this channel. +$ ! +$ if p3 .eqs. "" then p3 = "1-JAN-1970" +$ dirlst_file = "pmdf_root:[log]" + channel_name + "_master_dirlst_" + - + F$GETJPI ("", "PID") + ".tmp" +$ define/process outbound 'dirlst_file' +$ directory/noheader/notrailer/column=1/since="''p3'"/output='dirlst_file' - + pmdf_root:[queue]'channel_name'_*.%%;* +$ ! +$ ! Determine whether or not connection should really be made +$ ! +$ if p2 .nes. "POLL" .and. - + f$file_attributes(dirlst_file, "ALQ") .eq. 0 then goto out1 +$ ! +$ ! Handle various channels specially +$ ! +$ if channel_name .eqs. "l" then goto local_channel +$ if channel_name .eqs. "d" then goto DECnet_compatibility_channel +$ if channel_name .eqs. "directory" then goto dir_channel +$ if f$extract(0,5,channel_name) .eqs. "anje_" then goto BITNET_channel +$ if f$extract(0,4,channel_name) .eqs. "bit_" then goto BITNET_channel +$ if f$extract(0,5,channel_name) .eqs. "bull_" then goto BULLETIN_channel +$ if f$extract(0,3,channel_name) .eqs. "cn_" then goto CN_channel +$ if f$extract(0,5,channel_name) .eqs. "ctcp_" then goto CTCP_channel +$ if f$extract(0,3,channel_name) .eqs. "dn_" then goto DECnet_channel +$ if f$extract(0,6,channel_name) .eqs. "dsmtp_" then goto DSMTP_channel +$ if f$extract(0,5,channel_name) .eqs. "etcp_" then goto ETCP_channel +$ if f$extract(0,5,channel_name) .eqs. "ftcp_" then goto FTCP_channel +$ if f$extract(0,4,channel_name) .eqs. "ker_" then goto KER_channel +$ if f$extract(0,5,channel_name) .eqs. "mail_" then goto MAIL_channel +$ if f$extract(0,5,channel_name) .eqs. "mtcp_" then goto MTCP_channel +$ if f$extract(0,5,channel_name) .eqs. "px25_" then goto PX25_channel +$ if f$extract(0,4,channel_name) .eqs. "tcp_" then goto TCP_channel +$ if f$extract(0,5,channel_name) .eqs. "test_" then goto TEST_channel +$ if f$extract(0,5,channel_name) .eqs. "uucp_" then goto UUCP_channel +$ if f$extract(0,5,channel_name) .eqs. "wtcp_" then goto WTCP_channel +$ if f$extract(0,6,channel_name) .eqs. "xsmtp_" then goto XSMTP_channel +$ ! +$ ! This must be a PhoneNet channel (the default); set up and use MASTER +$ ! Read the list of valid connection types for each channel. +$ ! +$ cnt = f$integer("0") +$ open/read/error=regular_master pmdf_data pmdf_root:[table]phone_list.dat +$ list_loop: +$ read/end=eof_list pmdf_data line +$ ! Ignore comment lines. +$ if (f$extract (0, 1, line) .eqs. "!") then - + goto list_loop +$ line = f$edit (line, "COMPRESS,LOWERCASE") +$ ! Get the channel name from the line read. +$ chan = f$extract (0, f$locate(" ", line), line) +$ if (chan .nes. channel_name) then - +$ goto list_loop +$ ! Get the connection name +$ name = f$edit(f$extract(f$locate(" ",line),255,line),"COLLAPSE") +$ ! If none, then ignore the line +$ if name .eqs. "" then - + goto list_loop +$ ! Found at least one to try. +$ cnt = cnt + 1 +$ @pmdf_root:[exe]all_master.com 'name' +$ define PMDF_DEVICE TT +$ ! +$ ! Define other logical names +$ ! +$ define/user script pmdf_root:[table.'channel_name']'name'_script. +$ define/user ph_current_message pmdf_root:[log]'channel_name'_master_curmsg.tmp +$ define/user option_file pmdf_root:[table]'channel_name'_option. +$ define/user di_transcript pmdf_root:[log]di_'channel_name'_master.trn +$ define/user ph_logfile pmdf_root:[log]ph_'channel_name'_master.log +$ define/user di_errfile pmdf_root:[log]di_'channel_name'_master.log +$ ! +$ ! This check attempts to verify that we are in fact the owner process of +$ ! the device, TT. If the device is sharable, then we ignore the +$ ! owner. +$ ! +$ if (f$getdvi("TT","pid") .nes. f$getjpi(0,"pid")) .and. - + (f$getdvi("TT","shr") .eqs. "FALSE") then - + goto list_loop +$ ! +$ ! Run master to deliver the mail +$ ! +$ run pmdf_root:[exe]master +$ exit_stat = $status +$ ! +$ ! Activate optional cleanup script to reset terminal/modem +$ ! +$ if f$search("pmdf_root:[exe]''name'_cleanup.com") .nes. "" then - + @pmdf_root:[exe]'name'_cleanup.com 'exit_stat' +$ deallocate TT +$ deassign TT +$ deassign PMDF_DEVICE +$ ! +$ ! If master does not exit normally, then try a different connection. +$ ! +$ if exit_stat .ne. 1 then goto list_loop +$ eof_list: +$ close pmdf_data +$ ! +$ ! If we found at least one connection type for this channel, then skip +$ ! the attempt to use the conventional mechanism. +$ ! +$ if cnt .gt. 0 then goto out_phonenet +$ ! +$ regular_master: +$ @pmdf_root:[exe]'channel_name'_master.com +$ define PMDF_DEVICE TT +$ ! +$ ! Define logical names +$ ! +$ define/user script pmdf_root:[table]'channel_name'_script. +$ define/user ph_current_message pmdf_root:[log]'channel_name'_master_curmsg.tmp +$ define/user option_file pmdf_root:[table]'channel_name'_option. +$ define/user di_transcript pmdf_root:[log]di_'channel_name'_master.trn +$ define/user ph_logfile pmdf_root:[log]ph_'channel_name'_master.log +$ define/user di_errfile pmdf_root:[log]di_'channel_name'_master.log +$ ! +$ run pmdf_root:[exe]master +$ exit_stat = $status +$ ! +$ ! Activate optional cleanup script to reset terminal/modem +$ ! +$ if f$search("''channel_name'_cleanup.com") .nes. "" then - + @pmdf_root:[exe]'channel_name'_cleanup.com 'exit_stat' +$ deallocate TT +$ deassign TT +$ deassign PMDF_DEVICE +$ ! +$ out_phonenet: +$ if P4 .eqs. "POST" then wait 00:00:30 +$ goto out1 +$ ! +$ ! Directory channel +$ ! +$ dir_channel: +$ ! +$ run pmdf_root:[exe]dir_master +$ goto out1 +$ ! +$ ! This is a DECnet channel; set up and use DN_MASTER +$ ! +$ DECnet_channel: +$ ! +$ ! Define other logical names +$ ! +$ node_name = f$edit(channel_name - "dn_", "UPCASE") +$ define/user ph_current_message pmdf_root:[log]'channel_name'_master_curmsg.tmp +$ define/user option_file pmdf_root:[table]'channel_name'_option. +$ define/user di_transcript pmdf_root:[log]di_'channel_name'_master.trn +$ define/user ph_logfile pmdf_root:[log]ph_'channel_name'_master.log +$ define/user di_errfile pmdf_root:[log]di_'channel_name'_master.log +$ define/user pmdf_node "''node_name'::""PMDF=""" +$ ! +$ run pmdf_root:[exe]dn_master +$ goto out1 +$ ! +$ ! This is a BITNET channel; use BN_MASTER +$ ! +$ BITNET_channel: +$ ! +$ if channel_name .eqs. "bit_gateway" then goto BITNET_gateway +$ run pmdf_root:[exe]bn_master +$ goto out1 +$ ! +$ ! This is the BITNET gateway channel; use BN_GATEWAY +$ ! +$ BITNET_gateway: +$ ! +$ run pmdf_root:[exe]bn_gateway +$ goto out1 +$ ! +$ ! This is a BULLETIN channel; use BULLETIN_MASTER +$ ! +$ BULLETIN_channel: +$ ! +$ run pmdf_root:[exe]bulletin_master +$ goto out1 +$ ! +$ ! This is a Tektronix TCP channel; use TCP_MASTER +$ ! +$ TCP_channel: +$ ! +$ run pmdf_root:[exe]tcp_master +$ goto out1 +$ ! +$ ! This is a CMU/Tektronix TCP channel; use CTCP_MASTER +$ ! +$ CTCP_channel: +$ ! +$ run pmdf_root:[exe]ctcp_master +$ goto out1 +$ ! +$ ! This is a Wollongong TCP channel; use WTCP_MASTER +$ ! +$ WTCP_channel: +$ ! +$ ! Define other logical names +$ ! +$ run pmdf_root:[exe]wtcp_master +$ goto out1 +$ ! +$ ! This is a MultiNet TCP channel; use MTCP_MASTER +$ ! +$ MTCP_channel: +$ ! +$ run pmdf_root:[exe]mtcp_master +$ goto out1 +$ ! +$ ! This is a Excelan TCP channel; use ETCP_MASTER +$ ! +$ ETCP_channel: +$ ! +$ run pmdf_root:[exe]etcp_master +$ goto out1 +$ ! +$ ! This is an NRC Fusion TCP channel; use FTCP_MASTER +$ ! +$ FTCP_channel: +$ ! +$ run pmdf_root:[exe]ftcp_master +$ goto out1 +$ ! +$ CN_channel: +$ ! +$ ! Define other logical names +$ ! +$ define/user script pmdf_root:[table]'channel_name'_script. +$ ! following may vary: should point to cnio's group +$ define/table=lnm$process_directory lnm$temporary_mailbox lnm$group_000277 +$ ! +$ run/nodeb'p5' pmdf_root:[exe]cn_smtp_master +$ goto out1 +$ ! +$ KER_channel: +$ ! +$ ! kermit protocol is slave only. If we get here there has been a mistake. +$ ! however we will just exit and no harm done. +$ goto out1 +$ ! +$ ! This is a PhoneNet X25 channel; set up and use PX25_MASTER +$ ! +$ PX25_channel: +$ ! +$ ! Define other logical names +$ ! +$ define/user ph_current_message pmdf_root:[log]'channel_name'_master_curmsg.tmp +$ define/user option_file pmdf_root:[table]'channel_name'_option. +$ define/user di_transcript pmdf_root:[log]'channel_name'_di_master.trn +$ define/user ph_logfile pmdf_root:[log]'channel_name'_ph_master.log +$ define/user di_errfile pmdf_root:[log]'channel_name'_di_master.log +$ ! +$ run pmdf_root:[exe]PX25_master +$ goto out1 +$ ! +$ ! This is a DEC/Shell channel; set up and use UUCP_MASTER +$ ! +$ UUCP_channel: +$ ! +$ ! Define other logical names +$ ! +$ uucp_to_host = channel_name - "uucp_" +$ define/user uucp_to_host "''uucp_to_host'" +$ define/user uucp_current_message - + pmdf_root:[log]'channel_name'_master_curmsg.tmp +$ define/user uucp_logfile pmdf_root:[log]'channel_name'_master.logfile +$ ! +$ run pmdf_root:[exe]UUCP_master +$ uupoll = "$shell$:[usr.lib.uucp]uupoll" +$ uupoll 'uucp_to_host' +$ goto out1 +$ ! +$ ! This is a X.25 SMTP channel; set up and use XSMTP_MASTER +$ ! +$ XSMTP_channel: +$ ! +$ run pmdf_root:[exe]xsmtp_master +$ goto out1 +$ ! +$ ! This is a DECNET SMTP channel; set up and use DSMTP_MASTER +$ ! +$ DSMTP_channel: +$ ! +$ run pmdf_root:[exe]dsmtp_master +$ goto out1 +$ ! +$ ! Handle delivery on the local channel, MAIL_ channels, and +$ ! the DECnet compatibility channel +$ ! +$ MAIL_channel: +$ local_channel: +$ DECnet_compatibility_channel: +$ open/read queue_file 'dirlst_file' +$ local_loop: +$ read/end=exit_local_loop/error=exit_local_loop queue_file file_to_process +$ priv_list = f$setprv("SYSPRV, DETACH") +$ mail/protocol=pmdf_mailshr 'file_to_process' +$ priv_list = f$setprv(priv_list) +$ goto local_loop +$ ! +$ exit_local_loop: +$ close queue_file +$ goto out1 +$ ! +$ ! This is a SMTP test channel, use TEST_SMTP_MASTER +$ ! +$ TEST_channel: +$ ! +$ ! Typically some form of redirection is needed here... +$ deassign sys$input +$ run pmdf_root:[exe]test_smtp_master +$ goto out1 +$ ! +$ out1: +$ delete 'dirlst_file';* +$ ! +$ ! Common exit point - clean up things first +$ ! +$ out: +$ if f$logical("OUTBOUND") .nes. "" then deassign/process outbound +$ if f$logical("PMDF_CHANNEL") .nes. "" then deassign/process pmdf_channel +$ if f$logical("PMDF_DATA") .nes. "" then close pmdf_data +$ if f$logical("PMDF_DEVICE") .eqs. "" then goto restore +$ deallocate TT +$ deassign TT +$ deassign PMDF_DEVICE +$ restore: +$ ! +$ ! Restore saved stuff +$ ! +$ set protection=('save_protection')/default +$ set default 'save_directory' +$ set process/priv=('save_privileges') +$ ! +$ exit +$ ! +$ ! Modification history: +$ ! +$ ! This version by Ned Freed, 20-Jul-1986 +$ ! +$ ! Modified by Gregg Wonderly to allow multiple connections for each channel +$ ! 10-Oct-1986. +$ ! Some additions by Ned Freed 30-Oct-86. +$ ! Added CMU/Tektronix TCP channel (CTCP) /Kevin Carosso 6-Mar-1987 +$ ! Added Multinet TCP channel (MTCP) /Ned Freed 10-Mar-1987 +$ ! Added directory save/restore /Ned Freed 1-Jun-1987 +$ ! Added Excelan TCP channel (ETCP) /Ned Freed 9-Jul-1987 +$ ! Added MAIL, CNIO, KERMIT channel /Bob Smart 4-Jul-1987 +$ ! Added Warwick Jackson's PhoneNet X25 support /Ned Freed 5-Sep-87 +$ ! Added X25 SMTP channel SX25_ /Goeran Bengtsson, Mats Sundvall 24-Jul-87 +$ ! Added NRC Fusion TCP channel (FTCP) /Kevin Carosso 12-Jan-1988 +$ ! Added a variant of Randy McGee's code to put a list of channels on hold +$ ! /Ned Freed 9-Feb-1988 +$ ! Made this procedure save and restore a little more state information +$ ! than it used to, including default protection and privileges. Also +$ ! moved a bunch of the logical name assignments around to eliminate +$ ! redundant code all over the place. /Ned Freed 10-Feb-1988 +$ ! Modified to allow P3 date/time paramter. /Ned Freed 23-Feb-1988 +$ ! Added support for Dennis Boylan's UUCP channel. /Ned Freed 28-Mar-1988 +$ ! Added Robert Smart's directory channel. /Ned Freed 21-Apr-1988 +$ ! Added support for Warwick Jackson's SMTP over X.25 and SMTP over +$ ! DECnet channels. /Ned Freed 26-May-1988 +$ ! Added P4 and P5 parameters. /Ned Freed 10-Jun-1988 +$ ! Added code to call the TEST_SMTP_MASTER for testing. /Ned Freed 1-Jul-1988 +$ ! Added preliminary support for ANJE. /Ned Freed 7-Jul-1988 +$ ! Removed extra dispatch for WTCP_ channel. /Ned Freed 3-Sep-1988 +$ ! Added dispatch for BULL_ channel. /Ned Freed 28-Nov-1988 +$ ! Cleaned up error recovered and emergency exit -- close PHONE_LIST.DAT +$ ! file when aborting. /Ned Freed 13-Dec-1988 +$ ! Additional error recovery cleanup -- use PMDF_DEVICE instead of TT to +$ ! allow deallocation on an abort. /Ned Freed 14-Dec-1988 +$ ! +$ ! Parameters: +$ ! +$ ! P1 - Name of the channel whose messages are to be delivered. +$ ! P2 - Activity type. If P2 .eqs. "POLL", establish the connection +$ ! unconditionally, otherwise only establish the connection if +$ ! messages are waiting in the queue. +$ ! P3 - Earliest possible date/time for message(s). Messages older than +$ ! this time are not processed. +$ ! P4 - Environment. P4 .eqs. "POST" if MASTER is being called from the +$ ! POST.COM procedure or some other procedure that invokes MASTER +$ ! more than once. This parameter is used to insert delays before +$ ! returning if hardware needs time to reset. +$ ! P5 - Parameter reserved for channel-specific uses. +$eod +$copy/log sys$input PMDF.TXT +$deck +This describes the procedure necessary to use BULLETIN with PMDF. You must +be using at least PMDF V3.1. If using V3.2 you will instead have to use +BULLETIN_MASTER.PAS_V32. V3.2 does come with it's own BULLETIN_MASTER.PAS, but +there is a small bug in it. + +BULLETIN_MASTER.PAS and MASTER.COM are the files you need to run a BULLETIN +channel. Put BULLETIN_MASTER.PAS in a subdirectory of PMDF_ROOT:[SRC] (I use +the directory PMDF_ROOT:[SRC.BULLETIN]). Compile it there and then link it as +follows. This might result in undefined reference errors. You can ignore them, +as these are routines that are used for connecting to USENET NEWS, and are not +used by the BULLETIN_MASTER executable. + +For V3.1: + + LINK /EXE=PMDF_ROOT:[EXE]BULLETIN_MASTER - + BULLETIN_MASTER,[EXE]PMDFLIB/LIB,BULL_SOURCE:BULL/LIB, - + PMDF_ROOT:[EXE]VAXC/OPT + +For V3.2: + + LINK /EXE=PMDF_ROOT:[EXE]BULLETIN_MASTER - + BULL_DIR:BULLETIN_MASTER,PMDF_ROOT:[EXE]PMDFSHR_LINK.OPT/OPT, - + [EXE]IDENT.OPT/OPT,BULL_SOURCE:BULL.OLB/LIB,PMDF_ROOT:[EXE]VAXC/OPT + +If you need to, put the new MASTER.COM in PMDF_ROOT:[EXE]. NOTE: Check your +MASTER.COM, as the latest version of PMDF contains the code necessary to check +for bulletin mail. However, it will not necessary have the latest copy of +BULLETIN_MASTER.PAS. + +You then need a channel definition like the following in your configuration +file PMDF.CNF: + + bull_local single logging + BULLETIN-DAEMON + +And a rewrite rule of the form: + + BULLETIN $U%BULLETIN@BULLETIN-DAEMON + +Then you put an alias in your ALIASES. file for each mailing list you want to +process this way. I have the following: + + info-vax: info-vax@bulletin + tex-hax: tex-hax@bulletin + xmailer-list: xmailer@bulletin + mail-l: mail-l@bulletin + jnet-l: jnet-l@bulletin + policy-l: policy-l@bulletin + future-l: future-l@bulletin + mon-l: mon-l@bulletin + ug-l: ug-l@bulletin + +Then mail sent to info-vax@localhost will be routed to a folder called +info-vax. In general, an alias of the form + + a : b@bulletin + +will route mail sent to a@localhost to folder b in BULLETIN. + +NOTE: If you have BBOARD set for a folder that you convert to be delivered +directly to PMDF, remember to do a SET NOBBOARD for that folders (unless +using the LISTSERV option. See HELP SET BBOARD LISTSERV for more info). After +doing so, restart BULLCP using BULLETIN/START. +$eod -- GitLab