$! ................... Cut between dotted lines and save. ...................
$!...........................................................................
$! VAX/VMS archive file created by VMS_SHARE V06.10 7-FEB-1989.
$!
$! VMS_SHARE was written by James Gray (Gray:OSBUSouth@Xerox.COM) from
$! VMS_SHAR by Michael Bednarek (U3369429@ucsvc.dn.mu.oz.au).
$!
$! To unpack, simply save, concatinate all parts into one file and
$! execute (@) that file.
$!
$! This archive was created by user TNIELAND
$! on  2-JUN-1989 14:13:22.95.
$!
$! It contains the following 8 files:
$!        AAAREADME.1ST
$!        BECOME.COM
$!        BECOME.PAS
$!        BECOMECLD.CLD
$!        BECOMEMSG.MSG
$!        BECOMESUB.MAR
$!        BECOMESUBS.MAR
$!        SEG.MAR
$!
$!============================================================================
$ SET SYMBOL/SCOPE=( NOLOCAL, NOGLOBAL )
$ VERSION = F$GETSYI( "VERSION" )
$ IF VERSION .GES "V4.4" THEN GOTO VERSION_OK
$ WRITE SYS$OUTPUT "You are running VMS ''VERSION'; ", -
    "VMS_SHARE V06.10 7-FEB-1989 requires VMS V4.4 or higher."
$ EXIT 44 ! SS$_ABORT
$VERSION_OK:
$ GOTO START
$!
$UNPACK_FILE:
$ WRITE SYS$OUTPUT "Creating ''FILE_IS'"
$ DEFINE/USER_MODE SYS$OUTPUT NL:
$ EDIT/TPU/COMMAND=SYS$INPUT/NODISPLAY/OUTPUT='FILE_IS'/NOSECTION -
    VMS_SHARE_DUMMY.DUMMY
b_part := CREATE_BUFFER( "{Part}", GET_INFO( COMMAND_LINE, "file_name" ) )
; s_file_spec := GET_INFO( COMMAND_LINE, "output_file" ); SET( OUTPUT_FILE
, b_part, s_file_spec ); b_errors := CREATE_BUFFER( "{Errors}" ); i_errors 
:= 0; pat_beg_1 := ANCHOR & "-+-+-+ Beginning"; pat_beg_2 := LINE_BEGIN 
& "+-+-+-+ Beginning"; pat_end := ANCHOR & "+-+-+-+-+ End"; POSITION
( BEGINNING_OF( b_part ) ); LOOP EXITIF SEARCH( SPAN( ' ' )@r_trail 
& LINE_END, FORWARD) = 0; POSITION( r_trail ); ERASE( r_trail ); ENDLOOP
; POSITION( BEGINNING_OF( b_part ) ); i_append_line := 0; LOOP EXITIF MARK
( NONE ) = END_OF( b_part ); s_x := ERASE_CHARACTER( 1 )
; IF s_x = '+' THEN r_skip := SEARCH( pat_beg_1, FORWARD, EXACT ); IF r_skip 
<> 0 THEN s_x := ''; MOVE_HORIZONTAL( -CURRENT_OFFSET ); ERASE_LINE; ENDIF
; ENDIF; IF s_x = '-' THEN r_skip := SEARCH( pat_end, FORWARD, EXACT )
; IF r_skip <> 0 THEN s_x := ''; MOVE_HORIZONTAL( -CURRENT_OFFSET ); m_skip 
:= MARK( NONE ); r_skip := SEARCH( pat_beg_2, FORWARD, EXACT ); IF r_skip 
<> 0 THEN POSITION( END_OF( r_skip ) ); MOVE_HORIZONTAL( -CURRENT_OFFSET )
; MOVE_VERTICAL( 1 ); MOVE_HORIZONTAL( -1 ); ELSE POSITION( END_OF( b_part ) 
); ENDIF; ERASE( CREATE_RANGE( m_skip, MARK( NONE ), NONE ) ); ENDIF; ENDIF
; IF s_x = 'V' THEN s_x := ''; IF i_append_line <> 0 THEN APPEND_LINE
; MOVE_HORIZONTAL( -CURRENT_OFFSET ); ENDIF; i_append_line := 1
; MOVE_VERTICAL( 1 ); ENDIF; IF s_x = 'X' THEN s_x := ''; IF i_append_line 
<> 0 THEN APPEND_LINE; MOVE_HORIZONTAL( -CURRENT_OFFSET ); ENDIF
; i_append_line := 0; MOVE_VERTICAL( 1 ); ENDIF; IF s_x <> '' THEN i_errors 
:= i_errors + 1; s_text := CURRENT_LINE; POSITION( b_errors ); COPY_TEXT
( "The following line could not be unpacked properly:" ); SPLIT_LINE
; COPY_TEXT( s_x ); COPY_TEXT( s_text ); POSITION( b_part ); MOVE_VERTICAL
( 1 ); ENDIF; ENDLOOP; POSITION( BEGINNING_OF( b_part ) ); LOOP r_x := SEARCH
( "`", FORWARD, EXACT ); EXITIF r_x = 0; POSITION( r_x ); ERASE_CHARACTER( 1 
); COPY_TEXT( ASCII( INT( ERASE_CHARACTER( 3 ) ) ) ); ENDLOOP
; IF i_errors = 0 THEN SET( NO_WRITE, b_errors, ON ); ELSE POSITION
( BEGINNING_OF( b_errors ) ); COPY_TEXT( FAO
( "The following !UL errors were detected while unpacking !AS", i_errors
, s_file_spec ) ); SPLIT_LINE; SET( OUTPUT_FILE, b_errors, "SYS$COMMAND" )
; ENDIF; EXIT; 
$ DELETE VMS_SHARE_DUMMY.DUMMY;*
$ CHECKSUM 'FILE_IS
$ WRITE SYS$OUTPUT " CHECKSUM ", -
  F$ELEMENT( CHECKSUM_IS .EQ. CHECKSUM$CHECKSUM, ",", "failed!!,passed." )
$ RETURN
$!
$START: 
$ FILE_IS = "AAAREADME.1ST"
$ CHECKSUM_IS = 1513604716
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
XThis program when used as a foreign command allows a suitably privileged user
Vto "BECOME" another user.  This program sets the following process parameters
X:`032
X
X`009UIC
X`009DEFAULT DEVICE & DIRECTORY
X`009PROCESS NAME
X`009USERNAME
X`009ACCOUNT NAME
X`009PROCESS PRIVS
X`009GROUP LOGICAL NAME TABLE LNM$GROUP
X`009RIGHTS from RIGHTSLIST.DAT
X
XNote that BECOME does not change the process's limits or quotas nor does it
Vexecute the target user's LOGIN.COM file.  BECOME does not touch the authoriz
Xed
Xprivilege mask so that once you become another user, you can still become
Xyourself again.`032
X
XThis submission is V1.6 of BECOME which has had several modifications and
Xbug fixes made in it.  Please read the header comments in the PASCAL & MACRO
Xsources to find out what's been changed.
X
XAny questions or comments should be directed to:
X
X`009Eric Wentz
X`009General Electric Co.
X`009Nela Park Noble Rd #1782.00
X`009Cleveland, Ohio 44112
X`009(216)266-2382
X
XTo install BECOME do the following.
X
X$ MESSAGE BECOMEMSG
X$ SET COMMAND/OBJECT BECOMECLD
X$ MACRO BECOMESUB
X$ PASCAL BECOME
X$ LINK BECOME,BECOMESUB,BECOMEMSG,BECOMECLD
X$ COPY BECOME.EXE SYS$COMMON:[SYSEXE]
X
XIn your LOGIN.COM file put:
X
X$ BECOME :== $BECOME
X
XNote that if you do not have a Pascal compiler,  the object module
XBECOME.OBJ has been included.  If you do intend to recompile the source,
Xyou must first compile the Pascal environment files in the directory
Xpointed to by the PASCAL$ENVIRONMENT logical name.  The sources for
Xthese environment files are included in another directory of this submission.
$ GOSUB UNPACK_FILE

$ FILE_IS = "BECOME.COM"
$ CHECKSUM_IS = 1736079423
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
Xbecome,becomesub,becomemsg,becomecld
$ GOSUB UNPACK_FILE

$ FILE_IS = "BECOME.PAS"
$ CHECKSUM_IS = 1279087546
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
V[IDENT('V1.8'),`009`009    `123 Update this with the version constant below `
X125
XINHERIT ('SYS$LIBRARY:STARLET.PEN')]
XPROGRAM BECOME(OUTPUT);
X
X`123 This program when used as a foreign command allows a suitably priviliged
X  user to "BECOME" another user.  This program sets the following process
X  parameters:
X
X`009UIC
X`009DEFAULT DEVICE & DIRECTORY
X`009PROCESS NAME
X`009USERNAME
X`009ACCOUNT NAME
X`009PROCESS PRIVS
X`009GROUP LOGICAL NAME TABLE LNM$GROUP
X`009RIGHTS from RIGHTSLIST.DAT
X
XNote that BECOME does not change the process's limits or quotas.
X
XAuthor: Eric Wentz 1-May-1985 General Electric Co., Cleveland Ohio`032
V-----------------------------------------------------------------------------
X---
XModification history:
XVersion 1.1 added these logical names:
X`009Eric Wentz 9-Sep-1985
X`009Changed logical name handling and add the three names
X`009SYS$LOGIN logical name
X`009SYS$LOGIN_DEVICE logical name
X`009SYS$SCRATCH logical name
XVersion 1.2
X`009Eric Wentz 26-Sep-1985
X`009Set the owner of the logical name table to be the same
X`009as the new user
XVersion 1.3
X`009Eric Wentz 20-Mar-1986
X`009Modified so that when you become a new user, you get all their
X`009`009rights as defined by the rightslist database.
X`009Changed process name to be more consistent with the way
X`009`009in which VMS handles duplicate process names.
X`009Added sanity check so you can't BECOME another user if you're
X`009`009in a sub-process or you own any subprocesses.
X`009Moved all messages to a message file.
X`009Added in the code to change the account name.
X`009Disable `094Y during the actual kernel changes.
X
XVersion 1.4
X`009Eric Wentz 17-May-1986
X`009Fixed the way process names were passed to VMS so that
X`009they wouldn't have trailing spaces.
X`009Changed UAF access to use the $GETUAI system service
X
XVersion 1.5 24-Nov-1986 Eric Wentz
X`009Fixed bug which caused the program not to exit if the user
X`009owened a sub-process.
X
XVersion 1.6 8-Feb-1987 Eric Wentz
X`009Added CLI parsing to the command string so we can support command
X`009qualifiers.
X`009Added the /VERSION qualifier to show the current version of BECOME
X
XVersion 1.7 10-Jun-1987 Eric Wentz
X`009Added accounting records so we can track who became who and when.
X
XVersion 1.8 04-Dec-1987 Eric Wentz
X`009Made necessary changes for VMS V5.x
V-----------------------------------------------------------------------------
X--`125
XCONST
V    VER_STRING = 'V1.8';`009`009    `123 Update with version in the header`12
X5
X
XTYPE
X    UBYTE`009    = [BYTE] 0..255;
X    UWORD`009    = [WORD] 0..65535;
X    UQUAD`009    = [QUAD,UNSAFE] RECORD L0,L1:UNSIGNED;END;
X    USERNAME_TYPE   = PACKED ARRAY [1..12] OF CHAR;
X    ACCOUNT_TYPE    = PACKED ARRAY [1..8] OF CHAR;
X
X    ITEM_LIST_TYPE = RECORD
X`009BUFFER_LENGTH`009: UWORD;
X`009ITEM_CODE`009: UWORD;
X`009BUFFER_ADDRESS`009: UNSIGNED;
X`009RETURN_LEN_ADDR`009: UNSIGNED;
X`009END;
X
X    UIC_TYPE = RECORD CASE INTEGER OF
X    1:(UIC  : INTEGER);
X    2:(MEMBER`009: UWORD;
X       GROUP`009: UWORD);
X       END;
X    VARY16 = RECORD
X`009LENGTH`009: UBYTE;
X`009BODY`009: PACKED ARRAY [1..16] OF CHAR;
X`009END;
X    VARY64 = RECORD
X`009LENGTH`009: UBYTE;
X`009BODY`009: PACKED ARRAY [1..64] OF CHAR;
X`009END;
X
X
X(********** Define the variables used by the program ************)
X
XVAR
X    ISTAT`009: [VOLATILE] INTEGER;
X    NEW_USERNAME: USERNAME_TYPE;
X    SETUP_PRIVS`009: UQUAD:=0;
X    IDENTIFIER`009: UQUAD;
X    CONTEXT`009: UNSIGNED;
X    HOLDER`009: UQUAD;
X    ERRMSG`009: VARYING[255] OF CHAR;
X    JPI_LIST`009: ARRAY [1..2] OF ITEM_LIST_TYPE:=
X`009`009((4,JPI$_UIC,0,0),(0,0,0,0));
X`123
XLocal storage for $GETUAI items (from UAF file)
X`125
X    DEFDEV`009: [VOLATILE] VARY16;
X    DEFDIR`009: [VOLATILE] VARY64;
X    UIC`009`009: [VOLATILE] UIC_TYPE;
X    ACCOUNT`009: ACCOUNT_TYPE;
X    PRIV`009: [QUAD] PRV$TYPE;
X    GETUAI_LIST`009: ARRAY [1..7] OF ITEM_LIST_TYPE:=ZERO;
X`123
XDefine the variables for the message numbers
X`125
X    BECOME_NOINSUB,
X    BECOME_NOSUB,
X    BECOME_UAFNOTFOU,
X    BECOME_VERSION,
X    BECOME_BECAME,
X    BECOME_NOUSER`009: [EXTERNAL,VALUE] INTEGER;
X
X    COMMAND_STRING : VARYING [80] OF CHAR;
V    BECOMECLD : [EXTERNAL,VALUE] INTEGER;`009`123 Parsing tables for CLI    `
X125
X
X(******** Functions that reside in BECOMESUB.MAR ************)
X
XPROCEDURE SET_UIC`009(VAR UIC`009: [VOLATILE] UIC_TYPE);`009EXTERNAL;
XPROCEDURE SET_USERNAME`009(VAR USERNAME`009: USERNAME_TYPE);`009EXTERNAL;
XPROCEDURE SET_ACCOUNT`009(VAR ACCOUNT`009: ACCOUNT_TYPE);`009EXTERNAL;
XPROCEDURE SET_PRIVS`009(VAR PRIVS`009: [QUAD] PRV$TYPE);`009EXTERNAL;
VFUNCTION SET_TABLE_PROT(VAR UIC`009: [VOLATILE]UIC_TYPE):INTEGER;`009EXTERNAL
X;
X
X
V(****************************************************************************
X**)
V(***************   Define RTL routines  *************************************
X**)
V(****************************************************************************
X**)
X
X[ASYNCHRONOUS] PROCEDURE LIB$STOP
X  (%IMMED Cond_Value :INTEGER);EXTERNAL;
X
XFUNCTION LIB$GET_FOREIGN(
X`009var get_str : [CLASS_S] PACKED ARRAY
X`009[$L1..$U1:INTEGER] OF CHAR;
X`009var user_prompt : [CLASS_S,READONLY] PACKED ARRAY
X`009[$L2..$U2:INTEGER] OF CHAR := %IMMED 0;
X`009var out_len : UWORD := %IMMED 0;
X`009var force_prompt : [CLASS_S,READONLY] PACKED ARRAY
X`009[$L3..$U3:INTEGER] OF CHAR := %IMMED 0):integer; external;
X
XPROCEDURE LIB$PUT_OUTPUT(
V    VAR STR : [READONLY,CLASS_S] PACKED ARRAY [A..B:INTEGER] OF CHAR);EXTERNA
XL;
X
XPROCEDURE LIB$ENABLE_CTRL(
X`009VAR ENABLE_MSK : [READONLY] UNSIGNED);EXTERNAL;
X
XPROCEDURE LIB$DISABLE_CTRL(
X`009VAR DISABLE_MSK : [READONLY] UNSIGNED);EXTERNAL;
X
X`123 Somebody blew it, this should be defined in STARLET !! `125
X[ASYNCHRONOUS,EXTERNAL(SYS$SETDDIR)]
XFUNCTION $SETDDIR(
V    VAR NEW_DIR_ADDR : [READONLY,CLASS_S] PACKED ARRAY [A..B:INTEGER] OF CHAR
X;
X    VAR LENGTH_ADDR : UWORD := %IMMED 0;
X    VAR CUR_DIR_ADDR : [CLASS_S] PACKED ARRAY
X`009[C..D:INTEGER] OF CHAR := %IMMED 0):INTEGER;EXTERNAL;
X
XVAR`009`009    `123 Define CLI utility conditions `125
X  CLI$_NOCOMD,
X  CLI$_INVROUT,
X  CLI$_COMMA,
X  CLI$_CONCAT,
X  CLI$_ABSENT,
X  CLI$_PRESENT,
X  CLI$_NEGATED,
X  CLI$_LOCPRES,
X  CLI$_DEFAULTED    : [EXTERNAL,VALUE] INTEGER;
X
XFunction CLI$DCL_PARSE(
X`009var command_string  : [CLASS_S,READONLY] PACKED ARRAY
X`009`009[$L1..$U1:INTEGER] OF CHAR;
X`009%immed table`009    : [READONLY] INTEGER;
X`009%immed [UNBOUND] procedure param_routine := %immed 0;
X`009%immed [UNBOUND] procedure prompt_routine := %immed 0;
X`009var prompt_string   : [CLASS_S,READONLY] PACKED ARRAY
X`009`009[$L2..$U2:INTEGER] OF CHAR:=%IMMED 0):INTEGER; EXTERNAL;
X
XFunction CLI$GET_VALUE(
X`009var entity_desc`009    : [CLASS_S,READONLY] PACKED ARRAY
X`009`009[$L1..$U1:INTEGER] OF CHAR;
X`009var retdesc`009    : [CLASS_S] PACKED ARRAY
X`009`009[$L2..$U2:INTEGER] OF CHAR;
X`009var retlength`009    : UWORD :=%IMMED 0):INTEGER;EXTERNAL;
X
XFunction CLI$PRESENT(
X`009var entity_desc`009    : [CLASS_S,READONLY] PACKED ARRAY
X`009`009[$L1..$U1:INTEGER] OF CHAR):INTEGER;EXTERNAL;
X
X
X(*********** Local functions to this program **************)
X
X[ASYNCHRONOUS] PROCEDURE SET_LOGICAL(
X`009TABLE      : [READONLY] PACKED ARRAY [$L1..$U1:INTEGER] OF CHAR;
X`009LOG_NAME   : [READONLY] PACKED ARRAY [$L2..$U2:INTEGER] OF CHAR;
X`009VALUE      : [READONLY] PACKED ARRAY [$L3..$U3:INTEGER] OF CHAR;
X`009ACCESS_MODE: UBYTE);
XVAR
X    ITEM_LIST : ARRAY [1..2] OF ITEM_LIST_TYPE;
X
XBEGIN
X    ITEM_LIST := ZERO;
X    WITH ITEM_LIST[1] DO
X    BEGIN
X`009BUFFER_LENGTH`009:= $U3;
X`009ITEM_CODE`009:= LNM$_STRING;
X`009BUFFER_ADDRESS`009:= IADDRESS(VALUE);
X`009END;
X
X    ISTAT := $CRELNM(`009TABNAM := TABLE,
X`009`009`009LOGNAM := LOG_NAME,
X`009`009`009ACMODE := ACCESS_MODE,
X`009`009`009ITMLST := ITEM_LIST);
X    END;
X
X(******* Executive mode routine to set logical names ******)
X
X[ASYNCHRONOUS] PROCEDURE SET_LOGICALS;
X
XVAR
X  GROUP_TABLE : [VOLATILE] VARYING[16] OF CHAR;
X
XBEGIN
X    $DELLNM(`009`009`009`009    `123 Delete any old SYS$DISK`009    `125
X`009TABNAM`009:= 'LNM$PROCESS',
X`009LOGNAM`009:= 'SYS$DISK',
X`009ACMODE`009:= PSL$C_SUPER);
X    SET_LOGICAL(`009`009`009    `123 Create new SYS$DISK`009    `125
X`009TABLE      := 'LNM$PROCESS',
X`009LOG_NAME   := 'SYS$DISK',
X`009VALUE      := SUBSTR(DEFDEV.BODY,1,DEFDEV.LENGTH),
X`009ACCESS_MODE:= PSL$C_EXEC);
X    SET_LOGICAL(
X`009TABLE      := 'LNM$JOB',
X`009LOG_NAME   := 'SYS$LOGIN_DEVICE',
X`009VALUE      := SUBSTR(DEFDEV.BODY,1,DEFDEV.LENGTH),
X`009ACCESS_MODE:= PSL$C_EXEC);
X    SET_LOGICAL(
X`009TABLE      := 'LNM$JOB',
X`009LOG_NAME   := 'SYS$LOGIN',
X`009VALUE      := SUBSTR(DEFDEV.BODY,1,DEFDEV.LENGTH)+
X`009`009      SUBSTR(DEFDIR.BODY,1,DEFDIR.LENGTH),
X`009ACCESS_MODE:= PSL$C_EXEC);
X    SET_LOGICAL(
X`009TABLE      := 'LNM$JOB',
X`009LOG_NAME   := 'SYS$SCRATCH',
X`009VALUE      := SUBSTR(DEFDEV.BODY,1,DEFDEV.LENGTH)+
X`009`009      SUBSTR(DEFDIR.BODY,1,DEFDIR.LENGTH),
X`009ACCESS_MODE:= PSL$C_EXEC);
X
X    WRITEV(GROUP_TABLE,'LNM$GROUP_',OCT(UIC.GROUP,6));
X    SET_LOGICAL(
X`009TABLE      := 'LNM$PROCESS_DIRECTORY',
X`009LOG_NAME   := 'LNM$GROUP',
X`009VALUE      := SUBSTR(GROUP_TABLE.BODY,1,GROUP_TABLE.LENGTH),
X`009ACCESS_MODE:= PSL$C_EXEC);
X    END;
V(****************************************************************************
X**)
XPROCEDURE GRANTID;
XBEGIN
X`123
XGet the current UIC
X`125
X    JPI_LIST[1].BUFFER_ADDRESS := IADDRESS(HOLDER.L0);
X    ISTAT := $GETJPI(ITMLST:=JPI_LIST);
X    IF NOT ODD(ISTAT) THEN LIB$STOP(ISTAT);
X
X    HOLDER.L1 := 0;
X    CONTEXT := 0;
X`123
XNow scan the rightslist database and grant all identifiers
Xwhich are to be held by this user
X`125
X    WHILE ODD(ISTAT) DO
X    BEGIN
X`009ISTAT := $FIND_HELD(
X`009    HOLDER`009:= HOLDER,
X`009    ID`009:= IDENTIFIER.L0,
X`009    ATTRIB`009:= IDENTIFIER.L1,
X`009    CONTXT`009:= CONTEXT);
X`009IF ODD(ISTAT) THEN ISTAT := $GRANTID(ID:=IDENTIFIER)
X`009END;
X
X    IF ISTAT <> SS$_NOSUCHID THEN LIB$STOP(ISTAT);
X    END;
X
V(****************************************************************************
X**)
XPROCEDURE REVOKEID;
XBEGIN
X`123
XGet the current UIC
X`125
X    JPI_LIST[1].BUFFER_ADDRESS := IADDRESS(HOLDER.L0);
X    ISTAT := $GETJPI(ITMLST:=JPI_LIST);
X    IF NOT ODD(ISTAT) THEN LIB$STOP(ISTAT);
X
X    HOLDER.L1 := 0;
X    CONTEXT := 0;
X`123
XNow scan the rightslist database and revoke all identifiers held
Xby this user
X`125
X    WHILE ODD(ISTAT) DO
X    BEGIN
X`009ISTAT := $FIND_HELD(
X`009    HOLDER`009:= HOLDER,
X`009    ID`009:= IDENTIFIER.L0,
X`009    ATTRIB`009:= IDENTIFIER.L1,
X`009    CONTXT`009:= CONTEXT);
X`009IF ODD(ISTAT) THEN ISTAT := $REVOKID(ID:=IDENTIFIER)
X`009END;
X
X    IF ISTAT <> SS$_NOSUCHID THEN LIB$STOP(ISTAT);
X    END;
X
V(****************************************************************************
X**)
XPROCEDURE SET_PROCESS_NAME(USERNAME : USERNAME_TYPE);
XVAR
X    TERMINAL_NAME : PACKED ARRAY [1..30] OF CHAR;
X    LNM_ITMLST : ARRAY [1..2] OF ITEM_LIST_TYPE;
X    I : INTEGER;
X
XFUNCTION EOS(VAR STR : [READONLY] PACKED ARRAY`032
X    [A..B:INTEGER] OF CHAR):INTEGER;
XVAR
X    PTR : INTEGER;
X    TMP : INTEGER;
XBEGIN
X    FOR PTR := A TO B DO IF STR[PTR] <> ' ' THEN TMP := PTR;
X    EOS := TMP;
X    END;
X
XBEGIN
X    WITH LNM_ITMLST[1] DO
X    BEGIN
X`009BUFFER_LENGTH`009:= SIZE(TERMINAL_NAME);
X`009ITEM_CODE`009:= LNM$_STRING;
X`009BUFFER_ADDRESS`009:= IADDRESS(TERMINAL_NAME);
X`009RETURN_LEN_ADDR := 0;
X`009END;
X    LNM_ITMLST[2].ITEM_CODE := 0;
X    TERMINAL_NAME := ' ';
X
X    ISTAT := $TRNLNM(TABNAM := 'LNM$PROCESS',
X`009`009     LOGNAM := 'SYS$INPUT',
X`009`009     ITMLST := LNM_ITMLST);
X    IF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
X    TERMINAL_NAME := SUBSTR(TERMINAL_NAME,5,SIZE(TERMINAL_NAME) - 4);
X    I := INDEX(TERMINAL_NAME,'$');
X    IF I <> 0 THEN
X`009TERMINAL_NAME := SUBSTR(TERMINAL_NAME,I+1,SIZE(TERMINAL_NAME) - I);
X    IF TERMINAL_NAME[1] = '_' THEN
X`009TERMINAL_NAME := SUBSTR(TERMINAL_NAME,2,SIZE(TERMINAL_NAME) - 1);
X    TERMINAL_NAME := '_' + SUBSTR(TERMINAL_NAME,1,SIZE(TERMINAL_NAME) - 1);
X    $SETPRN(SUBSTR(TERMINAL_NAME,1,EOS(TERMINAL_NAME)));
X    $SETPRN(SUBSTR(USERNAME,1,EOS(USERNAME)));
X    END;
V(****************************************************************************
X**)
XPROCEDURE SUB_PROCESS_CHECK;
XVAR
X    ITMLST`009: ARRAY [1..4] OF ITEM_LIST_TYPE;
X    MASTER_PID`009: INTEGER;
X    PID`009`009: INTEGER;
X    PRCCNT`009: INTEGER;
X   `032
XBEGIN
X    ITMLST := ZERO;
X    WITH ITMLST[1] DO
X    BEGIN
X`009BUFFER_LENGTH`009:= 4;
X`009ITEM_CODE`009:= JPI$_MASTER_PID;
X`009BUFFER_ADDRESS`009:= IADDRESS(MASTER_PID);
X`009END;
X    WITH ITMLST[2] DO
X    BEGIN
X`009BUFFER_LENGTH`009:= 4;
X`009ITEM_CODE`009:= JPI$_PID;
X`009BUFFER_ADDRESS`009:= IADDRESS(PID);
X`009END;
X    WITH ITMLST[3] DO
X    BEGIN
X`009BUFFER_LENGTH`009:= 4;
X`009ITEM_CODE`009:= JPI$_PRCCNT;
X`009BUFFER_ADDRESS`009:= IADDRESS(PRCCNT);
X`009END;
X    ISTAT := $GETJPI(ITMLST:=ITMLST);
X    IF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
X
X    IF PID <> MASTER_PID THEN
X    BEGIN
X`009ISTAT := $GETMSG(BECOME_NOINSUB,ERRMSG.LENGTH,ERRMSG.BODY);
X`009IF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
X`009WRITELN(ERRMSG);
X`009$EXIT(1);
X`009END;
X
X    IF PRCCNT > 0 THEN
X    BEGIN
X`009ISTAT := $GETMSG(BECOME_NOSUB,ERRMSG.LENGTH,ERRMSG.BODY);
X`009IF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
X`009WRITELN(ERRMSG);
X`009$EXIT(1);
X`009END;
X    END;
X
V(****************************************************************************
X**)
XPROCEDURE WRITE_ACCOUNTING;
XVAR
X    I,
X    STS`009`009    : INTEGER;
X    PARAMETERS`009    : ARRAY [0..1] OF INTEGER;
X    ITEM_LIST`009    : ARRAY [0..1] OF ITEM_LIST_TYPE;
X    ACCOUNTING_RECORD : PACKED ARRAY [1..255] OF CHAR;
XBEGIN
X`123
XInitialize the item list to zero
X`125
XITEM_LIST := ZERO;
XPARAMETERS := ZERO;
XPARAMETERS[1] := IADDRESS(NEW_USERNAME);
X`123
XGet the format of the accounting message
X`125
XISTAT := $GETMSG(BECOME_BECAME,ERRMSG.LENGTH,ERRMSG.BODY);
XIF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
X`123
XDetermine the length of the new username
X`125
XFOR I := 1 TO SIZE(NEW_USERNAME) DO
X    IF NEW_USERNAME[I] <> ' ' THEN PARAMETERS[0] := I;
X`123
XFormat the accounting record
X`125
XSTS := $FAOL(
X`009CTRSTR := SUBSTR( ERRMSG.BODY, 1, ERRMSG.LENGTH ),
X`009OUTLEN := ITEM_LIST[0].BUFFER_LENGTH,
X`009OUTBUF := ACCOUNTING_RECORD,
X`009PRMLST := PARAMETERS);
XIF NOT ODD(STS) THEN $EXIT(STS);
X`123
XInitialize the SNDSBC item list
X`125
XWITH ITEM_LIST[0] DO
X    BEGIN
X    ITEM_CODE`009    := SJC$_ACCOUNTING_MESSAGE;
X    BUFFER_ADDRESS  := IADDRESS(ACCOUNTING_RECORD);
X    END;
X`123
XWrite the accounting record
X`125
XSTS := $SNDJBC(FUNC:=SJC$_WRITE_ACCOUNTING,ITMLST:=ITEM_LIST);
XIF NOT ODD(STS) THEN $EXIT(CODE:=STS);
XEND;
X
X(************   Start of mainline program **************)
XBEGIN
X`123
XFirst try to set this process to have CMKRNL,CMEXEC & SYSPRV - If we can't
Xdo this, the user has no right to run the program
X`125
XSETUP_PRIVS::PRV$TYPE.PRV$V_CMKRNL := TRUE;
XSETUP_PRIVS::PRV$TYPE.PRV$V_CMEXEC := TRUE;
XSETUP_PRIVS::PRV$TYPE.PRV$V_SYSPRV := TRUE;
X
XISTAT := $SETPRV(
X`009ENBFLG`009:= 1,
X`009PRVADR`009:= SETUP_PRIVS);
XIF ISTAT = SS$_NOTALLPRIV THEN $EXIT(SS$_NOPRIV);
XIF NOT ODD (ISTAT) THEN $EXIT(ISTAT);
X`123
XNow get the command from DCL which returns the new username
X`125
XISTAT := LIB$GET_FOREIGN(
X`009    GET_STR`009:= COMMAND_STRING.BODY,
X`009    USER_PROMPT`009:= 'Username: ',
X`009    OUT_LEN     := COMMAND_STRING.LENGTH);
XIF NOT ODD (ISTAT) THEN
X    IF ISTAT = RMS$_EOF THEN
X`009$EXIT(1) ELSE
X`009$EXIT(ISTAT);
X
XISTAT := CLI$DCL_PARSE(
X    'BECOME ' + SUBSTR(COMMAND_STRING.BODY,1,COMMAND_STRING.LENGTH),
X    %IMMED BECOMECLD);
XIF NOT ODD(ISTAT) THEN $EXIT;
X
XIF ODD(CLI$PRESENT('VERSION')) THEN
X    BEGIN
X    ISTAT := $GETMSG(BECOME_VERSION,ERRMSG.LENGTH,ERRMSG.BODY);
X    IF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
X    ERRMSG := ERRMSG + VER_STRING;
X    WRITELN(ERRMSG);
X    $EXIT;
X    END;
X
XISTAT := CLI$GET_VALUE('P1',NEW_USERNAME);
XIF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
X
X`123
XCheck to see if the user is in a subprocess or owns any subprocesses
X`125
XSUB_PROCESS_CHECK;
X`123
XNow set up the item list for the $GETUAI system service
X`125
XWITH GETUAI_LIST[1] DO
XBEGIN
X    BUFFER_LENGTH   := SIZE(DEFDEV);
X    ITEM_CODE`009    := UAI$_DEFDEV;
X    BUFFER_ADDRESS  := IADDRESS(DEFDEV);
X    END;   `032
XWITH GETUAI_LIST[2] DO
XBEGIN
X    BUFFER_LENGTH   := SIZE(DEFDIR);
X    ITEM_CODE`009    := UAI$_DEFDIR;
X    BUFFER_ADDRESS  := IADDRESS(DEFDIR);
X    END;   `032
XWITH GETUAI_LIST[3] DO
XBEGIN
X    BUFFER_LENGTH   := SIZE(UIC);
X    ITEM_CODE`009    := UAI$_UIC;
X    BUFFER_ADDRESS  := IADDRESS(UIC);
X    END;   `032
XWITH GETUAI_LIST[4] DO
XBEGIN
X    BUFFER_LENGTH   := SIZE(ACCOUNT);
X    ITEM_CODE`009    := UAI$_ACCOUNT;
X    BUFFER_ADDRESS  := IADDRESS(ACCOUNT);
X    END;   `032
XWITH GETUAI_LIST[5] DO
XBEGIN
X    BUFFER_LENGTH   := SIZE(PRIV);
X    ITEM_CODE`009    := UAI$_PRIV;
X    BUFFER_ADDRESS  := IADDRESS(PRIV);
X    END;   `032
X`123
XThe the poop on this new username from the UAF file
X`125
XISTAT := $GETUAI(
X    USRNAM  := NEW_USERNAME,
X    ITMLST  := GETUAI_LIST);
X`123
XIf we fould one, do all the heavy work
X`125
XIF ODD(ISTAT) THEN
XBEGIN
V    LIB$DISABLE_CTRL(LIB$M_CLI_CTRLY);`009`123 Disable CTRL/Y while in progre
Xss  `125
X    WRITE_ACCOUNTING;`009`009`009`123 Write an accounting record`009    `125
X    REVOKEID;`009`009`009`009`123 Revoke all the user's rights`009    `125
X    SET_UIC(UIC);`009`009`009`123 Set the new UIC`009`009    `125
V    SET_TABLE_PROT(UIC);`009`009`123 Set the protection on LNM$JOB`009    `12
X5
V    $SETDDIR(SUBSTR(DEFDIR.BODY,1,`009`123 Set the new default directory`009
X    `125
X`009DEFDIR.LENGTH));
V    $CMEXEC(SET_LOGICALS);`009`009`123 Set all of our new logicals`009    `12
X5
V    SET_USERNAME(NEW_USERNAME);`009`009`123 Set the new username fields`009
X    `125
V    SET_PROCESS_NAME(NEW_USERNAME);`009`123 Set our process name via VMS rule
Xs`125
X    SET_ACCOUNT(ACCOUNT);`009`009`123 Set the new account data`009    `125
X    GRANTID;`009`009`009`009`123 Grant all the new identifiers`009    `125
X    SET_PRIVS(PRIV);`009`009`009`123 Set the new user's privs`009    `125
V    LIB$ENABLE_CTRL(LIB$M_CLI_CTRLY);`009`123 Re-enable control/y`009`009`032
X   `125
X    END ELSE
X`123
XDidn't find one (or other system service error) print out
Xan error msg
X`125
XBEGIN
X    IF ISTAT = RMS$_RNF THEN
X`009ISTAT := $GETMSG(BECOME_NOUSER,ERRMSG.LENGTH,ERRMSG.BODY) ELSE
X`009ISTAT := $GETMSG(ISTAT,ERRMSG.LENGTH,ERRMSG.BODY);
X    IF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
X    WRITELN(ERRMSG);
X    END;
XEND.
$ GOSUB UNPACK_FILE

$ FILE_IS = "BECOMECLD.CLD"
$ CHECKSUM_IS = 1216292012
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
X`009MODULE BECOMECLD
X`009IDENT /V1.0/
X!+
X! This module define the syntax for the BECOME foreign command
X!-
X`009DEFINE SYNTAX SHOW_VERSION,NOPARAMETERS
X
X`009DEFINE VERB BECOME
X`009`009PARAMETER P1 VALUE(REQUIRED)
X`009`009QUALIFIER VERSION NONNEGATABLE,SYNTAX=SHOW_VERSION
$ GOSUB UNPACK_FILE

$ FILE_IS = "BECOMEMSG.MSG"
$ CHECKSUM_IS = 941434870
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
X`009.FACILITY BECOME,1
X
X`009.SEVERITY INFORMATIONAL
X
X`009VERSION <BECOME version >
X
X`009.SEVERITY SUCCESS
X`009BECAME <Became user !AD>/FAO=1
X
X`009.SEVERITY FATAL
X`009NOINSUB`009<You can't BECOME another user while in a subprocess>
X`009NOSUB`009<You can't BECOME another user while you own a subprocess>
X`009UAFNOTFOU <Error opening SYSUAF.DAT>
X`009NOUSER`009<That user does not exist>
X`009.END
$ GOSUB UNPACK_FILE

$ FILE_IS = "BECOMESUB.MAR"
$ CHECKSUM_IS = 521679620
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
X`009.TITLE BECOME_SUBROUTINES
X`009.IDENT /01.2/
X;
X; This module has all the macro modules which support the BECOME program
X;
X; Revision history:
X;
X;`009V1.2 1-Oct-1986 WEW
X;`009`009Changed access mode on call to LNM$SEARCHLOG from
X;`009`009KERNEL to EXEC to get rid of the error finding
X;`009`009the logical name
X;
X; Include files:
X;
X`009.LIBRARY /SYS$LIBRARY:LIB/`009; Executive macro library
X`009.LINK 'SYS$SYSTEM:SYS.STB'/SELECTIVE_SEARCH
X`009$PCBDEF`009`009`009`009; Process Control Block offsets
X`009$JIBDEF`009`009`009`009; Job Information Block offsets
X`009$PHDDEF`009`009`009`009; Process Header Block offsets
X`009$LNMSTRDEF`009`009`009; Logical name definitions
X`009$ORBDEF`009`009`009`009; Object rights block defs
X`009$LNMDEF`009`009`009`009; Logical name
X`009$IPLDEF`009`009`009`009; Processor IPL defs
X`009$PSLDEF`009`009`009`009; PSL bit defs
X
V;----------------------------------------------------------------------------
X---
X`009.PSECT`009DATA,RD,NOWRT,NOEXE,PIC,LONG
XLNM_JOB:.ASCID /LNM$JOB/
XSYS_LOGIN:.ASCID/SYS$LOGIN/
V;----------------------------------------------------------------------------
X---
X;
X; Since this is a kernel mode routine R4 already points to the PCB
X; of the current process
X;
X`009.PSECT`009CODE RD,NOWRT,PIC,EXE,LONG
X`009.ENTRY`009SET_UIC `094M<>`009`009; Routine entry point
X`009$CMKRNL_S ROUTIN=10$, -`009`009; Kick into kernel
X`009`009  ARGLST=(AP)`009`009; & pass along the argument list
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD 0`009`009`009`009; Kernel entry point
X`009MOVAL`009HANDLER ,(FP)`009`009; Establish anti-crashing handler
X`009MOVL`009@4(AP),PCB$L_UIC(R4)`009; Stuff the new UIC
X`009MOVZBL`009#SS$_NORMAL, R0`009`009; Set success
X`009RET`009`009`009`009; from kernel
X
V;----------------------------------------------------------------------------
X---
X`009.ENTRY SET_USERNAME `094M<R2,R3,R4,R5,R5> ; Routine entry point
X`009$CMKRNL_S ROUTIN=10$, -`009`009; Kick into kernel
X`009`009  ARGLST=(AP)`009`009; & pass along the argument list
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD`0090`009`009`009; Kernel entry point
X`009MOVAL`009HANDLER, (FP)`009`009; Establish anti-crashing handler
X`009MOVL`009PCB$L_JIB(R4),R0`009; Get JIB address
X`009MOVC3`009#JIB$S_USERNAME,@4(AP),-; Copy the username
X`009`009JIB$T_USERNAME(R0)`009; into the JIB
X`009MOVC3`009#JIB$S_USERNAME,@4(AP),-; Copy the username
X`009`009G`094CTL$T_USERNAME`009; into the CTL region
X`009MOVZBL`009#SS$_NORMAL, R0`009`009; Set success
X`009RET`009`009`009`009; from kernel
X
V;----------------------------------------------------------------------------
X---
X`009.ENTRY SET_ACCOUNT `094M<R2,R3,R4,R5,R6>`009; Procedure entry point
X`009$CMKRNL_S ROUTIN=10$, -`009`009; Kick into kernel mode
X`009`009  ARGLST=(AP)`009`009; & pass along the argument list
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD`0090`009`009`009; Kernel entry point
X`009MOVAL`009HANDLER, (FP)`009`009; Establish condition handler
X`009MOVL`009PCB$L_JIB(R4), R0`009; Get JIB address
X`009MOVC3`009#JIB$S_ACCOUNT,@4(AP), -; Copy the account name
X`009`009JIB$T_ACCOUNT(R0)`009; into it's JIB location
X`009MOVC3`009#JIB$S_ACCOUNT,@4(AP),-`009; Copy the account name
X`009`009G`094CTL$T_ACCOUNT`009`009; into it's P1 location
X`009MOVZBL`009#SS$_NORMAL, R0`009`009; Set success
X`009RET`009`009`009`009; from kernel
X
V;----------------------------------------------------------------------------
X---
X;+
X; This routine is used to set the current process privs.  Note that
X; it doesn't touch the authorized priv mask in the PHD.  This allows
X; us to "become" ourselves again.
X;-
X`009.ENTRY SET_PRIVS `094M<>`009`009; Routine entry point
X`009$CMKRNL_S ROUTIN=10$,-`009`009; Kick into kernel
X`009`009  ARGLST=(AP)`009`009; & pass the argument pointer
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD`0090`009`009`009; Kernel entry point
X`009MOVAL`009HANDLER, (FP)`009`009; Establish condition handler
X`009MOVQ`009@4(AP), G`094CTL$GQ_PROCPRIV ; Set permanent process privs
X`009MOVQ`009@4(AP), PCB$Q_PRIV(R4)`009; Set current privs
X`009MOVL`009PCB$L_PHD(R4), R0`009; Get pointer to process header
X`009MOVQ`009@4(AP), PHD$Q_PRIVMSK(R0); Set the other copy of current privs
X`009MOVZBL`009#SS$_NORMAL, R0`009`009; Return success
X`009RET`009`009`009`009; from kernel
X
V;----------------------------------------------------------------------------
X---
X;+
X; This routine sets the owner of job logical name table to the
X; new uic of the user. The owner is in the objects rights block
X; which is pointed to from the logical name table structure.
X;-
X`009.ENTRY SET_TABLE_PROT `094M<R2,R3,R4,R5> ; Routine entry point
X`009$CMKRNL_S ROUTIN = 10$, -`009; Kick intor kernel
X`009`009  ARGLST=(AP)`009`009; & pass the argument list
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD`0090`009`009`009; Kernel entry point
X`009MOVAB`009HANDLER, (FP)`009`009; Establish condition handler
X;+
V; Raise IPL to AST delivery level so that there are no interruptions while th
Xe
X; translation of the logical name is being carried out, lock the logical name
X; mutex for reading, and then search for the specified logical name.
X;-
X`009SETIPL`009S`094#IPL$_ASTDEL`009`009; Raise IPL to AST delivery level
X`009JSB`009G`094LNM$LOCKR`009`009; Lock tables for reading
X`009MOVQ`009SYS_LOGIN, R0`009`009; Get logical name descriptor
X`009MOVQ`009LNM_JOB, R2`009`009; Get table name descriptor
X`009MOVZWL`009R0, R0`009`009`009; Clear the high order word
X`009MOVZWL`009R2, R2`009`009`009; Clear the high order word
X`009MOVL`009#PSL$C_EXEC, R5`009`009; Set R5 to it's required value
X;+
X; Call to LNM$SEARCHLOG expects the following registers to be set up:
X;
X;`009R0 - length of logical name string
X;`009R1 - Address of logical name string
X;`009R2 - Length of table name string
X;`009R3 - Address of logical name string
X;`009R5 - Search access mode in low byte,
X;`009     caseless flag in bit 8,
X;`009     high order word 0.
X; Returns:
X;
X;`009R0 low bit clear indicates search failure.
X;`009`009R0 - SS$_NOLOGNAM -No logical name match found.
X;`009`009R1 - Address of logical name block on which search failed
X;
X;`009R0 low bit set indictes success with:
X;`009`009R1 - Address of logical name block that contains match
X;
X;`009All other registers are preserved
X;-
X`009JSB`009G`094LNM$SEARCHLOG`009`009; Search for the logical name
X`009PUSHL`009R0`009`009`009; Save the search status
X`009BLBC`009R0, 20$`009`009`009; Branch if no name found
X`009MOVL`009LNMB$L_TABLE(R1), R1`009; Get address of table header
X`009MOVL`009LNMTH$L_ORB(R1), R1`009; Get address of object rights block
X`009MOVL`009@4(AP), ORB$L_OWNER(R1)`009; Set the new owner of the table
X20$:`009JSB`009G`094LNM$UNLOCK`009`009; Release lock on logical name mutex
X`009SETIPL`009#0`009`009`009; Drop our IPL to zero
X`009POPL`009R0`009`009`009; Get status
X`009RET`009`009`009`009; Return from kernel mode
V;----------------------------------------------------------------------------
X---
X`009.PSECT COND_HANDLER RD,NOWRT,PIC,EXE,LONG
X`009.ENTRY`009HANDLER `094M<>
X;
X; First get the mutex count out of our PCB to see if we should
X; release the I/O sub-system before exiting
X;
X`009MOVL`009G`094CTL$GL_PCB, R4`009; Get the current PCB address (US)
X`009TSTW`009PCB$W_MTXCNT(R4)`009; Any mutex's held ?
X`009BEQL`00910$`009`009`009; Branch if nope...
X`009JSB`009G`094LNM$UNLOCK`009`009; Release our mutex
X`009SETIPL`009#0`009`009`009; Drop our IPL to zero
X10$:`009$EXIT_S`009`009`009`009; Cause process to exit
X`009.END
$ GOSUB UNPACK_FILE

$ FILE_IS = "BECOMESUBS.MAR"
$ CHECKSUM_IS = 422610745
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
X`009.TITLE BECOME_SUBROUTINES
X`009.IDENT /01.3/
X;
X; This module has all the macro modules which support the BECOME program
X;
X; Revision history:
X;
X;`009V1.2 1-Oct-1986 WEW
X;`009`009Changed access mode on call to LNM$SEARCHLOG from
X;`009`009KERNEL to EXEC to get rid of the error finding
X;`009`009the logical name
X;
X;`009V1.3 14-Nov-1987 WEW
X;`009`009Made the required changes for VMS V5.x.
X;
X; Include files:
X;
X`009.LIBRARY /SYS$LIBRARY:LIB/`009; Executive macro library
X`009.LINK 'SYS$SYSTEM:SYS.STB'/SELECTIVE_SEARCH
X
X`009$PCBDEF`009`009`009`009; Process Control Block offsets
X`009$JIBDEF`009`009`009`009; Job Information Block offsets
X`009$PHDDEF`009`009`009`009; Process Header Block offsets
X`009$LNMSTRDEF`009`009`009; Logical name definitions
X`009$ORBDEF`009`009`009`009; Object rights block defs
X`009$LNMDEF`009`009`009`009; Logical name
X`009$IPLDEF`009`009`009`009; Processor IPL defs
X`009$PSLDEF`009`009`009`009; PSL bit defs
X;
X; Block to control recursive table name translation
X;
X`009$DEFINI RT
X$DEF`009RT_B_ACMODE,`009.BLKB, 1`009; Access mode
X$DEF`009RT_B_FLAGS,`009.BLKB, 1`009; Flags field
X`009_VIELD RT,0,<-
X`009`009<CASE,,>-`009`009; Caseless flag
X`009`009<TERM,,>>`009`009; Inhibit recursion flag
X$DEF`009RT_B_DEPTH,`009.BLKB, 1`009; Recursion depth
X$DEF`009RT_B_RETRIES,`009.BLKB, 1`009; Recursion tries
X$DEF`009RT_L_CACHEPTR,`009.BLKL, 1`009; Address of cache entry
X$DEF`009RT_A_STACK`009`009`009; Start of recursion stack
X$DEF`009RT_K_BLKLEN`009`009`009; Length of structure
X`009$DEFEND RT
XRT_K_SIZE = RT_K_BLKLEN + LNM$C_MAXDEPTH*4 ; Calculate total block size
X
X
V;----------------------------------------------------------------------------
X---
X`009.PSECT`009DATA,RD,NOWRT,NOEXE,PIC,LONG
XLNM_JOB:.ASCID /LNM$JOB/
V;----------------------------------------------------------------------------
X---
X;
X; Since this is a kernel mode routine R4 already points to the PCB
X; of the current process
X;
X`009.PSECT`009CODE RD,NOWRT,PIC,EXE,LONG
X`009.ENTRY`009SET_UIC `094M<>`009`009; Routine entry point
X`009$CMKRNL_S ROUTIN=10$, -`009`009; Kick into kernel
X`009`009  ARGLST=(AP)`009`009; & pass along the argument list
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD 0`009`009`009`009; Kernel entry point
X`009MOVAL`009HANDLER ,(FP)`009`009; Establish anti-crashing handler
X`009MOVL`009@4(AP),PCB$L_UIC(R4)`009; Stuff the new UIC
X`009MOVZBL`009#SS$_NORMAL, R0`009`009; Set success
X`009RET`009`009`009`009; from kernel
X
V;----------------------------------------------------------------------------
X---
X`009.ENTRY SET_USERNAME `094M<R2,R3,R4,R5,R5> ; Routine entry point
X`009$CMKRNL_S ROUTIN=10$, -`009`009; Kick into kernel
X`009`009  ARGLST=(AP)`009`009; & pass along the argument list
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD`0090`009`009`009; Kernel entry point
X`009MOVAL`009HANDLER, (FP)`009`009; Establish anti-crashing handler
X`009MOVL`009PCB$L_JIB(R4),R0`009; Get JIB address
X`009MOVC3`009#JIB$S_USERNAME,@4(AP),-; Copy the username
X`009`009JIB$T_USERNAME(R0)`009; into the JIB
X`009MOVC3`009#JIB$S_USERNAME,@4(AP),-; Copy the username
X`009`009G`094CTL$T_USERNAME`009; into the CTL region
X`009MOVZBL`009#SS$_NORMAL, R0`009`009; Set success
X`009RET`009`009`009`009; from kernel
X
V;----------------------------------------------------------------------------
X---
X`009.ENTRY SET_ACCOUNT `094M<R2,R3,R4,R5,R6>`009; Procedure entry point
X`009$CMKRNL_S ROUTIN=10$, -`009`009; Kick into kernel mode
X`009`009  ARGLST=(AP)`009`009; & pass along the argument list
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD`0090`009`009`009; Kernel entry point
X`009MOVAL`009HANDLER, (FP)`009`009; Establish condition handler
X`009MOVL`009PCB$L_JIB(R4), R0`009; Get JIB address
X`009MOVC3`009#JIB$S_ACCOUNT,@4(AP), -; Copy the account name
X`009`009JIB$T_ACCOUNT(R0)`009; into it's JIB location
X`009MOVC3`009#JIB$S_ACCOUNT,@4(AP),-`009; Copy the account name
X`009`009G`094CTL$T_ACCOUNT`009`009; into it's P1 location
X`009MOVZBL`009#SS$_NORMAL, R0`009`009; Set success
X`009RET`009`009`009`009; from kernel
X
V;----------------------------------------------------------------------------
X---
X;+
X; This routine is used to set the current process privs.  Note that
X; it doesn't touch the authorized priv mask in the PHD.  This allows
X; us to "become" ourselves again.
X;-
X`009.ENTRY SET_PRIVS `094M<>`009`009; Routine entry point
X`009$CMKRNL_S ROUTIN=10$,-`009`009; Kick into kernel
X`009`009  ARGLST=(AP)`009`009; & pass the argument pointer
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD`0090`009`009`009; Kernel entry point
X`009MOVAL`009HANDLER, (FP)`009`009; Establish condition handler
X`009MOVQ`009@4(AP), G`094CTL$GQ_PROCPRIV ; Set permanent process privs
X`009MOVQ`009@4(AP), PCB$Q_PRIV(R4)`009; Set current privs
X`009MOVL`009PCB$L_PHD(R4), R0`009; Get pointer to process header
X`009MOVQ`009@4(AP), PHD$Q_PRIVMSK(R0); Set the other copy of current privs
X`009MOVZBL`009#SS$_NORMAL, R0`009`009; Return success
X`009RET`009`009`009`009; from kernel
X
V;----------------------------------------------------------------------------
X---
X;+
X; This routine sets the owner of job logical name table to the
X; new uic of the user. The owner is in the objects rights block
X; which is pointed to from the logical name table structure.
X;-
X`009.ENTRY SET_TABLE_PROT `094M<R2,R3,R4,R5> ; Routine entry point
X`009$CMKRNL_S ROUTIN = 10$, -`009; Kick intor kernel
X`009`009  ARGLST=(AP)`009`009; & pass the argument list
X`009BLBS`009R0, 5$`009`009`009; Branch if success
X`009PUSHL`009R0`009`009`009; Push the bad status
X`009CALLS`009#1, G`094LIB$STOP`009`009; Crash on errors
X5$:`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD`0090`009`009`009; Kernel entry point
X`009MOVAB`009HANDLER, (FP)`009`009; Establish condition handler
X;+
V; Raise IPL to AST delivery level so that there are no interruptions while th
Xe
X; translation of the logical name is being carried out, lock the logical name
X; mutex for reading, and then search for the specified logical name.
X;-
X`009SETIPL`009S`094#IPL$_ASTDEL`009`009; Raise IPL to AST delivery level
X`009JSB`009G`094LNM$LOCKR`009`009; Lock tables for reading
X`009SUBL`009#RT_K_SIZE, SP`009`009; Allocate a recursion control block
X`009MOVL`009SP, R5`009`009`009; Set the address in the proper reg
X`009MOVB`009#PSL$C_EXEC, RT_B_ACMODE(R5) ; Set the proper access mode
X`009CLRB`009RT_B_FLAGS(R5)`009`009; Initialize the flags field
X`009BBSS`009#RT_V_CASE,RT_B_FLAGS(R5),11$ ; Set the proper flag bit
X11$:`009MOVQ`009LNM_JOB, R2`009`009; Get table name descriptor
X`009MOVZWL`009R2, R2`009`009`009; Clear the high order word
X;+
X; Call to LNM$SETUP expects the following registers to be set up:
X;
X;`009R2 - Length of table name string
X;`009R3 - Address of logical name string
X;`009R5 - Address of recursion table search control block
X; Returns:
X;
X;`009R0 low bit clear indicates search failure.
X;`009`009R0 - SS$_NOLOGNAM -No logical name match found.
X;`009`009R1 - Address of logical name block on which search failed
X;
X;`009R0 low bit set indictes success with:
X;`009`009R1 - Address of logical name table block that contains match
X;
X;`009All other registers are preserved
X;-
X`009JSB`009G`094LNM$SETUP`009`009; Search for the logical name block
X`009PUSHL`009R0`009`009`009; Save the search status
X`009BLBC`009R0, 20$`009`009`009; Branch if no name found
X`009MOVL`009LNMTH$L_ORB(R1), R1`009; Get address of object rights block
X`009MOVL`009@4(AP), ORB$L_OWNER(R1)`009; Set the new owner of the table
X20$:`009JSB`009G`094LNM$UNLOCK`009`009; Release lock on logical name mutex
X`009SETIPL`009#0`009`009`009; Drop our IPL to zero
X`009POPL`009R0`009`009`009; Get status
X`009RET`009`009`009`009; Return from kernel mode
V;----------------------------------------------------------------------------
X---
X`009.PSECT COND_HANDLER RD,NOWRT,PIC,EXE,LONG
X`009.ENTRY`009HANDLER `094M<>
X;
X; First get the mutex count out of our PCB to see if we should
X; release the I/O sub-system before exiting
X;
X`009MOVL`009G`094CTL$GL_PCB, R4`009; Get our current PCB
X`009TSTW`009PCB$W_MTXCNT(R4)`009; Any mutex's held ?
X`009BEQL`00910$`009`009`009; Branch if nope...
X`009JSB`009G`094LNM$UNLOCK`009`009; Release our mutex
X`009SETIPL`009#0`009`009`009; Drop our IPL to zero
X10$:`009$EXIT_S`009`009`009`009; Cause process to exit
X`009.END
$ GOSUB UNPACK_FILE

$ FILE_IS = "SEG.MAR"
$ CHECKSUM_IS = 1074489876
$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY
V;----------------------------------------------------------------------------
X---
X;+
X; This routine sets the owner of job logical name table to the
X; new uic of the user. The owner is in the objects rights block
X; which is pointed to from the logical name table structure.
X;-
X`009.ENTRY SET_TABLE_PROT `094M<R2,R3,R4,R5> ; Routine entry point
X`009$CMKRNL_S ROUTIN = 10$, -`009; Kick intor kernel
X`009`009  ARGLST=(AP)`009`009; & pass the argument list
X`009RET`009`009`009`009; back to the Pascal mainline
X10$:`009.WORD`0090`009`009`009; Kernel entry point
X`009MOVAB`009HANDLER, (FP)`009`009; Establish condition handler
X;+
V; Raise IPL to AST delivery level so that there are no interruptions while th
Xe
X; translation of the logical name is being carried out, lock the logical name
X; mutex for reading, and then search for the specified logical name.
X;-
X`009SETIPL`009S`094#IPL$_ASTDEL`009`009; Raise IPL to AST delivery level
X`009JSB`009G`094LNM$LOCKR`009`009; Lock tables for reading
X`009MOVQ`009SYS_LOGIN, R0`009`009; Get logical name descriptor
X`009MOVQ`009LNM_JOB, R2`009`009; Get table name descriptor
X`009MOVZWL`009R0, R0`009`009`009; Clear the high order word
X`009MOVZWL`009R2, R2`009`009`009; Clear the high order word
X`009MOVL`009#PSL$C_EXEC, R5`009`009; Set R5 to it's required value
X;+
X; Call to LNM$SEARCHLOG expects the following registers to be set up:
X;
X;`009R0 - length of logical name string
X;`009R1 - Address of logical name string
X;`009R2 - Length of table name string
X;`009R3 - Address of logical name string
X;`009R5 - Search access mode in low byte,
X;`009     caseless flag in bit 8,
X;`009     high order word 0.
X; Returns:
X;
X;`009R0 low bit clear indicates search failure.
X;`009`009R0 - SS$_NOLOGNAM -No logical name match found.
X;`009`009R1 - Address of logical name block on which search failed
X;
X;`009R0 low bit set indictes success with:
X;`009`009R1 - Address of logical name block that contains match
X;
X;`009All other registers are preserved
X;-
X`009JSB`009G`094LNM$SEARCHLOG`009`009; Search for the logical name
X`009PUSHL`009R0`009`009`009; Save the search status
X`009BLBC`009R0, 20$`009`009`009; Branch if no name found
X`009MOVL`009LNMB$L_TABLE(R1), R1`009; Get address of table header
X`009MOVL`009LNMTH$L_ORB(R1), R1`009; Get address of object rights block
X`009MOVL`009@4(AP), ORB$L_OWNER(R1)`009; Set the new owner of the table
X20$:`009JSB`009G`094LNM$UNLOCK`009`009; Release lock on logical name mutex
X`009SETIPL`009#0`009`009`009; Drop our IPL to zero
X`009POPL`009R0`009`009`009; Get status
X`009RET`009`009`009`009; Return from kernel mode
V;----------------------------------------------------------------------------
X---
$ GOSUB UNPACK_FILE
$ EXIT