	PROGRAM PRSERVER
C	Title: Printer server for remote printing.
C	Author: Mark T. Draughn
C
C	This recieves printer requests to print a job and
C	prints it.
C
C Disallow default typing because of the abundance of external
C variables referenced.

	IMPLICIT	NONE

C
C Error handling variables.
C

	INTEGER*4	RMSSTS
	INTEGER*4	RMSSTV

C
C File names and unit numbers.
C

	INTEGER		NETLINK
	PARAMETER	(NETLINK = 10)

C
C Declare external symbols.
C

	EXTERNAL	SS$_IVDEVNAM,SS$_NOSUCHDEV,DVI$_DEVCLASS,
     +			DC$_LP,DC$_TERM,LCK$K_NLMODE,LCK$K_EXMODE,
     +			LCK$M_SYSTEM,LCK$M_CONVERT,IO$_WRITELBLK,
     +			IO$_WRITEPBLK,IO$M_NOFORMAT,SS$_DEVALLOC,
     +			DVI$_DEVNAM,SS$_PROTOCOL,SS$_TIMEOUT,
     +			RMS$_DEV,DVI$_ALLDEVNAM,DVI$_DEVDEPEND,
     +			DVI$C_SECONDARY

C
C Declare external routines.
C

	INTEGER*4	SYS$ALLOC,SYS$DALLOC,SYS$ASSIGN,SYS$DASSGN,
     +			SYS$ENQW,SYS$DEQ,SYS$QIOW,SYS$GETDVI,
     +			LIB$WAIT,LIB$GETDVI,SYS$SETIMR,SYS$CANTIM,
     +			TIMER,SYS$SETPRN,SYS$SETAST,LIB$SIGNAL
	EXTERNAL	SYS$ALLOC,SYS$DALLOC,SYS$ASSIGN,SYS$DASSGN,
     +			SYS$ENQW,SYS$DEQ,SYS$QIOW,SYS$GETDVI,
     +			LIB$WAIT,LIB$GETDVI,SYS$SETIMR,SYS$CANTIM,
     +			TIMER,SYS$SETPRN,SYS$SETAST,LIB$SIGNAL

C
C Status values.
C

	INTEGER*4	STATUS
	INTEGER*4	IOSB(2)

C
C Node name.
C

	CHARACTER*255	NODENAME
	INTEGER		NODENAME_LEN

C
C Process name.
C

	CHARACTER*255	PROCNAME
	INTEGER		PROCNAME_LEN
	INTEGER		SEQNUM
	CHARACTER*4	SEQNUM_CHAR
C
C Device class.
C

	INTEGER*4	DEVCLASS

C
C Task requests.
C

	CHARACTER	REQUEST

C
C Function values.
C

	INTEGER*4	PRINT,PRINT_NOFORMAT

C
C Buffer.
C

	CHARACTER*65535	LINE
	INTEGER*4	LINE_LEN

C
C Shared data.
C

	LOGICAL*1	TIMEOUT
	INTEGER		TIMEOUT_STATUS
	CHARACTER*255	DEVNAM
	INTEGER		DEVNAM_LEN
	INTEGER*2	CHANNEL
	INTEGER*4	LOCKBLOCK(2)
	INTEGER*4	VAXTIME(2)
	CHARACTER*255	ALLDEVNAM
	INTEGER*4	ALLDEVNAM_LEN

	COMMON		/PRTIMEOUT/ TIMEOUT,TIMEOUT_STATUS,
     +			DEVNAM,DEVNAM_LEN,CHANNEL,LOCKBLOCK,VAXTIME,
     +			ALLDEVNAM,ALLDEVNAM_LEN

C
C Device information.
C

	INTEGER*4	DEVDEPEND
	
C
C Item list.
C

	INTEGER*4	LONG(13)
	INTEGER*2	SHORT(26)
	EQUIVALENCE	(LONG,SHORT)

C
C Timeout period.
C

	INTEGER*4	TIMESEC /30/


C
C Format statements.
C

70	FORMAT(Z8)
71	FORMAT(Q,A)
72	FORMAT(A1,Q,A)

C
C Build item list.
C

	SHORT(1) =	4
	SHORT(2) =	(%LOC(DVI$_DEVDEPEND)).OR.(%LOC(DVI$C_SECONDARY))
	LONG(2) =	%LOC(DEVDEPEND)
	LONG(3) =	0

	SHORT(7) =	4
	SHORT(8) =	(%LOC(DVI$_DEVCLASS)).OR.(%LOC(DVI$C_SECONDARY))
	LONG(5) =	%LOC(DEVCLASS)
	LONG(6) =	0

	SHORT(13) =	64
	SHORT(14) =	(%LOC(DVI$_ALLDEVNAM)).OR.(%LOC(DVI$C_SECONDARY))
	LONG(8) =	%LOC(ALLDEVNAM)
	LONG(9) =	ALLDEVNAM_LEN

	SHORT(19) =	255
	SHORT(20) =	(%LOC(DVI$_DEVNAM)).OR.(%LOC(DVI$C_SECONDARY))
	LONG(11) =	%LOC(DEVNAM)
	LONG(12) =	%LOC(DEVNAM_LEN)

	LONG(13) =	0

C
C Open network link.
C

	OPEN(NETLINK,
     +		FILE = 'SYS$NET:',
     +		FORM = 'FORMATTED',
     +		CARRIAGECONTROL = 'NONE',
     +		ERR = 900,
     +		STATUS = 'OLD')

C
C Get name of source node and set process name.
C

	READ(NETLINK,71,ERR=900) NODENAME_LEN,NODENAME

	SEQNUM = 0
80	SEQNUM = SEQNUM + 1
	WRITE(SEQNUM_CHAR,FMT='(I4.4)')SEQNUM
	PROCNAME_LEN = NODENAME_LEN + 8
	PROCNAME(1:PROCNAME_LEN) = 
     +		'PR_'//NODENAME(1:NODENAME_LEN)//'_'//SEQNUM_CHAR
	STATUS = SYS$SETPRN(PROCNAME(1:PROCNAME_LEN))
	IF(STATUS) GOTO 81
	IF(SEQNUM.EQ.9999) THEN
		WRITE(NETLINK,70,ERR=900) STATUS
		CALL EXIT(STATUS)
	END IF
	GOTO 80
81	WRITE(NETLINK,70,ERR=900) STATUS

C
C Get name of printer device.
C

	READ(NETLINK,71,ERR=900) DEVNAM_LEN,DEVNAM

C
C Now process device name if possible.
C Check if device name is long enough.
C

	IF (DEVNAM_LEN.EQ.0) THEN
		STATUS = %LOC(SS$_IVDEVNAM)
	ELSE

C
C Get device information.
C

		STATUS = SYS$GETDVI(,,DEVNAM(1:DEVNAM_LEN),LONG(1),,,,)
		IF (.NOT.STATUS) THEN
			WRITE(NETLINK,70,ERR=900) STATUS
			CALL EXIT(STATUS)
		END IF

C
C Make sure it is a valid device type, either a terminal
C or a line printer.
C

		IF ((DEVCLASS.NE.%LOC(DC$_TERM)).AND.
     +		    (DEVCLASS.NE.%LOC(DC$_LP)))
     +			STATUS = %LOC(RMS$_DEV)
		IF (.NOT.STATUS) THEN
			WRITE(NETLINK,70,ERR=900) STATUS
			CALL EXIT(STATUS)
		END IF

C
C Set up function definitions.
C A print request is always a "write logical block".
C An unformatted print is a "write logical block" with no format
C if the device is a terminal and a "write physical block" for a
C line printer. 
C
		IF (DEVCLASS.EQ.%LOC(DC$_TERM)) THEN
			PRINT = %LOC(IO$_WRITELBLK)
			PRINT_NOFORMAT = 
     +				(%LOC(IO$_WRITELBLK)).OR.
     +				(%LOC(IO$M_NOFORMAT))
		ELSE
			PRINT = %LOC(IO$_WRITELBLK)
			PRINT_NOFORMAT = %LOC(IO$_WRITEPBLK)
		END IF
	END IF

C
C Test for error.
C

	IF (.NOT.STATUS) THEN
		WRITE(NETLINK,70,ERR=900) STATUS
		CALL EXIT(STATUS)
	END IF

C
C
C Place a null lock on the device.
C

	STATUS = SYS$ENQW(,%VAL(%LOC(LCK$K_NLMODE)),
     +			  LOCKBLOCK,
     +			  %VAL(%LOC(LCK$M_SYSTEM)),
     +			  'PRSERVER_'//DEVNAM(1:DEVNAM_LEN),,,,,,)
	WRITE(NETLINK,70,ERR=900) STATUS
	IF (.NOT.STATUS) CALL EXIT(STATUS)

C
C Get device characteristics.
C


	WRITE(NETLINK,70,ERR=900) 0

C
C Convert timeout period to VMS delta time.
C

	VAXTIME(1) = TIMESEC * -10000000
	VAXTIME(2) = -1

C
C Now begin the main loop.
C
C Get the initial request.
C

100	READ(NETLINK,72,END=200,ERR=900) REQUEST,LINE_LEN,LINE

C
C Check for a protocol error.
C

	IF(REQUEST.NE.'B') STATUS = %LOC(SS$_PROTOCOL)
	IF (.NOT.STATUS) THEN
		WRITE(NETLINK,70,ERR=900) STATUS
		CALL EXIT(STATUS)
	END IF

C
C Get exclusive access to the printer.
C

	STATUS = SYS$ENQW(,%VAL(%LOC(LCK$K_EXMODE)),
     +			  LOCKBLOCK,
     +			  %VAL(%LOC(LCK$M_CONVERT)),
     +			  'PRSERVER_'//DEVNAM(1:DEVNAM_LEN),,,,,,)
	IF (.NOT.STATUS) THEN
		WRITE(NETLINK,70,ERR=900) STATUS
		CALL EXIT(STATUS)
	END IF

C
C Allocate the printer.  If unable to allocate it because of another user,
C then pause and try again later.
C

110	STATUS = SYS$ALLOC(DEVNAM(1:DEVNAM_LEN),,,,)
	IF (STATUS.EQ.%LOC(SS$_DEVALLOC)) THEN
		CALL LIB$WAIT(15.0)
		GOTO 110
	END IF
	IF (.NOT.STATUS) THEN
		WRITE(NETLINK,70,ERR=900) STATUS
		CALL EXIT(STATUS)
	END IF

C
C Assign a channel to the device.
C

	STATUS = SYS$ASSIGN(DEVNAM(1:DEVNAM_LEN),CHANNEL,,)
	WRITE(NETLINK,70,ERR=900) STATUS

C
C Now read lines of output until the end.
C
C Enable timeouts.
C

	TIMEOUT = .FALSE.

C
C Start timer.
C

120	IF (.NOT.TIMEOUT) THEN
		STATUS = SYS$SETIMR(%VAL(2),%REF(VAXTIME),TIMER,1)
		IF (.NOT.STATUS) CALL EXIT(STATUS)
	END IF

C
C Do the actual read.
C

	READ(NETLINK,72,END=200,ERR=900) REQUEST,LINE_LEN,LINE

C
C Disable timeouts.
C

	CALL SYS$SETAST(%VAL(0))
	IF (.NOT.TIMEOUT) THEN
		STATUS = SYS$CANTIM(1,)
		IF (.NOT.STATUS) THEN
			WRITE(NETLINK,70,ERR=900) STATUS
			CALL EXIT(STATUS)
		END IF
	END IF
	CALL SYS$SETAST(%VAL(1))

C
C Handle each request.
C
C Write requests.
C

	IF (REQUEST.EQ.'W') THEN
	    WRITE (NETLINK,70,ERR=900) STATUS
	    IF (TIMEOUT) THEN
		STATUS = %LOC(SS$_TIMEOUT)
	    ELSE
		STATUS = SYS$QIOW(%VAL(3),%VAL(CHANNEL),
     +			%VAL(PRINT),
     +			IOSB,,,
     +			%VAL(%LOC(LINE)),
     +			%VAL(LINE_LEN),,,,)
	    END IF
	ELSE IF (REQUEST.EQ.'N') THEN
	    WRITE (NETLINK,70,ERR=900) STATUS
	    IF (TIMEOUT) THEN
		STATUS = %LOC(SS$_TIMEOUT)
	    ELSE
		STATUS = SYS$QIOW(%VAL(3),%VAL(CHANNEL),
     +			%VAL(PRINT_NOFORMAT),
     +			IOSB,,,
     +			%VAL(%LOC(LINE)),
     +			%VAL(LINE_LEN),,,,)
	    END IF
C
C "E" means end of task.
C

	ELSE IF (REQUEST.EQ.'E') THEN

C
C If it has timed out, then the printer has already been released.
C
	    IF (TIMEOUT) THEN
		STATUS = TIMEOUT_STATUS
		TIMEOUT = .FALSE.

C
C Otherwise release the printer.
C
C Deassign the channel.
C

	    ELSE
		STATUS = SYS$DASSGN(%VAL(CHANNEL))
		IF (.NOT.STATUS) THEN
			WRITE(NETLINK,70,ERR=900) STATUS
			CALL EXIT(STATUS)
		END IF

C
C Deallocate the device.
C

		STATUS = SYS$DALLOC(DEVNAM(1:DEVNAM_LEN),)
		IF (.NOT.STATUS) THEN
			WRITE(NETLINK,70,ERR=900) STATUS
			CALL EXIT(STATUS)
		END IF

C
C Release the lock.
C

		STATUS = SYS$ENQW(,%VAL(%LOC(LCK$K_NLMODE)),
     +			  LOCKBLOCK,
     +			  %VAL(%LOC(LCK$M_CONVERT)),
     +			  'PRSERVER_'//DEVNAM(1:DEVNAM_LEN),,,,,,)
	    END IF

	    WRITE (NETLINK,70,ERR=900) STATUS
	    IF (.NOT.STATUS) CALL EXIT(STATUS)

	    GOTO 100

	ELSE
		STATUS = %LOC(SS$_PROTOCOL)
	END IF
	IF (.NOT.STATUS) THEN
		IF (STATUS.NE.%LOC(SS$_TIMEOUT)) CALL EXIT(STATUS)
	END IF
	GOTO 120

C
C Handle end-of-file condition.
C

200	CLOSE(NETLINK,ERR=900)
	CALL EXIT

C
C Handle FORTRAN I/O errors.
C

900	CALL ERRSNS(,RMSSTS,RMSSTV)
	CALL LIB$SIGNAL(%VAL(RMSSTS),%VAL(RMSSTV))

	END


	INTEGER*4 FUNCTION TIMER()
C Disallow default typing because of the abundance of external
C variables referenced.

	IMPLICIT	NONE

C
C Shared data.
C

	LOGICAL*1	TIMEOUT
	INTEGER		TIMEOUT_STATUS
	CHARACTER*255	DEVNAM
	INTEGER		DEVNAM_LEN
	INTEGER*2	CHANNEL
	INTEGER*4	LOCKBLOCK(2)
	INTEGER*4	VAXTIME(2)
	CHARACTER*255	ALLDEVNAM
	INTEGER*4	ALLDEVNAM_LEN

	COMMON		/PRTIMEOUT/ TIMEOUT,TIMEOUT_STATUS,
     +			DEVNAM,DEVNAM_LEN,CHANNEL,LOCKBLOCK,VAXTIME,
     +			ALLDEVNAM,ALLDEVNAM_LEN

	INTEGER*4	SYS$SETIMR,SYS$DASSGN,SYS$DALLOC,SYS$ENQW,
     +			LCK$K_NLMODE,LCK$M_CONVERT,SYS$CANCEL
	EXTERNAL	SYS$SETIMR,SYS$DASSGN,SYS$DALLOC,SYS$ENQW,
     +			LCK$K_NLMODE,LCK$M_CONVERT,SYS$CANCEL


	TIMEOUT = .TRUE.
	TIMEOUT_STATUS = SYS$CANCEL(%VAL(CHANNEL))
	IF (.NOT.TIMEOUT_STATUS) THEN
		CALL EXIT(TIMEOUT_STATUS)
	END IF
	TIMEOUT_STATUS = SYS$DASSGN(%VAL(CHANNEL))
	IF (.NOT.TIMEOUT_STATUS) THEN
		CALL EXIT(TIMEOUT_STATUS)
	END IF
	TIMEOUT_STATUS = SYS$DALLOC(DEVNAM(1:DEVNAM_LEN),)
	IF (.NOT.TIMEOUT_STATUS) THEN
		CALL EXIT(TIMEOUT_STATUS)
	END IF
	TIMEOUT_STATUS = SYS$ENQW(,%VAL(%LOC(LCK$K_NLMODE)),
     +			  LOCKBLOCK,
     +			  %VAL(%LOC(LCK$M_CONVERT)),
     +			  'PRSERVER_'//DEVNAM(1:DEVNAM_LEN),,,,,,)

	END
