| Here is a complete FORCEX for you. This version logs use to the
console so you can tell who's been using it (we have it installed with WORLD
and OPER) and provides a full DCL command interface as follows:
The FORCEX command follows the syntax of the DCL STOP command.
FORCEX [/IDENTIFICATION=pid] [process-name]
Additional qualifiers:
/STATUS_CODE=code-in-hex status for target process
/CONFIRM ask before blowing away target
/LOG display same message to user as
is displayed on the console
Three files follow, FORCEX.CLD, FORCEX.FOR and LLEN.MAR. To build:
FORTRAN FORCEX
MACRO LLEN
LINK/NOTRACE FORCEX,LLEN
Move to SYS$SYSTEM and INSTALL w/ WORLD & OPER
SET COMMAND FORCEX or add to your DCLTABLES.
Questions or comments to ANYWAY::GORDON
--Doug
*****************************Cut*Here******************************************
! Make this FORCEX.CLD
!*****************************************************************************
! FORCEX.CLD Douglas A. Gordon
! Digital Equipment Corporation
! 8-Apr-1987
!
! C O P Y R I G H T
!
! (C) Copyright 1987
! Digital Equipment Corporation, Maynard, Massachusetts
!
! This software is furnished under a license for use only on
! a single computer system and may be copied only with the
! inclusion of the above copyright notice. This software,
! or any other copies thereof, may not be provided or
! otherwise made available to any other person except for
! use of such system and to one who agrees to these license
! terms. Title to and ownership of the software shall at all
! times remain in DIGITAL.
!
! The information in this software is subject to change
! without notice and should not be construed as a commitment
! by Digital Equipment Corporation.
!
! DIGITAL assumes no responsibility for the use or
! reliability of its software on equipment that is not
! supplied by DIGITAL.
!
!*****************************************************************************
define verb FORCEX
image "FORCEX"
parameter P1,
value
qualifier CODE,
value(required)
qualifier IDENTIFICATION,
value(required)
*****************************Cut*Here******************************************
* Make this FORCEX.FOR
program forcex
* Forcex: Douglas A. Gordon
* Digital Equipment Corporation
* 6-Apr-1987
* Last Revision Date: Mon 6-Apr-87 15:09
*
* Abstract:
*
* Execute the $FORCEX system service as a DCL command. Sends
* a message to the console when used.
*
* Enviroment:
*
* VAX VMS V4.5, native mode, privileged
*
* Privileges Required:
*
* This routine should be installed with WORLD and OPER
*
* Side Effects:
*
* If you FORCEX a process already at DCL, the next image run will
* abort immediately.
*
* Include Files Required:
*
* None.
*
* Data Files Used:
*
* None.
*
* Functions & Subroutines Called:
*
*
* Linking:
*
* LINK Forcex,llen
*
* Revision History:
*
* 27-Jan-1987 Updated to include console logging from old version
* I had around.
* 16-Jun-1987 Added /CONFIRM and /LOG
* 17-Jun-1987 Bug when /LOG without /CONFIRM
************************************************************************
*
* C O P Y R I G H T
*
* (C) Copyright 1987
* Digital Equipment Corporation, Maynard, Massachusetts
*
* This software is furnished under a license for use only on
* a single computer system and may be copied only with the
* inclusion of the above copyright notice. This software,
* or any other copies thereof, may not be provided or
* otherwise made available to any other person except for
* use of such system and to one who agrees to these license
* terms. Title to and ownership of the software shall at all
* times remain in DIGITAL.
*
* The information in this software is subject to change
* without notice and should not be construed as a commitment
* by Digital Equipment Corporation.
*
* DIGITAL assumes no responsibility for the use or
* reliability of its software on equipment that is not
* supplied by DIGITAL.
*
************************************************************************
*
implicit integer*4 (a - z)
character proc_name*15, buffer*32, message*512, ans*1
character*1 cr/13/, lf/10/
*
* This is a FORTRAN structure declaration for the VMS
* data type "item_list_3"
*
structure /item_list_3/
union
map
integer*2 len ! buffer length
integer*2 code ! item code
integer*4 addr ! buffer address
integer*4 rla ! returned length address
end map
map
integer*4 end_list ! end of list
end map
end union
end structure
integer*4 sys$getjpiw, stat, jpi_iosb(2)
record /item_list_3/ jpibuf(5)
integer*4 target_pid
integer*2 target_pid_len
character target_user*12
integer*2 target_user_len
character this_user*12
integer*2 this_user_len
character target_image*252
integer*2 target_image_len
character target_process*15
integer*2 target_process_len
character this_process*15
integer*2 this_process_len
include '($jpidef)'
*
* Get info about the caller for the console log
*
jpibuf(1).len = 15
jpibuf(1).code = jpi$_prcnam
jpibuf(1).addr = %loc(this_process)
jpibuf(1).rla = %loc(this_process_len)
jpibuf(2).len = 12
jpibuf(2).code = jpi$_username
jpibuf(2).addr = %loc(this_user)
jpibuf(2).rla = %loc(this_user_len)
jpibuf(3).end_list = jpi$c_listend ! end of request
stat = sys$getjpiw(, , , jpibuf, jpi_iosb, ,)
if(.not. stat) call lib$signal(%val(stat))
*
* Now reuse some of the list to get info about the target
*
jpibuf(1).addr = %loc(target_process)
jpibuf(1).rla = %loc(target_process_len)
jpibuf(2).addr = %loc(target_user)
jpibuf(2).rla = %loc(target_user_len)
jpibuf(3).len = 4
jpibuf(3).code = jpi$_pid
jpibuf(3).addr = %loc(target_pid)
jpibuf(3).rla = %loc(target_pid_len)
jpibuf(4).len = 252
jpibuf(4).code = jpi$_imagname
jpibuf(4).addr = %loc(target_image)
jpibuf(4).rla = %loc(target_image_len)
jpibuf(5).end_list = jpi$c_listend ! end of request
if(cli$present('STATUS_CODE')) then ! did they give us a status?
stat = cli$get_value('STATUS_CODE', buffer)
if(.not. stat) call lib$stop(%val(stat))
stat = ots$cvt_tz_l(buffer(1:llen(buffer)), code,
& %val(4), %val(1))
if(.not. stat) call lib$stop(%val(stat))
else ! nope - use success
code = 1
endif
if(cli$present('IDENTIFICATION')) then ! did they say /ID=?
stat = cli$get_value('IDENTIFICATION', buffer)
if(.not. stat) call lib$stop(%val(stat))
stat = ots$cvt_tz_l(buffer(1:llen(buffer)), pid,
& %val(4), %val(1))
stat = sys$getjpiw(, pid, , jpibuf, jpi_iosb, ,)
if(.not. stat) call lib$signal(%val(stat))
else ! ... nope - try process name
stat = cli$get_value('P1', proc_name)
stat = sys$getjpiw(, , proc_name(1:llen(proc_name)), jpibuf,
& jpi_iosb, ,)
if(.not. stat) call lib$signal(%val(stat))
endif
if(llen(target_image) .eq. 0) target_image = '(DCL)'
open(unit=13,file='sys$output',status='unknown',recl=512)
if(cli$present('CONFIRM')) then
open(unit=15,file='sys$command',status='unknown',readonly)
ans = 'X'
do while (ans .ne. 'Y' .and. ans .ne. 'N')
10 write(13,20) target_process,
& target_user(1:llen(target_user)), target_pid,
& target_image(1:llen(target_image))
20 format(1x,a,' (',a,') ',z8.8,1x,a,/,' Forcex? [N]: ',$)
read(15,30,end=900,err=10) ans
30 format(a)
if(ans .eq. ' ') ans = 'N'
call str$upcase(ans, ans)
end do
if(ans .eq. 'N') goto 900
endif
write(message, 40) this_process, this_user(1:llen(this_user)),
& cr, lf, target_process,
& target_user(1:llen(target_user)), cr, lf, target_pid,
& cr, lf, target_image(1:llen(target_image)), cr, lf, code
40 format('User ',A,' (',A,
& ') forced exit on the following process:',A,A,
& 'Process: ',A,' (',A,')',A,A,'PID: ',
& z8.8,A,A,'Image: ',A,A,A,'Status: ',z8.8)
stat = send_oper(message)
if(.not. stat) call lib$stop(%val(stat))
if(cli$present('LOG')) write(13,50) message(1:llen(message))
50 format(/1x,a)
stat = sys$forcex(pid, , %val(code))
if(.not. stat) call lib$stop(%val(stat))
900 end
********************************************************************
********************************************************************
integer*4 function send_oper(message)
* Send_Oper: Douglas A. Gordon
*
* Abstract:
*
* Routine to send a message to the operator.
*
* Calling Sequence:
*
* Ret-Stat.wlc.v = Send_Oper( Message.rt.dx )
*
* Formal Parameters:
*
* Message Passed length character string containing the
* message to be sent to the operator. Passed
* by descriptor.
*
* Return Status:
*
* Any status returned by SYS$SNDOPR.
*
* Implicit Inputs:
*
* None.
*
* Implicit Outputs:
*
* Message to operator.
*
* Side Effects:
*
* None.
*
* Functions & Subroutines Called:
*
* I*4 SYS$SNDOPR VAX System Service
*
* Revision History:
*
*
implicit integer*4 (a - z)
include 'sys$library:forsysdef.tlb($opcdef)'
byte opc_type(2)
integer*4 request(2), target, text_len
character message*(*)
character op_msg*256, text*248
equivalence (opc_type, request, op_msg)
equivalence (opc_type(2), target)
equivalence (op_msg(9:), text)
opc_type(1) = opc$_rq_rqst ! it's a request
target = opc$m_nm_centrl
request(2) = 0
text = message
call str$trim(text, text, text_len)
send_oper = sys$sndopr(op_msg(:text_len+8), )
return
end
*****************************Cut*Here******************************************
; Make this LLEN.MAR
;---------------------------------------------------------------
.title LLEN - Significant length of a string
.ident \1-004\
; Douglas A. Gordon
;
;-----------------------------------------------------------------------------
;
; C O P Y R I G H T
;
; (C) Copyright 1986,1987
; Digital Equipment Corporation, Maynard, Massachusetts
;
; This software is furnished under a license for use only on
; a single computer system and may be copied only with the
; inclusion of the above copyright notice. This software,
; or any other copies thereof, may not be provided or
; otherwise made available to any other person except for
; use of such system and to one who agrees to these license
; terms. Title to and ownership of the software shall at all
; times remain in DIGITAL.
;
; The information in this software is subject to change
; without notice and should not be construed as a commitment
; by Digital Equipment Corporation.
;
; DIGITAL assumes no responsibility for the use or
; reliability of its software on equipment that is not
; supplied by DIGITAL.
;
;-----------------------------------------------------------------------------
; Last Revision Date: Thu 22-May-86 15:14
;
; Functional Description:
;
; This procedure finds the significant length of a string, that
; is, excluding trailing white space, where white space is
; defined as spaces, tabs, or nulls
;
; Enviroment:
;
; VAX native mode, nonprivileged. CALLS, CALLG, JSB [LLEN_R2]
;
; Calling Sequence:
;
; length.wl.v = LLEN(string.r.dx)
;
; JSB LLEN_R2 (descriptor in R0, R1)
;
; Formal Parameters:
;
; string Input string. Passed by descriptor.
;
; Value Returned:
;
; length Significant length of the input string. Passed by value.
;
; Implicit Inputs:
;
; None.
;
; Implicit Outputs:
;
; None.
;
; Side Effects:
;
; None.
;
; Revision History:
;
; \1-002\ 20-May-1985 DAG - Added JSB entry point. Completed
; documentation.
; \1-003\ 24-Jun-1985 DAG - Added Routine macro for psect
; compatibility.
; \1-004\ 22-May-1986 DAG - Silly me - fixed JSB entry point.
;
.page
;
; Macros
;
;---------------------------------------------------------------
; Routine name, <registers>
;---------------------------------------------------------------
.macro routine name, mask
.show meb
.psect _code, pic, usr, con, rel, lcl, shr, exe, rd, nowrt
.entry name, ^m<mask>
.noshow meb
.endm routine
;
; Symbol definitions
;
str_dsc = 4
;
; Executable code
;
routine llen, <r2>
movq @str_dsc(ap), r0 ; R0<15:0>=len, R1=adr of string
jsb llen_R2 ; do the work
ret ; go away...
llen_R2:: ; JSB entry point LLEN_R2
movzwl r0, r2 ; length in r2 as counter
10$: beql 20$ ; length is zero or str_dsc exhausted
cmpb -1(r2)[r1], #32 ; is it a blank?
beql 15$ ; yup - skip it.
cmpb -1(r2)[r1], #9 ; or perhaps a tab?
beql 15$ ; if so, skip it.
cmpb -1(r2)[r1], #0 ; or just a lowly null?
bneq 20$ ; nope - success
15$: decl r2 ; backup one character
brb 10$ ; and try again
20$: movl r2, r0 ; return the length
rsb ; back from whence we came
.end
|
| RE :- .1
Here's one in ADA. If you (or anyone else) need more I've got several
others written in other languages as well. If you're interested then
send a mail to OSL03::TORE or 50.331::TORE
Here it comes.....
-- ++
--
-- ABSTRACT:
--
-- This program displays information about interactive
-- processes by issuing a call ty $GETJPIW. It can then
-- optionally delete either the image in the process by
-- issuing a call ty $FORCEX or the process itself by
-- means of the $DELPRC system service. The user will
-- be prompted for his/her choice.
--
-- AUTHOR:
--
-- Tore Ottem EDUS NWO
--
-- CREATION DATE:
--
-- 2-JUL-1986
--
-- --
--
-- Include the usual things like systemservices,
-- VMS datatypes and so on and so forth..
--
with STARLET; use STARLET;
with SYSTEM; use SYSTEM;
with CONDITION_HANDLING; use CONDITION_HANDLING;
with TEXT_IO; use TEXT_IO;
with INTEGER_TEXT_IO; use INTEGER_TEXT_IO;
procedure KILL is
--
-- Declare record to hold necessary info about the
-- process.
--
type PROC_INFO is
record
PID : PROCESS_ID_TYPE; -- Process ID
PROCNAME : PROCESS_NAME_TYPE(1..15); -- Process name
IMAGE : STRING(1..39); -- Image in process
TERMINAL : DEVICE_NAME_TYPE(1..7); -- Attached terminal
TLENGTH,ILENGTH,PLENGTH : UNSIGNED_WORD; -- Length of strings
end record;
ITEM_LIST : ITEM_LIST_TYPE(1..6); -- Itemlist with 6 elements
PROCESS : array (1..72) of PROC_INFO; -- Array of processrecords
WILDPID : PROCESS_ID_TYPE := -1; -- Wildcard PID
ITEM_END : ITEM_REC_TYPE -- Itemlist terminator
:= (0,0,ADDRESS_ZERO,ADDRESS_ZERO);
RETSTAT : COND_VALUE_TYPE; -- VMS return status
REPLY : CHARACTER; -- Answer control
PIDNR : PROCESS_ID_TYPE; -- Process ID
PROCNAM : PROCESS_NAME_TYPE(1..15); -- Process name
NAME_LEN : UNSIGNED_WORD; -- Length of name
IMAGENAME : STRING(1..39); -- Image in process
IMAGE_LEN : UNSIGNED_WORD; -- Length of imagename
TERMDEVIC : DEVICE_NAME_TYPE(1..7); -- Terminal devicename
TERM_LEN : UNSIGNED_WORD; -- Length of terminalname
MODE,I : INTEGER; -- Processtype and counter
--
-- Procedure to pad output strings with blanks to get
-- nice output.
--
procedure PAD_BLANKS ( ACTUAL_LEN : in INTEGER; MAX_LEN : in INTEGER ) is
begin
for I in 1..(MAX_LEN - ACTUAL_LEN) loop -- Calculate remaining space
PUT(" "); -- in string and fill this
end loop; -- space with blanks.....
PUT(" ");
end PAD_BLANKS;
--
-- Procedure to delete the entire process.
--
procedure KILL_PROCESS ( PID_NUM : in out PROCESS_ID_TYPE ) is
STAT : COND_VALUE_TYPE;
begin
DELPRC ( STATUS => STAT, -- Delete process with specified
PIDADR => PID_NUM ); -- Process ID
if not SUCCESS( STAT ) then -- Exit if failure
STOP( STAT );
end if;
end KILL_PROCESS;
--
-- Procedure to force imageexit on a procedure. The procedure
-- calls $FORCEX and exits the image in the process determined
-- by the PIDnr. The image exits with an exitstatus of 1.
--
procedure KILL_IMAGE ( PID_NUM : in out PROCESS_ID_TYPE ) is
STAT : COND_VALUE_TYPE;
EXCD : UNSIGNED_LONGWORD := 1; -- Exitstatus
begin
FORCEX ( STATUS => STAT, -- Returnstatus
PIDADR => PID_NUM, -- Pid of process
CODE => EXCD ); -- EXIT status
if not SUCCESS( STAT ) then -- Exit if failure
STOP( STAT );
end if;
end KILL_IMAGE;
begin
--
-- Itemlist to obtain the desired information
-- from $GETJPIW.
--
ITEM_LIST := (
1 => ( ITEM_CODE => JPI_TERMINAL, -- Treminal name
BUF_LEN => 7, -- Maxlength of data
BUF_ADDRESS => TERMDEVIC'ADDRESS, -- Buffer to recieve data
RET_ADDRESS => TERM_LEN'ADDRESS ), -- Length of data returned
2 => ( ITEM_CODE => JPI_PRCNAM, -- Process name
BUF_LEN => 15, -- Maxlength of data
BUF_ADDRESS => PROCNAM'ADDRESS, -- Buffer to recieve data
RET_ADDRESS => NAME_LEN'ADDRESS ), -- Length of returned data
3 => ( ITEM_CODE => JPI_PID, -- Process ID
BUF_LEN => 4, -- MAX length of data
BUF_ADDRESS => PIDNR'ADDRESS, -- Buffer to recieve data
RET_ADDRESS => ADDRESS_ZERO ),
4 => ( ITEM_CODE => JPI_IMAGNAME, -- Image in process
BUF_LEN => 39, -- Maxlength of data
BUF_ADDRESS => IMAGENAME'ADDRESS, -- Buffer to recieve data
RET_ADDRESS => IMAGE_LEN'ADDRESS ),-- Length of returned data
5 => ( ITEM_CODE => JPI_MODE, -- Process type
BUF_LEN => 4, -- Max length of data
BUF_ADDRESS => MODE'ADDRESS, -- Buffer to recieve data
RET_ADDRESS => ADDRESS_ZERO ),
6 => ITEM_END ); -- Itemlist terminator
--
-- Set RETSTAT to success to enter loop first time.
-- Set counter I to 1.
RETSTAT := SS_NORMAL;
I := 1;
--
-- Loop through all processes on the system and select only
-- those with MODE = 3 that is interactive processes.
-- The loop will execute while RETSTAT contains a success
-- status. Exit from loop when RETSTAT is SS$_NOMOREPROC or
-- another nonsuccess status.
-- The loop will terminate on any nonsuccess condition
-- This should be handled in an exceptionhandler
--
while SUCCESS( RETSTAT ) loop
GETJPIW ( STATUS => RETSTAT,
PIDADR => WILDPID,
ITMLST => ITEM_LIST );
--
-- Check to see if process interactive. If yes fill in
-- the information in the record PROCESS.
--
if MODE = 3 then
PROCESS(I).TERMINAL := TERMDEVIC; -- Terminal name
PROCESS(I).TLENGTH := TERM_LEN; -- Length of this
PROCESS(I).PID := PIDNR; -- Process ID
PROCESS(I).PROCNAME := PROCNAM; -- Process name
PROCESS(I).PLENGTH := NAME_LEN; -- Length of name
PROCESS(I).IMAGE := IMAGENAME; -- Imagename
PROCESS(I).ILENGTH := IMAGE_LEN; -- Length of name
--
-- Increment interactive process counter and continue
--
I := I + 1;
end if;
end loop;
--
-- Display all information on screen
--
for N in 1..(I-1) loop
PUT(N,WIDTH => 2); PUT(" ");
PUT(PROCESS(N).PROCNAME);
PAD_BLANKS(INTEGER(PROCESS(N).PLENGTH),15);
PUT(PROCESS(N).IMAGE);
PAD_BLANKS(INTEGER(PROCESS(N).ILENGTH),39);
PUT(PROCESS(N).TERMINAL);
NEW_LINE;
end loop;
--
-- Do we need to take action against processes. User
-- is asked yes or no. If yes the user will be prompted
-- whether he wants to force an exit on the process image
-- or delete the process....
--
NEW_LINE;
PUT("* AFFECT PROCESS (Y,N) ? "); GET(REPLY);
if REPLY = 'Y' or REPLY = 'y' then
PUT_LINE(" 'P' Delete Process..");
PUT_LINE(" 'I' Delete Image....");
PUT("? "); GET(REPLY);
--
-- Kill image in process and exit from program
--
if REPLY = 'I' or REPLY = 'i'then
PUT("INDEX: "); GET(I);
KILL_IMAGE(PROCESS(I).PID);
end if;
--
-- Kill process and exit from program
--
if REPLY = 'P' or REPLY = 'p'then
PUT("INDEX: "); GET(I);
KILL_PROCESS(PROCESS(I).PID);
end if;
--
-- Leave process unaffected and intact
--
else
null;
end if;
end KILL; -- **** That's it **** --
|