.title	system
	.sbttl	comments and symbol definitions
;+
;	integer function system(buffer)
;
;	character buffer(ARB)
;
;	return(0/1) if spawn failed/succeeded
;
;	the EOS-terminated command in buffer is spawned to the local
;	command interpreter (DCL).  If the spawn succeeded, a value of
;	1 is returned, else 0.  If buffer contains a null command, a
;	value of 1 is returned.
;
;	sys$system:loginout.exe is spawned as a sub-process reading
;	a mailbox for its input.  After some preliminary DCL commands
;	to force the environment to be correct, the command in buffer
;	is executed as
;
;	@st_bin:dodcl/out='term' 'command'
;
;	where 'term' is replaced by the translation of TT and 'command'
;	is the user specified command.  This command procedure is
;	designed to perform some more hacks to get the environment in
;	shape and to define the tools as foreign symbols.
;-
	$jpidef
	$dibdef
	$accdef
	$pqldef
	$devdef
buffer=4
	.page
	.sbttl	impure data
;
;	impure data
;
	.psect	st_system_data	rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long
pid:	.blkl	1		; our pid goes here
prib:	.blkl	1		; our base priority goes here
authpr:	.blkq	1		; our authorization privelege mask goes here
pidbuf:	.blkb	8		; buffer for formatted pid
trmbuf:	.ascii	"SYSTRM"	; name of termination mailbox
trmpid:	.blkb	8		; ...
argbuf:	.ascii	"SYSARG"	; name of argument mailbox
argpid:	.blkb	8		; ...
prcbuf:	.ascii	"SYS"		; sub-process name
prcpid:	.blkb	8		; ...
trmchn:	.blkw	1		; space for termination mailbox channel
trmunt:	.blkw	1		; space for termination mailbox unit
buf:	.blkb	512		; termporary buffer
ttybuf:	.blkb	64		; buffer for TT translation
dumdsc:	.blkq	1		; dummy descriptor
ttydsc:	.long	64		; resultant buffer for trnlog of TT
	.address	ttybuf		; ...
length:	.blkw	1		; location for length
cmddsc:	.blkq	1		; command descriptor
argchn:	.blkw	1		; location for argument mailbox channel
trmsts:	.blkb	acc$k_termlen	; termination mbox message buffer
	.page
	.sbttl	pure data
;
;	pure data
;
jpilst:	.word	4,jpi$_pid	; fetch our pid
	.address	pid	; ...
	.long		0	; ...
	.word	4,jpi$_prib	; fetch our base priority
	.address	prib	; ...
	.long	0		; ...
	.word	8,jpi$_authpriv	; fetch our auth privelege mask
	.address	authpr	; ...
	.long	0		; ...
	.long	0		; end of jpi list
pidfmt:	.ascid	"!XL"		; format string for pid format
trmdsc:	.long	14		; descriptor for termination mailbox
	.address	trmbuf		; ...
argdsc:	.long	14		; descriptor for argument mailbox
	.address	argbuf		; ...
prcdsc:	.long	11		; descriptor for process name
	.address	prcbuf		; ...
tt:	.ascid	"TT"		; descriptor for TT
nldsc:	.ascid	"NLA0:"		; descriptor for null device
imgdsc:	.ascid	"SYS$SYSTEM:LOGINOUT.EXE"	; image to run
nover:	.ascii	"$SET NOVERIFY"	; tell loginout not to mumble at user
noverl=.-nover
assfmt1: .ascid	"$ASSIGN !AS TT"	; format string for assign cmd
assfmt2: .ascid	"$ASSIGN !AS SYS$COMMAND"
cmdfmt:	.ascid	"$@ST_BIN:DODCL/OUT=!AS !AS"	; command format string
quotas:	.byte	pql$_astlm
	.long	10
	.byte	pql$_biolm
	.long	6
	.byte	pql$_bytlm
	.long	8192
	.byte	pql$_cpulm
	.long	0
	.byte	pql$_diolm
	.long	6
	.byte	pql$_fillm
	.long	15
	.byte	pql$_pgflquota
	.long	1024
	.byte	pql$_prclm
	.long	2
	.byte	pql$_tqelm
	.long	8
	.byte	pql$_wsdefault
	.long	300
	.byte	pql$_wsquota
	.long	750
	.byte	pql$_listend
	.page
	.sbttl	code
;
;	code
;
	.psect	st_pure_code	rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long
	.entry	system	^m<r2,r3,r4,r5>
	tstw	trmchn			; initialized yet?
	beql	1$			; NO
	brw	10$			; continue
1$:
	$getjpi_s itmlst=jpilst		; fetch pid, base_prio and priv_mask
	blbs	r0,2$			; lbs => success
	brw	5$			; error
2$:
	movl	#8,dumdsc		; prepare descriptor for fao
	movab	pidbuf,dumdsc+4		; ...
	$fao_s	ctrstr=pidfmt,outbuf=dumdsc,p1=pid	; format pid
	blbs	r0,3$			; lbs => success
	brw	5$			; error
3$:
	movc3	#8,pidbuf,trmpid	; copy into name strings
	movc3	#8,pidbuf,argpid	; ...
	movc3	#8,pidbuf,prcpid	; ...
	$crembx_s ,trmchn,#100,,#0,,trmdsc ; create termination mailbox
	blbs	r0,6$			; lbs => success
	brw	5$			; error
6$:
	movl	#512,dumdsc		; prepare descriptor for getchn
	movab	buf,dumdsc+4		; ...
	$getchn_s trmchn,,dumdsc		; get channel information
	blbc	r0,4$			; lbc => error
	movw	buf+dib$w_unit,trmunt	; save unit number
	$trnlog_s tt,length,ttydsc	; translate TT
	movw	length,ttydsc		; copy length into descriptor
	cmpb	#^x1b,ttybuf		; process permanent file?
	bneq	12$			; NO
	addl2	#4,ttydsc+4		; revise descriptor for tty
	subl2	#4,ttydsc		; ...
12$:
	$getdev_s ttydsc,,dumdsc	; get device information
	blbc	r0,11$			; lbc => error, use nla0:
	bbs	#dev$v_trm,buf+dib$l_devchar,10$	; if term, OK
11$:
	movq	nldsc,ttydsc		; redefine tty to be null device
	brb	10$			; continue to hard stuff
4$:
	$dassgn_s trmchn			; deassign channel
5$:
	clrw	trmchn			; initialization not complete
	clrl	r0			; return(0)
	ret
10$:
	clrl	r0			; initialize length of buffer
	movl	buffer(ap),r1		; starting address
20$:
	tstb	(r1)+			; null character yet?
	beql	30$			; YES
	incl	r0			; increment length
	brb	20$			; try again
30$:
	movl	r0,cmddsc		; fill in command descriptor
	bneq	40$			; we have something to do
	brw	return_1		; null command => immediate success
40$:
	movl	buffer(ap),cmddsc+4	; complete command descriptor
	$crembx_s ,argchn,#512,,#0,,argdsc	; create argument mailbox
	blbs	r0,50$			; lbs => success
	brw	return_0		; error
50$:
	$creprc_s ,imgdsc,argdsc,nldsc,nldsc,authpr,quotas,prcdsc,prib,,trmunt
	blbs	r0,60$			; lbs => success
	$dassgn_s argchn		; deassign the channel
	brw	return_0		; error
60$:
	$output	argchn,#noverl,nover	; $ set noverify
	movl	#512,dumdsc		; initialize dummy descriptor
	movab	buf,dumdsc+4		; ...
	moval	ttydsc,r0		; fetch address of descriptor
	$fao_s	assfmt1,length,dumdsc,r0	; format string
	$output	argchn,length,buf	; $assign 'term' TT
	moval	ttydsc,r0		; fetch address of descriptor
	$fao_s	assfmt2,length,dumdsc,r0	; format string
	$output	argchn,length,buf	; $assign 'term' SYS$COMMAND
	moval	ttydsc,r0		; fetch address of descriptor
	moval	cmddsc,r1		; fetch address of descriptor
	$fao_s	cmdfmt,length,dumdsc,r0,r1	; format string
	$output	argchn,length,buf	; $@dodcl/out='term' 'command'
	$qiow_s	,argchn,#io$_writeof	; write EOF on mbox
	$dassgn_s argchn		; deassign channel
	$input	trmchn,#acc$k_termlen,trmsts	; read return message
	movl	trmsts+acc$l_finalsts,r1; fetch return status
	beql	return_1		; OK if status == 0
	blbs	r1,return_1		; OK if low bit set
return_0:
	clrl	r0			; return(0)
	ret
return_1:
	movl	#1,r0			; return(1)
	ret
	.end