PROGRAM REMOTESYMB
C
C	REMOTESYMB -- Remote print symbiont
C
C	Version V01.02
C
C	Written: 24-Sep-1986 by John Osudar
C
C	Modification history:
C
C	1.01 26-Sep-1986 Fixed miscellaneous bugs in initial implementation
C	1.02 14-Apr-1987 Added code to split large buffers into smaller 
C			 records; added error checking on write operations
C
C	This is a "user-modified print symbiont" in which the standard VMS V4
C	print symbiont has its output routine replaced by one that writes the
C	output to a spooled (or dedicated) device across DECnet.
C
C===============================================================================
C
C	This is the main program, which sets things up for the user-modified
C	symbiont as dictated by the standard VMS shareable print symbiont.
C
C	First, define privilege symbols and symbiont symbols.
C
        INCLUDE '($PRVDEF)'
	INCLUDE 'SMBDEF.INC'
	INCLUDE 'PSMDEF.INC'
C
C	The remote output routine is external.
C
	EXTERNAL REMOTE_OUTPUT
C
C	Keep a list of work area ID's vs. output LUNs in common
C
	INTEGER*4 WRKIDS(16)
	INTEGER*2 LUN(16)
	COMMON /LUNCOM/WRKIDS,LUN
	DATA LUN/16*0/
C
C	The null descriptor and a work area descriptor
C
	INTEGER*4 NULLDESCR(2),WORKDESCR(2)
	COMMON /DSCS/NULLDESCR,WORKDESCR
	DATA NULLDESCR/0,0/,WORKDESCR/256,0/
C
C	Process privilege mask; since we are a symbiont, we get started with
C	only (!) SETPRV, and we have to set what we want.  We want NETMBX.
C
        INTEGER*4 PRIVILEGES(2)
	INTEGER*4 PRIVS
	PARAMETER (PRIVS=PRV$M_NETMBX)
        DATA PRIVILEGES/PRIVS,0/
C
C	Provide a "junk" byte so the null descriptor points to something.
C
	CHARACTER*1 JUNK
	DATA JUNK/' '/
C
C	Storage for the timeout clunks value
C
	INTEGER*4 DELAYTIME(2)
	COMMON /TIMER/DELAYTIME
C
C	"Function not supported" is not defined in the INC files, so reference
C	it as an external symbol, and provide a variable in common to get its
C	value.
C
	EXTERNAL PSM$_FUNNOTSUP
	INTEGER*4 FUNNOTSUP
	COMMON /PSMEXT/FUNNOTSUP
C
C===============================================================================
C
C	Start of code:
C
C	First, get the value of the "function not supported" symbol.
C
	FUNNOTSUP=%LOC(PSM$_FUNNOTSUP)
C
C	Set up the timeout value.  Ten seconds without any activity 
C	sounds reasonable.
C
	CALL SYS$BINTIM('0 00:00:10.00',DELAYTIME)
C
C	Set up the null descriptor address portion.
C
	NULLDESCR(2)=%LOC(JUNK)
C
C	Give ourselves NETMBX privilege.
C
	CALL SYS$SETPRV(%VAL(1),%REF(PRIVILEGES),%VAL(1),)
1	FORMAT(A)
C
C	Tell the shareable symbiont to replace its output routine with
C	our REMOTE_OUTPUT routine.
C
	CALL PSM$REPLACE(%REF(PSM$K_OUTPUT),REMOTE_OUTPUT)
c[
	open(unit=13,name='sys$manager:remotesymb.log',type='new',
	1 carriagecontrol='list',recordsize=255)
c]
C
C	Start up the symbiont, allow up to 16 streams, provide for a buffer 
C	size of 255 and a work area of 256 bytes per stream.
C
	CALL PSM$PRINT(%REF(16),%REF(255),%REF(256))
C
C	If PSM$PRINT ever returns, exit with a success status.
C
	CALL SYS$EXIT(%VAL(1))
	END
C
C	This is the remote output routine.  Arguments are dictated by the
C	shareable symbiont code.  In actual fact, since the "FUNCDESC"
C	argument can be optional, this routine just checks the address of
C	that argument and replaces it with the null string descriptor if the
C	argument is not present.  VAX Fortran makes this necessary because it
C	tries to do some operations on the descriptor if the argument passed
C	is a CHARACTER*x -- thus, the descriptor must be there.
C
	INTEGER*4 FUNCTION REMOTE_OUTPUT(REQID,WORKAREA,FUNC,FUNCDESC,FUNCARG)
	INTEGER*4 REQID,WORKAREA,FUNC,FUNCDESC,FUNCARG
	INTEGER*4 NULLDESCR(2),WORKDESCR(2)
	COMMON /DSCS/NULLDESCR,WORKDESCR
C
C	REMOUT is the real output routine.
C
	INTEGER*4 REMOUT
C
C	Set up the work area descriptor to include the address of the work
C	area.
C
	WORKDESCR(2)=%LOC(WORKAREA)
C
C	See if "FUNCDESC" is null, and if it is, replace it with the null
C	string descriptor.  Call the real output routine with the modified
C	arguments, and return the status that it returns.
C
	IF(%LOC(FUNCDESC).EQ.0)THEN
	   REMOTE_OUTPUT=REMOUT(REQID,WORKDESCR,FUNC,NULLDESCR,FUNCARG)
	ELSE
	   REMOTE_OUTPUT=REMOUT(REQID,WORKDESCR,FUNC,FUNCDESC,FUNCARG)
	ENDIF
	RETURN
	END
C
C	This is REALLY the real remote output routine.  The work area argument
C	is now a string descriptor, and the FUNCDESC argument is never missing.
C
	INTEGER*4 FUNCTION REMOUT(REQID,WORKAREA,FUNC,FUNCDESC,FUNCARG)
C
C	Define symbiont symbols
C
	INCLUDE 'SMBDEF.INC'
	INCLUDE 'PSMDEF.INC'
C
C	Request ID is a longword
C
	INTEGER*4 REQID
C
C	Work area is a character string
C
	CHARACTER*(*) WORKAREA
C
C	Function is a longword
C
	INTEGER*4 FUNC
C
C	Function parameter descriptor is a character string (which may be null)
C
	CHARACTER*(*) FUNCDESC
C
C	Function argument is a longword
C
	INTEGER*4 FUNCARG
C
C	Define local variables
C
	INTEGER*2 I,L,LL,IP
	INTEGER*4 WRKID
C
C	Table of work area ID's vs. LUNs
C
	INTEGER*4 WRKIDS(16)
	INTEGER*2 LUN(16)
	COMMON /LUNCOM/WRKIDS,LUN
C
C	"Function not supported" status value
C
	INTEGER*4 FUNNOTSUP
	COMMON /PSMEXT/FUNNOTSUP
C
C===============================================================================
C
C	Start of code:
C
C	Get address of work area, which is the "work area ID".
C
	WRKID=%LOC(WORKAREA)
c[
	write(13,19870,err=19880)wrkid
19870	format('wrkid = ',z8.8)
19880	continue
c]
C
C	Cancel the timer on that ID.
C
	CALL CANCEL_TIMER(WRKID)
C
C	Set default status to success
C
	REMOUT=1
C
C	Determine the requested function, and execute it.
C
	IF(FUNC.EQ.PSM$K_OPEN)THEN
C
C	Function is OPEN:  create a full DECnet remote filename in the
C	work area, and open it for writing.
C
	   LL=LEN(FUNCDESC)
c[
	write(13,19871,err=19881)ll,funcdesc,ichar(workarea(1:1)),
	1 ichar(workarea(2:2))
19871	format('OPEN'/'ll = ',i3/'funcdesc = "',a,'"'/'workarea(1) = ',i4/
	1 'workarea(2) = ',i4)
19881	continue
c]
C
C	Verify that the FUNCDESC argument is not null.
C
c[
	if(ll.eq.0)write(13,19879,err=19889)'FUNCDESC is zero -- aborting'
c]
	   IF(LL.LE.0)GOTO90
C
C	Replace the string "__" within the name by the double-colon that
C	separates a DECnet nodename from the rest of the name.
C
	   I=INDEX(FUNCDESC(1:LL),'__')
	   IF(I.NE.0)FUNCDESC(I:I+1)='::'
C
C	Copy the name to the work area.
C
	   WORKAREA(3:LL+2)=FUNCDESC(1:LL)
C
C	If the name ends with a colon, there must be no filename; append one.
C
	   IF(FUNCDESC(LL:LL).EQ.':')THEN
	      WORKAREA(LL+3:LL+12)='REMOTE.OUT'
	      LL=LL+10
	   ENDIF
C
C	Put in the length for future reference, and indicate no LUN open.
C
	   WORKAREA(1:1)=CHAR(0)
	   WORKAREA(2:2)=CHAR(LL)
C
C	Return the LOWERCASE status and success.
C
	   FUNCARG=SMBMSG$M_LOWERCASE
	   REMOUT=1
	ELSE IF(FUNC.EQ.PSM$K_START_TASK)THEN
c[
	write(13,19872,err=19882)
19872	format('START TASK')
19882	continue
c]
C
C	On a START TASK request, see if we have a LUN open for this work
C	area ID, and if so, use it.
C
	   DO I=1,16
	      IF(WRKID.EQ.WRKIDS(I))THEN
	         IF(LUN(I).GT.0)THEN
	            L=LUN(I)
	         ELSE
C
C	If work area ID found, but no LUN open, open one and save the number.
C
	            L=I+10
	            LL=ICHAR(WORKAREA(2:2))
c[
	write(13,19873,err=19883)l,ll,workarea(3:ll+2)
19873	format('opening lun ',i2,' ll = ',i3/'name = "',a,'"')
19883	continue
c]
	            OPEN(UNIT=L,NAME=WORKAREA(3:LL+2),TYPE='NEW',
	1            CARRIAGECONTROL='NONE',RECORDSIZE=255,ERR=9)
	            LUN(I)=L
	         ENDIF
	         GOTO1
	      ENDIF
	   ENDDO
C
C	If the work area ID is not known, find a free slot in the table and
C	fill it with the work area ID, and set up a LUN for it.
C
	   DO I=1,16
	      IF(LUN(I).EQ.0)THEN
	         WRKIDS(I)=WRKID
	         L=I+10
	         LL=ICHAR(WORKAREA(2:2))
c[
	write(13,19873,err=19893)l,ll,workarea(3:ll+2)
19893	continue
c]
	         OPEN(UNIT=L,NAME=WORKAREA(3:LL+2),TYPE='NEW',
	1         CARRIAGECONTROL='NONE',RECORDSIZE=255,ERR=9)
	         LUN(I)=L
	         GOTO1
	      ENDIF
	   ENDDO
C
C	If no free slots available, die a horrible death.
C
9	   CONTINUE
c[
	write(13,19879,err=19889)'open failed'
c]
	   GOTO90
C
C	If we succeeded in getting a LUN, fill it into the work area.
C
1	   WORKAREA(1:1)=CHAR(L)
	   REMOUT=1
	ELSE IF(FUNC.EQ.PSM$K_WRITE.OR.
	1 FUNC.EQ.PSM$K_WRITE_NOFORMAT)THEN
C
C	Function WRITE or WRITE NOFORMAT:
C
C	The FUNCDESC argument is the buffer to be written.  Get its length.
C	If not greater than zero, die.
C
	   LL=LEN(FUNCDESC)
c[
	write(13,19874,err=19884)ll
19874	format('WRITE with ll = ',i3)
19884	continue
c]
	   IF(LL.LE.0)GOTO99
C
C	Get the LUN to which this work area sends its output.  If that LUN
C	is not defined, die.
C
	   L=ICHAR(WORKAREA(1:1))
c[
	if(l.eq.0)write(13,19879,err=19889)'write lun is zero -- aborting'
c]
	   IF(L.EQ.0)GOTO90
C
C	Break up the buffer into 255-byte pieces, if necessary, and write it
C	to the specified LUN.
C
	   IP=0
14	   IF(LL-IP.GT.255)THEN
c[
	write(13,19875,err=19885)ip+1,ip+255,funcdesc(ip+1:ip+255)
19875	format('write buffer [',i5,':',i5,'] -- on next line:'/a)
19885	continue
c]
	      WRITE(L,15,ERR=90)FUNCDESC(IP+1:IP+255)
	      IP=IP+255
	      GOTO14
	   ELSE
c[
	write(13,19875,err=19895)ip+1,ll,funcdesc(ip+1:ll)
19895	continue
c]
	      WRITE(L,15,ERR=90)FUNCDESC(IP+1:LL)
	   ENDIF
15	   FORMAT(A)
C
C	Set the timer for this work area so that we shut down if no activity
C	within the timeout period.
C
	   CALL SET_TIMER(WRKID)
	   REMOUT=1
	ELSE IF(FUNC.EQ.PSM$K_CANCEL.OR.
	1 FUNC.EQ.PSM$K_CLOSE)THEN
C
C	Ignore the CANCEL and CLOSE functions, but return success.
C
c[
	write(13,19876,err=19886)
19876	format('CANCEL or CLOSE')
19886	continue
c]
	   REMOUT=1
	ELSE IF(FUNC.EQ.PSM$K_STOP_TASK)THEN
C
C	If doing a STOP TASK, get the LUN and close it.
C
	   L=ICHAR(WORKAREA(1:1))
	   IF(L.LE.10.OR.L.GT.26)GOTO19
c[
	write(13,19877,err=19887)l
19877	format('STOP TASK for lun = ',I3)
19887	continue
c]
	   CLOSE(UNIT=L,ERR=19)
C
C	Set all references for the work area to indicate no LUN active.
C
	   LUN(L-10)=0
	   WORKAREA(1:1)=CHAR(0)
	   REMOUT=1
	   GOTO99
19	   REMOUT='2C'X
	ELSE
C
C	All other functions are "not supported".
C
c[
	write(13,19878,err=19888)
19878	format('UNSUPPORTED FUNCTION')
19888	continue
c]
	   REMOUT=FUNNOTSUP
	ENDIF
C
C	Return the status
C
	GOTO99
C
C	Set abort status if we come here.
C
90	REMOUT='2C'X
c[
	write(13,19879,err=19889)'reached statement 90 -- returning ABORT'
19879	format(a)
19889	continue
c]
C
C	Return the status.
C
99	RETURN
	END
C
C	This routine sets the timer for a specified work area ID.
C
	SUBROUTINE SET_TIMER(REQIDT)
	INTEGER*4 REQIDT
	INTEGER*4 DELAYTIME(2)
	COMMON /TIMER/DELAYTIME
	EXTERNAL TIMER_AST
	CALL SYS$SETIMR(,%REF(DELAYTIME),%REF(TIMER_AST),%VAL(REQIDT))
	RETURN
	END
C
C	This routine cancels the timer for a specified work area ID.
C
	SUBROUTINE CANCEL_TIMER(REQIDT)
	INTEGER*4 REQIDT
	CALL SYS$CANTIM(%VAL(REQIDT),)
	RETURN
	END
C
C	This is the timer AST routine.  If a particular stream (represented
C	here by its work area ID) times out, close the LUN for that work area.
C	Because no indication of end-of-task is received by the user code,
C	this is the only way we can assure that the file on the remote system
C	will be closed in a reasonable time frame.
C
	SUBROUTINE TIMER_AST(WORKAREA)
	BYTE WORKAREA(256)
	INTEGER*4 WRKIDS(16)
	INTEGER*2 LUN(16)
	COMMON /LUNCOM/WRKIDS,LUN
	INTEGER*2 L
C
C	Get the work area's LUN pointer
C
	L=WORKAREA(1)
	IF(L.LE.10.OR.L.GT.26)GOTO19
C
C	If it's a valid LUN, close it and set pointer to show no LUN.
C
c[
	write(13,1987,err=1988)l
1987	format('closing lun = ',i3,' due to timeout')
1988	continue
c]
	CLOSE(UNIT=L,ERR=19)
	LUN(L-10)=0
	WORKAREA(1)=0
C
C	This is an AST routine, so it returns no status; whether error 
C	occurred or not, return.
C
19	RETURN
	END