X-NEWS: acfclu vmsnet.sources: 460
Xref: cmcl2 comp.os.vms:114571 vmsnet.sources:460
Path: cmcl2!hsdndev!wuarchive!gumby!peirce
From: peirce@gumby.cc.wmich.edu (Leonard Peirce)
Newsgroups: comp.os.vms,vmsnet.sources
Subject: DISCONNECT_VT -- disconnect a virtual terminal (part 1 of 1)
Message-ID: <1991Mar8.235344.4042@gumby.cc.wmich.edu>
Date: 8 Mar 91 23:53:44 GMT
Organization: Western Michigan University Academic Computing Services
Lines: 492

NOTE:  I am posting this for a friend.  I didn't write it and I haven't tested
       it yet (although it looks like fun) so use it at your own risk.  I've
       included a small BUILD.COM to help build it but you're on your own if
       you use it.

       To build it, run the BUILD.COM to create DISCONNECT_VT.EXE.

       Like the others, there is no documentation included other than the
       source itself.

This article will self-destruct in 5 seconds....

--
Leonard Peirce                  Internet:  peirce@gumby.cc.wmich.edu
Western Michigan University                peirce@gw.wmich.edu
Academic Computing Services     UUCP:      ...!uunet!sharkey!wmichgw!peirce
Kalamazoo, MI  49008            Phone:     (616) 387-5469

==================================================================================

Finally something that might be of some use.  It was based on some
code that I originally wrote back in 1986.  The 1986 version of the
code appeared in the old hackers notes file.  It was originally
scheduled to be included in Phoenix AKA V6.0.  The routines will allow
you to disconnect a Virtual Terminal (VT).  If the device is not
connected to a VT it forces a hangup.  In either case it is cleaner
that deleting a process.

    Forrest


$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 7.2-007  22-FEB-1990
$!   On  8-MAR-1991 18:00:35.15   By user PEIRCE 
$!
$! This VMS_SHARE Written by:
$!    Andy Harper, Kings College London UK
$!
$! Acknowledgements to:
$!    James Gray       - Original VMS_SHARE
$!    Michael Bednarek - Original Concept and implementation
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. BUILD.COM;11
$!       2. DISCONNECT_VT.FOR;1
$!       3. IOC_JACKET.MAR;1
$!
$set="set"
$set symbol/scope=(nolocal,noglobal)
$f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
$e="write sys$error  ""%UNPACK"", "
$w="write sys$output ""%UNPACK"", "
$ if f$trnlnm("SHARE_LOG") then $ w = "!"
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$UNPACK: SUBROUTINE ! P1=filename, P2=checksum
$ if f$search(P1) .eqs. "" then $ goto file_absent
$ e "-W-EXISTS, File ''P1' exists. Skipped."
$ delete 'f'*
$ exit
$file_absent:
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'."
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
$ delete 'f'*
$ exit
$dirok:
$ w "-I-PROCESS, Processing file ''P1'."
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
"output_file"));ENDPROCEDURE;Unpacker;QUIT;
$ delete/nolog 'f'*
$ CHECKSUM 'P1'
$ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
$ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ ENDSUBROUTINE
$START:
$ create 'f'
X$ FORTRAN DISCONNECT_VT.FOR
X$ MACRO IOC_JACKET.MAR
X$ LINK DISCONNECT_VT,IOC_JACKET,SYS$SYSTEM:SYS.STB/SELECT,SYS$INPUT:/OPT
XSYS$SHARE:VAXCRTL/SHARE
X$ exit
$ CALL UNPACK BUILD.COM;11 2013407687
$ create 'f'
XC`09disconnect_vt -- disconnect a virtual terminal (VT)
X
X`09character`09dev_name *20
X
X`09integer`09*4`09name_len
X`09integer`09*4`09ret_stat
X
X`09external`09unlink_vt
X`09integer`09*4`09unlink_vt
X
X`09do while (.true.)
X
X`09`09write (6, fmt='(''$enter device name: '')')
X`09`09read (5, fmt='(q,a)',end=100,err=200) name_len, dev_name(:name_len)
X`09`09ret_stat = unlink_vt (dev_name(1:name_len))
X`09`09write (6, fmt='(''/ status is:'', z8, /)') ret_stat
X
X`09enddo
X
X100`09stop`09'That''s all folks'
X200`09stop`09'Read error'
X   `20
X`09end
$ CALL UNPACK DISCONNECT_VT.FOR;1 1243219772
$ create 'f'
X`09.TITLE`09IOC_JACKET Jacket code to test new IOC$HANGUP_TT
X`09.IDENT`09/V1.1-000/
X`09.LIBRARY /SYS$LIBRARY:LIB.MLB/
X
X
X;++
X;
X;`09`09This is a test jacket program to test the new IOC$HANGUP_TT,`20
X;`09and IOC$
X;
X;`09NOTE:
X;`09`09The required prive to use this are:
X;
X;`09`09`091) PHY_IO
X;`09`09`092) CMKRNL
X;`09`09`093) WORLD
X;`09`09`094) OPER
X;`09`09`095) PSWAPM
X;`09`09`096) SYSPRV not explicity checked for
X;`09`09`097) SHARE not explicitly checked for
X;
X; CALLING SEQUENCE:
X;
X;`09ret_stat = UNLINK_VT (device_name)
X;
X;`09device_name`09-`09address of a string descriptor, the string must
X;`09`09`09`09contain name of VT to be disconnected (ex VTA0:)
X;
X; AUTHOR:
X;
X;`09Forrest A. Kenney`0928-August-1986
X;
X; REVISION HISTORY:
X;
X;`09X.X`09XXXNNN`09XX-XXX-XXXX
X;`09`09Reason
X;
X;--
X`0C
X`09.SBTTL`09External and local symbol definitions
X
X;
X; External symbols
X;
X
X`09$CCBDEF`09`09`09`09; Define CCB
X`09$DVIDEF`09`09`09`09; Device information
X`09$IOCDEF`09`09`09`09; Define IOC$SEARCH flags
X`09$IPLDEF`09`09`09`09; Define various CPU IPL levels
X`09$JPIDEF`09`09`09`09; Process information
X`09$PRVDEF`09`09`09`09; Process privilege definitions
X`09$SPLCODDEF`09`09`09; SMP code definitions
X`09$SSDEF`09`09`09`09; System status codes
X`09$UCBDEF`09`09`09`09; Unit control block
X`09$TTYDEFS`09`09`09; TTY specific definitions
X`09$TTYMACS`09`09`09; Define terminal macros
X`09$TTYUCBDEF`09`09`09; TTY UCB definitions
X
X
X;+
X; A simple macro to help build item list items
X;-
X  `09.MACRO`09ITEM`09LENGTH,CODE,BUFF_ADDR,RET_LEN=0
X
X`09.WORD`09`09LENGTH
X`09.WORD`09`09CODE
X`09.ADDRESS`09BUFF_ADDR
X`09.ADDRESS`09RET_LEN
X
X`09.ENDM`09ITEM
X`0C
X`09.SBTTL`09Allocate local storage
X
X
X`09.PSECT`09$DATA`09LONG,NOEXE,RD,WRT
X
XDEVNAM:`09.BLKB`0964`09`09`09; Block hold PHYDEV name`20
X`09DEVNAM_LEN = .-DEVNAM
XDEVNAM_SIZ:`09`09`09`09; Storage for length of PHYDEV name
X`09.LONG`090
X
XDISC_FLAG:`09`09`09`09; Is device disconnectable
X`09.LONG`090
X
XCHANNEL:
X`09.WORD`090`09`09`09; Channel number for assign
XIOSB:`09.BLKW`094`09`09`09; IOSB for $GETJPI & $GETDVI
X
XPROCPRIV:`09`09`09`09; QAUDWORD to hold process priv. mask
X`09.QUAD`090
X
X
XLOCK_ADDRS:
X`09.ADDRESS`09BEGIN_KRNL_CODE
X`09.ADDRESS`09END_KRNL_CODE
X
XJPILST:`09ITEM`098,JPI$_CURPRIV,PROCPRIV
X`09.LONG`090
X`0C
X`09.PSECT`09$CODE`09LONG,PIC,NOWRT,RD,EXE,CON,REL,LCL,SHR
X`09.SBTTL`09Validate device & request
X;+
X;
X;`09`09This routine will validate the the device to be disconnected is a`20
X;`09virtual terminal and the the user has the correct privs to do it.  The p
Vrocess`20
X;`09sequence is listed below:
X;
X;`09`091) Assign a channel to the device
X;`09`092) Validate privs
X;`09`093) Calls KERNEL mode routine (to get UCB addres and disconnect it)
X;
X;`09INPUTS:
X;`09`094(AP)`09- Address of a descriptor containing device name
X;`09`098(AP)`09- Unlink or disconnect flag
X;
X;`09OUTPUT:
X;`09`09R0`09- Status of operation
X;
X;`09`09`09`09SS$_IVDEVNAM
X;`09`09`09`09SS$_NOPRIV
X;`09`09`09`09any possible returns from $ASSIGN, or $GETJPI
X;
X;-
X
X`09.ENTRY`09UNLINK_VT,`5EM<>
X
X;+
X; Get a channel to work with
X;-
X`09CLRQ`09-(SP)`09`09`09; Default acmode & no mailbox
X`09MOVAW`09CHANNEL,-(SP)`09`09; Address of word to hold channel #
X`09MOVL`094(AP),-(SP)`09`09; Address of device name string
X`09CALLS`09#4,G`5ESYS$ASSIGN`09`09; Assign channel
X`09BLBS`09R0,50$`09`09`09; Success continue
X`09RET`09`09`09`09; Failed return with reason
X
X;+
X; Now lets find out if the call has needed privs
X;-
X50$:`09$GETJPIW_S`09IOSB=IOSB,-`09; Get process priv mask
X`09`09`09ITMLST=JPILST`09;
X`09BLBS`09R0,60$`09`09`09; If setup ok cont
X`09PUSHL`09R0`09`09`09; Save failure reason
X`09BRW`091000$`09`09`09; Branch to exit code
X60$:`09BLBS`09IOSB,70$`09`09; If got info cont
X`09MOVZWL`09IOSB,-(SP)`09`09; Save error reason
X`09BRW`091000$`09`09`09; Branch to exit code
X
X`09ASSUME`09PRV$V_CMKRNL LE 32`09; Make sure privs we care
X`09ASSUME`09PRV$V_PHY_IO LE 32`09; about are in 1st longword
X`09ASSUME`09PRV$V_WORLD  LE 32`09;
X`09ASSUME`09PRV$V_OPER   LE 32`09;
X`09ASSUME`09PRV$V_PSWAPM LE 32`09;
X
X70$:`09BICL2`09#`5EC<PRV$M_CMKRNL!-`09; Get just the PRIV bits we want
X`09`09    PRV$M_PHY_IO!-`09;
X`09`09    PRV$M_WORLD!-`09;
X`09`09    PRV$M_OPER!-`09;
X`09`09    PRV$M_PSWAPM>,PROCPRIV ;
X`09CMPL`09#<PRV$M_CMKRNL!-`09; Do we have right privs
X`09`09  PRV$M_PHY_IO!-`09;
X`09`09  PRV$M_WORLD!-`09`09;
X`09`09  PRV$M_OPER!-`09`09;
X`09`09  PRV$M_PSWAPM>,PROCPRIV ;
X`09BEQL`0980$`09`09`09; Ok continue
X`09MOVZWL`09#SS$_NOPRIV,-(SP)`09; Save error reason
X`09BRW`091000$`09`09`09; Branch to exit code
X
X;+
X; Lock down the KERNEL mode code`20
X;-
X80$:`09$LCKPAG_S`09`09-`09; Lock KRNL_CODE into memory
X`09`09INADR=LOCK_ADDRS`09;`20
X`09BLBS`09R0,90$`09`09`09; Success continue
X`09PUSHL`09R0`09`09`09; Save error status
X`09BRW`091000$`09`09`09; Error exit
X
X;+
X; Now build arg list & call Kernel mode routine
X;-
X90$:
X`09MOVL`09AP,-(SP)`09`09; Store argument list on stack
X`09MOVAL`09KRNL_CODE,-(SP)`09`09; Store address of Kernel routine on stack
X`09CALLS`09#2,SYS$CMKRNL`09`09; Invoke kernel mode routine
X`09PUSHL`09R0`09`09`09; Save status reason
X;+
X; Unlock the KERNEL mode code
X;-
X`09$ULKPAG_S`09`09-`09; Unlock KRNL_CODE
X`09`09INADR=LOCK_ADDRS`09;`20
X`09BLBS`09R0,1000$`09`09; Worked then continue
X`09BLBC`09(SP),1000$`09`09; Error unlinking use it
X`09MOVL`09R0,(SP)`09`09`09; Save $ULKPAG error`20
X
X;+
X; We have a channel to free before exiting
X;-
X1000$:`09$DASSGN_S`09CHAN=CHANNEL`09; Free channel
X`09BLBS`09R0,1010$`09`09; Ok just exit with correct reason
X`09MOVL`09R0,R1`09`09`09; Save channel DASSGN error`20
X`09POPL`09R0`09`09`09; Get previous status code
X`09BLBC`09R0,1020$`09`09; Use first error
X`09MOVL`09R0,R1`09`09`09; Use DASSGN error
X`09RET`09`09`09`09; Return
X1010$:`09POPL`09R0`09`09`09; Restore reason
X1020$:`09RET`09`09`09`09; Return to caller
X
X`0C
X;+
X; This section of code needs to run at elevalted IPL to prevent process
X; deletion while owning I/O database MUTEX.  It also will use a backdoor
X; hook into the TTDRIVER to UNLINK the VT.
X;
X;`09Note:`09R4 contains the current processes PCB address it is suppiled by
X;`09`09the change mode dispatcher.  It is needed by SCH$IOLOCKR &`20
X;`09`09SCH$IOUNLOCK
X;
X;-
XBEGIN_KRNL_CODE:
X
X`09.ENTRY`09KRNL_CODE,`5EM<R3,R5>
X`09JSB`09G`5ESCH$IOLOCKR`09`09; Lock the I/O database for read access
X`09MOVL`094(AP),R1`09`09; Store device name
X`09TSTL`098(AP)`09`09`09; See if unlink or hangup
X`09BEQL`0910$`09`09`09; EQL unlink`20
X`09JSB`09IOC$HANGUP_TT`09`09; hangup terminal`20
X`09BRB`0920$`09`09`09; Go to common exit code
X
X10$:`09JSB`09IOC$DISCONNECT_VT`09; Disconnect VT
X
X20$:`09PUSHL`09R0`09`09`09; Save reason
X`09JSB`09G`5ESCH$IOUNLOCK`09`09; Unlock I/O database`20
X`09POPL`09R0`09`09`09; Restore reason
X`09RET
X`0C
X;++
X;
X; IOC$HANGUP_TT - Hangup terminal.
X; IOC$DISCONNECT_VT - Disconnect VT if disconnectable otherwise exit
X;
X; This routine will use the terminal class driver disconnect code to force
X; a either a terminal hangup, or a Virtual terminal to be disconnected.  If
V you
X; use IOC$HANGUP_TT entry point and the device is disconnectable it will not
V be
X; hungup, instead it will be disconnected.
X;
X; INPUTS:
X;`09R1 = Address of descriptor of device / logical name string
X;`09I/O database mutex held, IPL 2
X;
X; OUTPUTS:
X;`09R0 = SS$_NORMAL - Device disconnect or hungup depending upon entry point
X;          = SS$_ACCVIO - name string is not readable
X;          = SS$_NONLOCAL - nonlocal device
X;          = SS$_IVLOGNAM - invalid logical name (e.g., too long)
X;          = SS$_TOOMANYLNAM - max. logical name recursion exceeded
X;          = SS$_IVDEVNAM - device cannot be disconnected
X;`09`09`09  - disconnect requested and device is already disconnected
X;`09`09`09  - disconnect requested and device is not disconnectable`20
X;`09`09`09  - device is not owned and cannot be disconnected
X;          = SS$_NOSUCHDEV - device not found
X;          = SS$_NODEVAVL - device exists but not available according to rul
Ves
X;          = SS$_DEVALLOC - device allocated to other user
X;          = SS$_NOPRIV - failed device protection
X;          = SS$_TEMPLATEDEV - can't allocate template device
X;          = SS$_DEVMOUNT - device already mounted
X;          = SS$_DEVOFFLINE - device marked offline
X;`09R1-R11 PRSERVED
X;
X;`09IOC$HANGUP_TT`09R4 = 0
X;
X;`09IOC$UNLINK_VT`09R4 = 1
X;
X; Note:`09This code relies on the fact that TTDRIVER is supposed to copy
X;`09the DLCK from the PHYUCB to the LOGUCB when it creates or relinks
X;`09a LOGUCB.  If that changes this will crash with a spinlock error.
X;
X;--
XIOC$HANGUP_TT:`09`09`09`09; Terminal hangup entry point
X`09PUSHR`09#`5EM<R1,R2,R3,R4,R5>`09; Save registers used by operatio
X`09CLRL`09R4`09`09`09; Hangup if device not disconnectable
X`09BRB`09IOC$HANGUP_COMMON`09; GOTO common code
X
XIOC$DISCONNECT_VT:`09`09`09; Disconnect VT entry point
X`09PUSHR`09#`5EM<R1,R2,R3,R4,R5>`09; Save registers used by operatio
X`09MOVL`09#1,R4`09`09`09; Indicate hangup is to be performed
X
X
XIOC$HANGUP_COMMON:`09`09`09; Hangup up the guy
X`09MOVL`094(AP),R1`09`09; Get device descriptor string address
X`09CLRL`09R3`09`09`09; No lock value block
X`09MOVZBL`09#<IOC$M_ANY!`09-`09; Match any local device`20
X`09`09 IOC$M_LOCAL>,R2`09;
X`09JSB`09G`5EIOC$SEARCH`09`09; Now find the devices UCB
X`09CMPW`09R0,#SS$_NORMAL`09`09; Is device just free
X`09BEQL`0920$`09`09`09; NEQ no use this error
X`09MOVL`09#SS$_IVDEVNAM,R0`09; Signal device is illegal for request
X
X10$:
X`09POPR`09#`5EM<R1,R2,R3,R4,R5>`09; Restore registers exit
X`09RSB
X
X20$:
X`09MOVL`09#SS$_IVDEVNAM,R0`09; Assume device is not legal`20
X`09BBC`09#DEV$V_TRM,`09-`09; See if device is a terminal
X`09`09UCB$L_DEVCHAR(R1),10$`09;
X`09BBS`09#DEV$V_RTT,`09-`09; Is this a remote terminal
X`09`09UCB$L_DEVCHAR2(R1),10$`09;
X`09FORKLOCK LOCK=UCB$B_FLCK(R1),-`09; Take fork lock to prevent TTDRIVER
X`09`09SAVIPL=-(SP),`09-`09; from unlinking device for us
X`09`09PRESERVE=YES`09`09;
X`09BBC`09#0,R4,30$`09`09; Hangup case keep checking
X`09BBC`09#TT2$V_DISCONNECT, -`09; Is device disconnectable no, disconnect`20
X`09`09UCB$L_DEVDEPND2(R1),50$`09;  requested exit with error
X`09MOVL`09UCB$L_TL_PHYUCB(R1),R5`09; Get PHYUCB, and verify disconnect reque
Vst`20
X`09BNEQ`0940$`09`09`09; Linked go ahead and disconnect it
X`09BRB`0950$`09`09`09; Already disconnected just exit
X
X30$:`09`09`09`09`09; Verify HANGUP request
X`09MOVL`09UCB$L_TL_PHYUCB(R1),R5`09; Get physical UCB
X`09BNEQ`0940$`09`09`09; Have PHYUCB hangup it up
X`09BRB`0950$`09`09`09; Alread disconnected just exit
X
X40$:`09
X`09DEVICELOCK`09`09-`09; Take device lock TTDRIVER assumes it
X`09`09LOCKADDR=UCB$L_DLCK(R5), - ; is held
X`09`09LOCKIPL=UCB$B_DIPL(R5), -  ;
X`09`09SAVIPL=-(SP),`09-`09;
X`09`09PRESERVE=NO`09`09;
X`09MOVL`09UCB$L_TT_CLASS(R5),R4`09; Get class disptach table address
X`09JSB`09@CLASS_DISCONNECT(R4)`09; Now call disconnect code
X`09DEVICEUNLOCK`09`09-`09; RElease the device lock
X`09`09LOCKADDR=UCB$L_DLCK(R5), - ;
X`09`09NEWIPL=(SP)+,`09-`09;
X    `09`09CONDITION=RESTORE, -`09;
X`09`09PRESERVE=NO`09`09;
X`09MOVZWL`09#SS$_NORMAL,R0`09`09; Store success as exit reason
X
X50$:
X`09FORKUNLOCK `09`09-`09; Release fork lock so TTDRIVER`20
X`09`09LOCK=UCB$B_FLCK(R5), -  ; can run the disconnect fork
X`09`09NEWIPL=(SP)+,`09-`09;
X`09`09CONDITION=RESTORE, -`09;
X`09`09PRESERVE=YES`09`09;
X`09POPR`09#`5EM<R1,R2,R3,R4,R5>`09; Restore saved registers
X`09RSB`09`09`09`09; Exit
X
X
XEND_KRNL_CODE:
X
X`09.END
X
$ CALL UNPACK IOC_JACKET.MAR;1 561577522
$ v=f$verify(v)
$ EXIT