.Title	ACCPORNAM	- Set the Access Port Name for terminals
	.Ident	/V01.000/
	.Enable	SUP
	.Default Displacement,Word
	.Subtitle	Introduction

;+
;
; ----- ACCPORNAM:  Set the Access Port Name for terminals
;
;
; Facility:
;
;	VAX/VMS system management
;
; Abstract:
;
;	This module allows a suitably privileged user to set the Access
;	Port Name (ACCPORNAM) for hard-wired terminals.
;
; Environment:
;
;	VAX/VMS native mode, VMS V5.0 or later, CMKRNL privilege.
;
;
;
; Version:	V01.000
; Date:		24-Feb-1989
;
; Copyright © 1989  San Diego Supercomputer Center
;
; Gerard K. Newman	24-Feb-1989
; San Diego Supercomputer Center
; General Atomics
; P.O. Box 85608
; San Diego, CA  92138-5608
; 619.534.5076
;
; Internet:	GKN@SDS.SDSC.EDU
; BITNET:	GKN@SDSC.BITNET
; SPAN:		SDSC::GKN (27.1)
; MFENET:	GKN@SDS.MFENET
; SDSCNET:	GKN@SDS.SDSCNET
;
;
; Modifications:
;
;
;-

	.Page
	.Subtitle	Local definitions

	.Link	 "SYS$SYSTEM:SYS.STB"/Selective_Search	;Grab the system symbol table
	.Library "SYS$LIBRARY:LIB.MLB"			;Get special macros from here

	.NoCross			;Save a tree

	$CHFDEF				;Define condition handler stuff
	$DCDEF				;Device class & type definitions
	$SSDEF				;System service codes
	$STSDEF				;Define severity codes
	$TPADEF				;TPARSE definitions
	$TTYUCBDEF			;Terminal UCB offsets
	$UCBDEF				;UCB offsets

	.Cross				;Turn CREF back on


; Local macros

; Item:		Make an item list entry for $GETxxI

.Macro	Item	Type=DVI,Item=,Length=4,RetAdr=,RetLen= ;Make an item list entry for $GETxxI
	.Word	Length,Type'$_'Item	;Length,,what
	.Address RetAdr			;Put it here
	.If	NB,RetLen		;If we have an explicit return length
	.Address RetLen			; then use it
	.Iff				;  else
	.Long	0			;   we don't care
	.Endc				;	...
.Endm	Item				;	...

; .Ascip:	Create a pointer to an .Ascid string

.Macro	.Ascip	STRING,?A		;Point to a string descriptor in another PSECT
	.Enable	LSB			;Turn on the local symbol block
	.Save				;Save the current PSECT
	.Psect	STRINGS NOEXE,RD,NOWRT,PIC,SHR,PAGE
A:	.Ascid	\'STRING\		;String
	.Restore			;Restore the current PSECT
	.Address A			;Store pointer to the string
	.Disable LSB			;Turn off the local symbol block
.Endm	.Ascip				;       ...

	.Page
	.Subtitle	TPARSE state table

;+
;
; ----- TPARSE state table
;
;
; Valid commands:
;
;	HELP or ?		- Print a short help message
;	SET <device> <string>	- Set  the ACCPORNAM for <device> to <string>
;	SHOW <device>		- Show the ACCPORNAM for <device>
;	EXIT			- Quit
;
;-

	$INIT_STATE	ACCP_STATES,ACCP_KEYS	;Initialize the state table

; Parse the major verb.

	$STATE					;First state

	$TRAN	TPA$_STRING,,UPCASE		;Upcase the first token (!)
	$TRAN	TPA$_EOS,TPA$_EXIT		;Ignore empty commands
	$TRAN	'?',TPA$_EXIT,HELP		;Print help
	$TRAN	'EXIT',TPA$_EXIT,RET_EOF	;Quit
	$TRAN	'HELP',TPA$_EXIT,HELP		;    ...
	$TRAN	'SET',ST_SET			;Set the ACCPORNAM
	$TRAN	'SHOW',ST_SHOW			;Show the ACCPORNAM

; Set <device> <string>

	$STATE	ST_SET				;Set the ACCPORNAM

	$TRAN	TPA$_FILESPEC,,CHECK_DEVICE	;Go check the device name out

	$STATE					;Here to set the string

	$TRAN	!ST_NAME,TPA$_EXIT,SET_ACCP	;Go set the string

; Show <device>

	$STATE	ST_SHOW				  ;Show the ACCPORNAM

	$TRAN	TPA$_FILESPEC,TPA$_EXIT,SHOW_ACCP ;Go show the access port name

; Sub-expression to swallow stuff until EOS.

	$STATE	ST_NAME				;Sub-expression to collect until EOS

	$TRAN	TPA$_LAMBDA,,BLANKS_VISIBLE	;Make blanks visible again

	$STATE	ST_NAME_1			;Here to collect until EOS

	$TRAN	TPA$_EOS,TPA$_EXIT		;Quit at EOS
	$TRAN	TPA$_ANY,ST_NAME_1		;Else munch another character

	$END_STATE				;End of the state table

	.Page
	.Subtitle	Impure storage

	.Psect	IMPURE_DATA	NOEXE,RD,WRT,PIC,NOSHR,PAGE


; TPARSE parameter block.

TPARSE_BLOCK:	.Long	TPA$K_COUNT0	;Argument count
		.Blkb	TPA$K_LENGTH0-4	;Allocate the rest of the block


; Random other crud.

DEVICE_CLASS:	.Blkl			;Device class
DEVICE_STS:	.Blkl			;Device status
DEVICE_DESC:	.Blkl			;Device name
		.Address DEVICE_BUFF	; descriptor
ACCP_DESC:	.Blkl			;Access Port Name
		.Address ACCP_BUFF	; descriptor
TT_DESC:	.Blkl			;Physical terminal
		.Address TT_BUFF	; descriptor

IN_BUFF:	.Blkb	128		;Command input buffer
TT_BUFF:	.Blkb	64		;Physical terminal name buffer
DEVICE_BUFF:	.Blkb	64		;Device name buffer
ACCP_BUFF:	.Blkb	64		;Access Port Name buffer

	.Page
	.Subtitle	Pure storage

	.Psect	PURE_DATA	NOEXE,RD,NOWRT,PIC,SHR,PAGE


; $GETDVI wish list.

DVI_LIST:	Item	Item=DEVCLASS,-		;Get the device class
			RetAdr=DEVICE_CLASS	;Put it here
		Item	Item=STS,-		;Get the device status word
			RetAdr=DEVICE_STS	;Put it here
		Item	Item=TT_PHYDEVNAM,-	;Get the device name
			Length=64,-		;It can be this big
			RetAdr=TT_BUFF,-	;Put it here
			RetLen=TT_DESC		;Return the length here
		Item	Item=TT_ACCPORNAM,-	;Get the Access Port Name
			Length=64,-		;It can be this big
			RetAdr=ACCP_BUFF,-	;Put it here
			RetLen=ACCP_DESC	;Return the length here
		Item	Item=DEVNAM,-		;Get the device name
			Length=64,-		;It can be this big
			RetAdr=DEVICE_BUFF,-	;Put it here
			RetLen=DEVICE_DESC	;Return the length here
		.Long	0			;That's all


; Help text.

HELP_TEXT:	.Ascip	<>
		.Ascip	<Commands:>
		.Ascip	<>
		.Ascip	<EXIT			- Exit the program>
		.Ascip	<SET device string	- Set  the ACCPORNAM for device to string>
		.Ascip	<SHOW device		- Show the ACCPORNAM for device>
		.Ascip	<>
		.Long	0


; Other random text.

PROMPT:		.Ascid	"ACCP> "
US:		.Ascid	"ACCP"

	.Page
	.Subtitle	Entry point

	.Psect	CODE		EXE,RD,NOWRT,PIC,SHR,PAGE

	.Entry	START,^M<>		;Entry here

	MOVAB	COND_HANDLER,(FP)	;Establish a condition handler
	MOVAL	TPARSE_BLOCK,R11	;Address our TPARSE block

; Loop here reading commands from SYS$INPUT.

10$:	MOVZBL	#128,TPA$L_STRINGCNT(R11)    ;Reset the input
	MOVAB	IN_BUFF,TPA$L_STRINGPTR(R11) ; descriptor
	MOVL	#TPA$M_ABBREV,-		     ;Reset the
		TPA$L_OPTIONS(R11)	     ; TPARSE options
	PUSHAW	TPA$L_STRINGCNT(R11)	     ;Return the length here
	PUSHAQ	PROMPT			     ;Prompt with this
	PUSHAQ	TPA$L_STRINGCNT(R11)	     ;Here's the input buffer
	CALLS	#3,G^LIB$GET_INPUT	     ;Fetch some input
	BLBC	R0,20$			     ;Presume EOF
	TSTW	TPA$L_STRINGCNT(R11)	     ;Any input?
	BEQL	10$			     ;If EQL no, ask again

; Feed the command to TPARSE.  Command execution handled by TPARSE
; action routines.

	PUSHAL	ACCP_KEYS		;Stack the keyword table address
	PUSHAL	ACCP_STATES		;Stack the state table address
	PUSHL	R11			;Stack the TPARSE block address
	CALLS	#3,G^LIB$TPARSE		;Parse the command
	BLBS	R0,10$			;Win!

; Here on some sort of error.

20$:	CMPL	#RMS$_EOF,R0		;End of file?
	BEQL	40$			;If EQL yes, not an error
	BBS	#STS$V_INHIB_MSG,R0,10$	;Branch if we've already signalled the error
	CMPL	#LIB$_SYNTAXERR,R0	;Syntax error?
	BNEQ	30$			;If NEQ no, a real problem
	PUSHAQ	TPA$L_TOKENCNT(R11)	;Else stack the token descriptor address
	PUSHL	#1			;1 FAO argument
	PUSHL	#ACCP$_SYNTAX		;Stack the error code
	CALLS	#3,G^LIB$SIGNAL		;Signal the error
	BRB	10$			;And loop

; Here on some drastic error.

30$:	PUSHL	R0			;Stack the error
	CALLS	#1,G^LIB$STOP		;Punt.

; Here to exit peacefully.

40$:	MOVL	#SS$_NORMAL,R0		;Success
	RET		

	.Page
	.Subtitle	HELP		- List brief help

;+
;
; ----- HELP:  List brief help
;
;
; This routine is called as a TPARSE action routine to print
; brief help on SYS$OUTPUT.
;
; Inputs:
;
;	HELP_TEXT	- Table of help text pointers.
;
; Outputs:
;
;	As described above.
;
;-

HELP:	.Word	^m<R2>			;List brief help

	MOVAL	HELP_TEXT,R2		;Address the help text

10$:	PUSHL	(R2)+			;Stack the next descriptor address
	BEQL	20$			;If EQL we're done
	CALLS	#1,G^LIB$PUT_OUTPUT	;Display it
	BRB	10$			;Around and around we go

20$:	RET				;Done

	.Page
	.Subtitle	RET_EOF		- Return RMS$_EOF

;+
;
; ----- RET_EOF:  Return RMS$_EOF
;
;
; This routine is called as a TPARSE action routine for the EXIT command.
;
; Inputs:
;
;	None
;
; Outputs:
;
;	R0	- RMS$_EOF
;
;-

RET_EOF: .Word	^m<>			;Return RMS$_EOF

	MOVL	#RMS$_EOF,R0		;Return
	RET				; RMS$_EOF

	.Page
	.Subtitle	CHECK_DEVICE	- Ensure that the device is a terminal

;+
;
; ----- CHECK_DEVICE:  Ensure that the device is a terminal
;
;
; This routine will ensure that the target device is a terminal
; and is not a "ephemeral" device.
;
; Inputs:
;
;	TPA$L_TOKENCNT(AP)	- A descriptor of the device name
;
; Outputs:
;
;	R0	- Success or failure
;
;-

CHECK_DEVICE: .Word ^m<>			;Ensure that the device is a terminal

; Get the scoop on this device

	$GETDVIW_S DEVNAM=TPA$L_TOKENCNT(AP),-	;Fetch the
		ITMLST=DVI_LIST			; poop on this device
	BLBC	R0,10$				;Lose!

; Reject if it's not a terminal, off line, or a template device.

	MOVAQ	DEVICE_DESC,R1			;Presume it's not a terminal
	MOVL	#ACCP$_NOTERM,R0		;Presume not a terminal
	CMPL	#DC$_TERM,DEVICE_CLASS		;Is it?
	BNEQ	20$				;Nope.
	MOVL	#ACCP$_OFFLINE,R0		;Presume device off line
	BBC	#UCB$V_ONLINE,DEVICE_STS,20$	;Branch if so
	MOVAL	TT_DESC,R1			;It's a terminal, so use this name for errors
	MOVL	#ACCP$_TEMPLATE,R0		;Presume template device
	BBS	#UCB$V_TEMPLATE,DEVICE_STS,20$	;Branch if so
	MOVL	#SS$_NORMAL,R0			;Else we're
	RET					; Ok

; Here on a system service error.

10$:	PUSHL	R0			;Stack the error code
	CALLS	#1,G^LIB$SIGNAL		;Signal same
	RET				;Done

; Here when it appears that we don't have an acceptible device.

20$:	PUSHL	R1			;Stack the device descriptor address
	PUSHL	#1			;1 FAO argument
	PUSHL	R0			;Stack the error code
	CALLS	#3,G^LIB$SIGNAL		;Signal the error
	RET				;Done

	.Page
	.Subtitle	SHOW_ACCP	- Show the Access Port Name

;+
;
; ----- SHOW_ACCP:  Show the Access Port Name
;
;
; This routine is called as a TPARSE action routine to show the
; Access Port Name for the current device.
;
; Inputs:
;
;	TPA$L_TOKENCNT(AP)	- A descriptor of the device name
;
; Outputs:
;
;	Access Port Name displayed.
;
;-

SHOW_ACCP: .Word ^m<>			;Show the Access Port Name

; Get the scoop on the device.

	$GETDVIW_S DEVNAM=TPA$L_TOKENCNT(AP),-	;Fetch the
		ITMLST=DVI_LIST			; poop on this device
	BLBC	R0,10$				;Lose!

; Lose if it's not a terminal, off line, or a template device.

	MOVAQ	DEVICE_DESC,R1			;Presume it's not a terminal
	MOVL	#ACCP$_NOTERM,R0		;Presume not a terminal
	CMPL	#DC$_TERM,DEVICE_CLASS		;Is it?
	BNEQ	20$				;Nope.
	MOVL	#ACCP$_OFFLINE,R0		;Presume device off line
	BBC	#UCB$V_ONLINE,DEVICE_STS,20$	;Branch if so
	MOVAQ	TT_DESC,R1			;It's a terminal, so use this name
	MOVL	#ACCP$_TEMPLATE,R0		;Presume template device
	BBS	#UCB$V_TEMPLATE,DEVICE_STS,20$	;Branch if so

; It's a terminal -- signal the Access Port Name.

	PUSHAQ	ACCP_DESC		;Stack the Access Port Name descriptor address
	PUSHAQ	TT_DESC			;Stack the device name descriptor address
	PUSHL	#2			;2 FAO arguments
	PUSHL	#ACCP$_ACCP		;Stack the message code
	CALLS	#4,G^LIB$SIGNAL		;Signal the message
	RET				;Done

; Here when $GETDVI loses.

10$:	PUSHL	R0			;Stack the error
	CALLS	#1,G^LIB$SIGNAL		;Signal it
	RET				;Done

; Here when the device isn't a terminal or is otherwise unacceptable.

20$:	PUSHL	R1			;Stack the device descriptor address
	PUSHL	#1			;1 FAO argument
	PUSHL	R0			;Stack the error code
	CALLS	#3,G^LIB$SIGNAL		;Signal the error
	RET				;Done

	.Page
	.Subtitle	SET_ACCP	- Set the Access Port Name

;+
;
; ----- SET_ACCP:  Set the Access Port Name
;
;
; This routine is called as a TPARSE action routine to set the Access
; Port Name for the specified device.  If  the device  already has an
; Access  Port Name  buffer then  we simply replace its contents.  If
; not, then  we allocate a  64 byte  chunk of  non-paged pool and use
; that.
;
; Inputs:
;
;	TT_DESC			- Descriptor of the device to hack
;	TPA$L_TOKENCNT(AP)	- Descriptor of the Access Port Name
;
; Outputs:
;
;	Access Port Name bashed.
;
;-

SET_ACCP: .Word	^m<>			;Set the Access Port Name

	CMPL	TPA$L_TOKENCNT(AP),#63	;Too big?
	BGTRU	10$			;If GTRU yes
	$CMKRNL_S B^20$,(AP)		;Do this in kernel mode
	RET				;Done, status in R0

; Here when the string is too long.

10$:	PUSHAQ	TPA$L_TOKENCNT(AP)	;Stack the string descriptor address
	PUSHL	#1			;1 FAO argument
	PUSHL	#ACCP$_TOOLONG		;Stack the error code
	CALLS	#1,G^LIB$SIGNAL		;Signal the error
	RET				;Done

; Here in kernel mode to do the hard work.

20$:	.Word	^m<R2,R3,R4,R5,R6,R7,R8,R9,R10,R11> ;Here in kernel mode to do the hard work.

; Hunt down the device.

	MOVL	G^CTL$GL_PCB,R4		  ;Fetch my PCB address
	JSB	G^SCH$IOLOCKW		  ;Lock the I/O database for write access
	MOVAB	TT_DESC,R1		  ;Here's the device to find
	JSB	G^IOC$SEARCHDEV		  ;Find the device
	BLBC	R0,40$			  ;Lose.
	MOVL	R1,R5			  ;Remember the UCB address

; Check to make sure that the UCB is long enough to accomodate an Access Port Name.

	MOVL	#ACCP$_BADUCB,R0	  ;Presume the UCB is too small
	CMPW	UCB$W_SIZE(R5),-	  ;Is the UCB
		#UCB$L_TT_ACCPORNAM+4	  ; big enough?
	BLSSU	40$			  ;If LSSU no, we have to lose. 
	MOVL	UCB$L_TT_ACCPORNAM(R5),R2 ;Fetch the Access Port Name buffer address
	BLSS	30$			  ;If LSS use the one that's there

; We have to  allocate an Access Port Name buffer.  This is a problem for
; ephemeral devices, in that when the UCB goes away then we will lose the
; non-paged  pool for the  Access Port Name  buffer.  We  can't make this
; check in  CHECK_DEVICE because of  the cretinous misfeature  of $GETDVI
; which returns UCB$W_STS  for the  *virtual*  terminal when  you ask for
; information on the  *physical*  terminal.  If I  had wanted information
; for the *virtual* terminal I would have asked for it...

	MOVL	#ACCP$_EPHEMERAL,R0	;Presume that the device is ephemeral
	BBS	#UCB$V_DELETEUCB,-	;Branch if this
		UCB$W_STS(R5),40$	; is the case

; Allocate an Access Port Name buffer

	MOVL	#64,R1			  ;We'd like 64 bytes
	JSB	G^EXE$ALONPAGVAR	  ;Get some pool
	BLBC	R0,40$			  ;Lossage!
	MOVL	R2,UCB$L_TT_ACCPORNAM(R5) ;Fill in the address of the block
	BBSS	#TTY$V_PC_ACCPORNAM,-	  ;Indicate that there's
		UCB$W_TT_PRTCTL(R5),30$	  ; an access port name buffer

; Stuff the string into the Access Port Name buffer.

30$:	MOVZBL	TPA$L_TOKENCNT(AP),R0	    ;Grab the device length
	MOVB	R0,(R2)+		    ;Stash the length
	MOVC3	R0,@TPA$L_TOKENPTR(AP),(R2) ;Stash the Access Port Name
	MOVL	#SS$_NORMAL,R0		    ;Success

40$:	PUSHL	R0			;Save the status
	MOVL	G^CTL$GL_PCB,R4		;Fetch my PCB address
	JSB	G^SCH$IOUNLOCK		;Unlock the I/O database
	POPL	R0			;Restore the status
	RET				;Back to user mode

	.Page
	.Subtitle	BLANKS_VISIBLE	- Make blanks visible

;+
;
; ----- BLANKS_VISIBLE:  Make blanks visible
;
;
; This routine is called as a TPARSE action routine to make
; blanks significant in the input string.
;
; Inputs:
;
;	AP	- TPARSE parameter block address
;
; Outputs:
;
;	TPA$M_BLANKS set in TPA$L_OPTIONS(AP).
;
;-

BLANKS_VISIBLE:	.Word ^m<>		;Make blanks visible

	BISL	#TPA$M_BLANKS,-		;Make blanks
		TPA$L_OPTIONS(AP)	; visible
	RET				;Done

	.Page
	.Subtitle	UPCASE		- Upcase the current token

;+
;
; ----- UPCASE:  Upcase the current token
;
;
; This routine is called as a TPARSE action routine to upcase the
; current token.  The routine  returns failure to cause TPARSE to
; scan forward for the next transition.
;
; Inputs:
;
;	TPA$L_TOKENCNT(AP)	- A descriptor of the token
;
; Outputs:
;
;	Token upcased.
;
;-

UPCASE:	.Word	^m<>			;Upcase the current token

	PUSHAL	TPA$L_TOKENCNT(AP)	;Here's the destination string
	PUSHL	(SP)			;Which happens to be the source string
	CALLS	#2,G^STR$UPCASE		;Uppercasify it
	CLRL	R0			;Lose
	RET				;Done

	.Page
	.Subtitle	COND_HANDLER	- Condition handler

;+
;
; ----- COND_HANDLER:  Condition handler
;
;
; This routine is the condition handler for this module.  We output an error
; message and exit with status if the error condition was severe.
;
; Inputs:
;
;	CHF$L_SIGARGLST(AP)	- Signal argument vector address
;	CHF$L_MECARGLST(AP)	- Mechanism argument vector address
;
; Outputs:
;
;	An error message is output to SYS$OUTPUT and SYS$ERROR using
;	$PUTMSG.  Image exit will be forced if the error was SEVERE.
;
;-

COND_HANDLER: .Word ^M<R2>		;Here on a signalled error

	MOVL	CHF$L_SIGARGLST(AP),R2	;Address the signal vector
	SUBL	#2,(R2)			;Never mind the PC and PSL
	$PUTMSG_S MSGVEC=(R2),-		;Output the error code(s)
		FACNAM=US		;Use our name.
	BISL3	#STS$M_INHIB_MSG,-	;Don't output
		CHF$L_SIG_NAME(R2),R1	; the message twice
	CMPZV	#STS$V_SEVERITY,-	;Is this a
		#STS$S_SEVERITY,-	; severe (fatal)
		R1,#STS$K_SEVERE	;  error?
	BEQL	10$			;If EQL yes, force image exit
	MOVL	CHF$L_MCHARGLST(AP),R2	;Else address the mechanism argument list
	MOVL	R1,CHF$L_MCH_SAVR0(R2)	;Return the error code and return to
	RET				; the previous thread of execution

10$:	$EXIT_S	R1			;Exit with status



	.End	START