Program Become
	implicit none

	external set_logicals, LIB$M_CLI_CTRLY

	integer lusr
	character Usr*32, usrs*80
	character booger*80

	real*8 privs
	integer*4 uic
	character defdev*32, defdir*64, account*9, grp*6
	common /defs/ defdev, defdir, account, grp, uic, privs

*
	call jpi(Usr, lusr)
	open(1,shared,status='old',readonly,file='become.dat')
10	read(1,'(a)',end=20) usrs
	if (Usr(:8) .ne. Usrs(:8)) goto 10
	call chose(Usr, Usrs(10:))
	print *, Usr
	
	lusr = index(Usr,' ') - 1

	call uai(usr(:lusr))


	call LIB$DISABLE_CTRL(%loc(LIB$M_CLI_CTRLY),)	! Disable CTRL/Y
D	call snd('write accounting')
	call write_accounting(usr(:lusr))	! Write an accounting record
D	call snd('revokeid')
	call revokeid				! Revoke all the user's rights	    }
D	call snd('set_uic')
	call set_uic(uic)			! Set the new UIC
D	call snd('SET_TABLE_PROT')
	call SET_TABLE_PROT(UIC)		! Set protection on LNM$JOB
D	call snd('sys$setddir')
	call sys$setddir(defdir(2:),ichar(defdir(1:1)),)
D	call snd('cmexec - set_logicals')
	call sys$cmexec(set_logicals,)		! Set our new logicals
D	call snd('SET_USERNAME')
	call SET_USERNAME(%ref(USR(:LUSR)))	! Set the new username fields
D	call snd('SET_ACCOUNT')
	call SET_ACCOUNT(%ref(ACCOUNT))		! Set the new account data
D	call snd('set_process_name')
	call set_process_name(usr(:lusr))	! Set new process name
D	call snd('grantid')
	call grantid				! Grant new identifiers
D	call snd('set_privs')
	call set_privs(privs)			! Set the new user's privs
	call LIB$ENABLE_CTRL(%loc(LIB$M_CLI_CTRLY),)	! Re-enable control/y

20	call exit
	end

	subroutine chose(Usr,Usrs)
	implicit none
	character Usr*9, Usrs(8)*9
	include '($Smgdef)'
	integer stus, pas1, key1, dis1, n

	integer*4 Smg$Create_Pasteboard, Smg$Create_Virtual_Keyboard 
	integer*4 Smg$Create_Virtual_Display, Smg$Paste_Virtual_Display 
	integer*4 Smg$Create_Menu, Smg$Select_From_Menu, Smg$Delete_Menu 

	n = 0
10	if (Usrs(n+1) .ne. ' ') then
	  n = n + 1
	  if (n .lt. 8) goto 10
	endif

	if (n .gt. 1) then
	  call Smg$Create_Pasteboard (pas1)
	  call Smg$Create_Virtual_Keyboard (key1)
	  call Smg$Create_Virtual_Display (1, n*9+6, dis1, Smg$m_Border,
     1		Smg$m_Bold)
	  call Smg$Label_Border (dis1, ' User to Become ', Smg$k_Top)
	  call Smg$Paste_Virtual_Display (dis1, pas1, 2, 2)
	  call Smg$Create_Menu (dis1, Usrs, Smg$k_Horizontal, , ,
     1		Smg$m_Bold, Smg$m_Bold)
	  call Smg$Select_From_Menu (key1, dis1, n,,,,,, Usr)
	  call Smg$Delete_Menu (dis1)
	else
	  Usr = Usrs(1)
	endif
	return
	end

	subroutine jpi(Usr, lusr)
	implicit none

 	integer*4 lusr
	character Usr*(*)

	structure /itm_list/
	  integer buflen*2, item*2, addr*4, retlen*4
	end structure
	record /itm_list/ itm(6)

	external
     .	  ss$_normal
     .	, jpi$_master_pid, jpi$_pid, jpi$_prccnt
     .  , jpi$_username, jpi$_procpriv, jpi$_authpriv
*
	integer*4 stat, pid, master_pid, prccnt, sys$getjpiw

	itm(1).item = %loc(jpi$_master_pid)
	itm(1).addr = %loc(master_pid)
	itm(1).buflen = 4
	itm(1).retlen = 0
	itm(2).item = %loc(jpi$_pid)
	itm(2).addr = %loc(pid)
	itm(2).buflen = 4
	itm(2).retlen = 0
	itm(3).item = %loc(jpi$_prccnt)
	itm(3).addr = %loc(prccnt)
	itm(3).buflen = 4
	itm(3).retlen = 0
	itm(4).item = %loc(jpi$_username)
	itm(4).addr = %loc(Usr)
	itm(4).buflen = len(Usr)
	itm(4).retlen = %loc(lusr)
	itm(5).item = 0

	stat = sys$getjpiw(,,,itm,,,)
	if (stat .ne. %loc(ss$_normal)) stop 
	if (pid .ne. master_pid) stop
	if (prccnt .gt. 0) stop

	return
	end

	subroutine uai(Usr)
	implicit none

	real*8 privs
	integer*2 mem, grp
	character defdev*32, defdir*64, account*9, grps*6
	common /defs/ defdev, defdir, account, grps, mem, grp, privs

	character Usr*(*)

	structure /itm_list/
	  integer buflen*2, item*2, addr*4, retlen*4
	end structure
	record /itm_list/ itm(6)

	integer*4 stat, sys$getuai
	parameter uai$_defdev = 13,
     .		  uai$_defdir = 14,
     .		  uai$_account= 11,
     .		  uai$_uic    =  6,
     .		  uai$_priv   = 31

	itm(1).item = uai$_defdev
	itm(1).addr = %loc(defdev)
	itm(1).buflen = len(defdev)
	itm(1).retlen = 0
	itm(2).item = uai$_defdir
	itm(2).addr = %loc(defdir)
	itm(2).buflen = len(defdir)
	itm(2).retlen = 0
	itm(3).item = uai$_account
	itm(3).addr = %loc(account)
	itm(3).buflen = len(account)
	itm(3).retlen = 0
	itm(4).item = uai$_uic
	itm(4).addr = %loc(mem)
	itm(4).buflen = 4
	itm(4).retlen = 0
	itm(5).item = uai$_priv
	itm(5).addr = %loc(privs)
	itm(5).buflen = 8
	itm(5).retlen = 0
	itm(6).item = 0

	stat = sys$getuai(,,Usr,itm,,,)
	call sys$fao('!OW',,grps,%val(grp))
D	call snd(' uic - '//grps)

	return
	end

	subroutine Set_logicals
	implicit none

	external ss$_normal

	integer*4 stus, sys$crelnm, sys$dellnm
	character defdev*32, defdir*64, account*9, grp*6
	common /defs/ defdev, defdir, account, grp

	character strng*120

	integer*2 l
	character buf*256

	structure /itm_list/
	  integer buflen*2, item*2, addr*4, retlen*4
	end structure
	record /itm_list/ itm(2)

	parameter LNM$_STRING	=	2
	parameter PSL$C_EXEC	=	1
	parameter PSL$C_SUPER	=	2

	itm(1).retlen = 0
	itm(1).item   = Lnm$_string
	itm(2).item   = 0

D	call snd(' before dellnm') 
	stus = sys$dellnm('LNM$PROCESS', 'SYS$DISK', PSL$C_SUPER)

D	call snd(' before crelnm 1') 
	itm(1).buflen = ichar(defdev(1:1))
	itm(1).addr   = %loc(defdev(2:))
	stus = sys$crelnm(,'LNM$PROCESS', 'SYS$DISK', PSL$C_EXEC, itm)
	if (stus .ne. %loc(ss$_normal)) then
	  call sys$getmsg(%val(stus),l,buf,,)
	  call sys$fao('!ZL',,buf(l+1:),%val(stus))
D	  call snd(' - '//buf(:l+8))
	endif

D	call snd(' before crelnm 2') 
	stus = sys$crelnm(,'LNM$JOB', 'SYS$LOGIN_DEVICE', PSL$C_EXEC, itm)
	if (stus .ne. %loc(ss$_normal)) then
	  call sys$getmsg(%val(stus),l,buf,,)
	  call sys$fao('!ZL',,buf(l+1:),%val(stus))
D	  call snd(' - '//buf(:l+8))
	endif

D	call snd(' before crelnm 3') 
	itm(1).buflen = ichar(defdev(1:1)) + ichar(defdir(1:1))
	itm(1).addr   = %loc(strng)
	strng = defdev(2:ichar(defdev(1:1))+1)// defdir(2:ichar(defdir(1:1))+1) 
	stus = sys$crelnm(,'LNM$JOB', 'SYS$LOGIN', PSL$C_EXEC, itm)
	if (stus .ne. %loc(ss$_normal)) then
	  call sys$getmsg(%val(stus),l,buf,,)
	  call sys$fao('!ZL',,buf(l+1:),%val(stus))
D	  call snd(' - '//buf(:l+8))
	endif

D	call snd(' before crelnm 4') 
	stus = sys$crelnm(,'LNM$JOB', 'SYS$SCRATCH', PSL$C_EXEC, itm)
	if (stus .ne. %loc(ss$_normal)) then
	  call sys$getmsg(%val(stus),l,buf,,)
	  call sys$fao('!ZL',,buf(l+1:),%val(stus))
D	  call snd(' - '//buf(:l+8))
	endif

D	call snd(' before crelnm 5-'//grp) 
	itm(1).buflen = 16
	strng = 'LNM$GROUP_' //grp	
	stus = sys$crelnm(,'LNM$PROCESS_DIRECTORY', 'LNM$GROUP', PSL$C_EXEC, 
	1	itm)
	if (stus .ne. %loc(ss$_normal)) then
	  call sys$getmsg(%val(stus),l,buf,,)
	  call sys$fao('!ZL',,buf(l+1:),%val(stus))
D	  call snd(' - '//buf(:l+8))
	endif

	return
	end


	integer function getuic()
	implicit none
	
	structure /itm_list/
	  integer buflen*2, item*2, addr*4, retlen*4
	end structure
	record /itm_list/ itm(2)

	external ss$_normal, jpi$_uic
	integer*4 stat, uic, sys$getjpiw

	itm(1).item = %loc(jpi$_uic)
	itm(1).addr = %loc(uic)
	itm(1).buflen = 4
	itm(1).retlen = 0
	itm(2).item = 0

	stat = sys$getjpiw(,,,itm,,,)
	if (stat .ne. %loc(ss$_normal)) stop 
	getuic = uic

	return
	end

	subroutine Revokeid
	implicit none

	structure /quad/
	  integer*4 l0, l1
	end structure
	record /quad/ holder, id
	external ss$_normal, ss$_nosuchid
	integer stat, cntxt, getuic
	integer sys$find_held, sys$revokid

	holder.l0 = getuic()
	holder.l1 = 0
	cntxt = 0
10	stat = sys$find_held(holder.l0, id.l0, id.l1, cntxt)
	if (stat .eq. %loc(ss$_normal)) then
	  stat = sys$revokid(,,id.l0,,)
	  if (mod(stat,2) .eq. 1) goto 10
	end if
	if (stat .ne. %loc(ss$_nosuchid)) call lib$stop(%val(stat))

	return
	end

	subroutine Grantid
	implicit none

	structure /quad/
	  integer*4 l0, l1
	end structure
	record /quad/ holder, id
	external ss$_normal, ss$_nosuchid
	integer stat, cntxt, getuic
	integer sys$find_held, sys$grantid

	holder.l0 = getuic()
	holder.l1 = 0
	cntxt = 0
10	stat = sys$find_held(holder.l0, id.l0, id.l1, cntxt)
	if (stat .eq. %loc(ss$_normal)) then
	  stat = sys$grantid(,,id.l0,,)
	  if (mod(stat,2) .eq. 1) goto 10
	end if
	if (stat .ne. %loc(ss$_nosuchid)) call lib$stop(%val(stat))

	return
	end

	subroutine Write_accounting(Usr)
	implicit none

	integer*4 Status, sys$sndjbc
	character Usr*(*), Acc_rec*30

	structure /itm_list/
	  integer buflen*2, item*2, addr*4, retlen*4
	end structure
	record /itm_list/ itm(2)

	parameter SJC$_WRITE_ACCOUNTING = 30
	parameter SJC$_ACCOUNTING_MESSAGE = 1

	itm(1).item = Sjc$_Accounting_message
	itm(1).addr = %loc(Acc_rec)
	itm(1).buflen = len(Acc_rec)
	itm(1).retlen = 0
	Itm(2).item = 0

	Acc_rec = '<Became user '//Usr//'>'

	Status = Sys$sndjbc(,%val(Sjc$_Write_Accounting),,itm,,,)
	if (mod(Status,2) .ne. 1) call Lib$signal(%val(Status))

	return
	end

	subroutine Set_process_name(Usr)
	implicit none

	character Usr*(*), Prcnam*15
	integer*4 l, stat, sys$trnlnm

	structure /itm_list/
	  integer buflen*2, item*2, addr*4, retlen*4
	end structure
	record /itm_list/ itm(2)

	parameter LNM$_STRING	=	2

	itm(1).item = Lnm$_string
	itm(1).addr = %loc(Prcnam)
	itm(1).buflen = Len(Prcnam)
	itm(1).retlen = 0
	itm(2).item = 0

	stat = sys$trnlnm(,'LNM$PROCESS','SYS$INPUT',,itm)
	if (mod(stat,2) .ne. 1) call lib$signal(%val(stat))

	l = index(prcnam,'$') + 1
	prcnam = prcnam(l:)
	l = index(prcnam,':')
	prcnam = Usr//'_'//prcnam(:l)

	call sys$setprn(prcnam)
	return
	end

C-   Routine to use sys$brkthru like send
	subroutine snd(msg)
	implicit none
	external ss$_normal
	integer BRK_DEV /1/

	integer*2 iosb(4)
	character usr*8, msg*(*)

c	call sys$brkthruw(,msg//char(13)//char(10),
c     .			   'tt:',%val(brk_dev),iosb,,,,%val(5),,)
c	if (iosb(1) .ne. %loc(ss$_normal)) call lib$signal(%val(iosb(1)))

	print *,msg
	return
	end