[IDENT('V1.0'),		    { Update this with the version constant below }
INHERIT ('SYS$LIBRARY:STARLET.PEN')]
PROGRAM SETUNAME(OUTPUT);

{ This program when used as a foreign command allows a suitably priviliged
  user to change his username to that of another user.  This program is a
  gutted version of Eric Wentz' BECOME V1.8
}

CONST
    VER_STRING = 'V1.0';		    { Update with version in the header}

TYPE
    UBYTE	    = [BYTE] 0..255;
    UWORD	    = [WORD] 0..65535;
    UQUAD	    = [QUAD,UNSAFE] RECORD L0,L1:UNSIGNED;END;
    USERNAME_TYPE   = PACKED ARRAY [1..12] OF CHAR;

    ITEM_LIST_TYPE = RECORD
	BUFFER_LENGTH	: UWORD;
	ITEM_CODE	: UWORD;
	BUFFER_ADDRESS	: UNSIGNED;
	RETURN_LEN_ADDR	: UNSIGNED;
	END;

    UIC_TYPE = RECORD CASE INTEGER OF
    1:(UIC  : INTEGER);
    2:(MEMBER	: UWORD;
       GROUP	: UWORD);
       END;

(********** Define the variables used by the program ************)

VAR
    ISTAT	: [VOLATILE] INTEGER;
    NEW_USERNAME: USERNAME_TYPE;
    SETUP_PRIVS	: UQUAD:=0;
    ERRMSG	: VARYING[255] OF CHAR;

{
Local storage for $GETUAI items (from UAF file)
}
    UIC		: [VOLATILE] UIC_TYPE;
    GETUAI_LIST	: ARRAY [1..2] OF ITEM_LIST_TYPE:=ZERO;
{
Define the variables for the message numbers
}
    SETUNAME_UAFNOTFOU,
    SETUNAME_VERSION,
    SETUNAME_BECAME,
    SETUNAME_NOUSER	: [EXTERNAL,VALUE] INTEGER;

    COMMAND_STRING : VARYING [80] OF CHAR;
    SETUNAMECLD : [EXTERNAL,VALUE] INTEGER;	{ Parsing tables for CLI    }

(******** Functions that reside in SETUNAMESUB.MAR ************)

PROCEDURE SET_USERNAME	(VAR USERNAME	: USERNAME_TYPE);	EXTERNAL;

(******************************************************************************)
(***************   Define RTL routines  ***************************************)
(******************************************************************************)

[ASYNCHRONOUS] PROCEDURE LIB$STOP
  (%IMMED Cond_Value :INTEGER);EXTERNAL;

FUNCTION LIB$GET_FOREIGN(
	var get_str : [CLASS_S] PACKED ARRAY
	[$L1..$U1:INTEGER] OF CHAR;
	var user_prompt : [CLASS_S,READONLY] PACKED ARRAY
	[$L2..$U2:INTEGER] OF CHAR := %IMMED 0;
	var out_len : UWORD := %IMMED 0;
	var force_prompt : [CLASS_S,READONLY] PACKED ARRAY
	[$L3..$U3:INTEGER] OF CHAR := %IMMED 0):integer; external;

PROCEDURE LIB$PUT_OUTPUT(
    VAR STR : [READONLY,CLASS_S] PACKED ARRAY [A..B:INTEGER] OF CHAR);EXTERNAL;

PROCEDURE LIB$ENABLE_CTRL(
	VAR ENABLE_MSK : [READONLY] UNSIGNED);EXTERNAL;

PROCEDURE LIB$DISABLE_CTRL(
	VAR DISABLE_MSK : [READONLY] UNSIGNED);EXTERNAL;

{ Somebody blew it, this should be defined in STARLET !! }
[ASYNCHRONOUS,EXTERNAL(SYS$SETDDIR)]
FUNCTION $SETDDIR(
    VAR NEW_DIR_ADDR : [READONLY,CLASS_S] PACKED ARRAY [A..B:INTEGER] OF CHAR;
    VAR LENGTH_ADDR : UWORD := %IMMED 0;
    VAR CUR_DIR_ADDR : [CLASS_S] PACKED ARRAY
	[C..D:INTEGER] OF CHAR := %IMMED 0):INTEGER;EXTERNAL;

VAR		    { Define CLI utility conditions }
  CLI$_NOCOMD,
  CLI$_INVROUT,
  CLI$_COMMA,
  CLI$_CONCAT,
  CLI$_ABSENT,
  CLI$_PRESENT,
  CLI$_NEGATED,
  CLI$_LOCPRES,
  CLI$_DEFAULTED    : [EXTERNAL,VALUE] INTEGER;

Function CLI$DCL_PARSE(
	var command_string  : [CLASS_S,READONLY] PACKED ARRAY
		[$L1..$U1:INTEGER] OF CHAR;
	%immed table	    : [READONLY] INTEGER;
	%immed [UNBOUND] procedure param_routine := %immed 0;
	%immed [UNBOUND] procedure prompt_routine := %immed 0;
	var prompt_string   : [CLASS_S,READONLY] PACKED ARRAY
		[$L2..$U2:INTEGER] OF CHAR:=%IMMED 0):INTEGER; EXTERNAL;

Function CLI$GET_VALUE(
	var entity_desc	    : [CLASS_S,READONLY] PACKED ARRAY
		[$L1..$U1:INTEGER] OF CHAR;
	var retdesc	    : [CLASS_S] PACKED ARRAY
		[$L2..$U2:INTEGER] OF CHAR;
	var retlength	    : UWORD :=%IMMED 0):INTEGER;EXTERNAL;

Function CLI$PRESENT(
	var entity_desc	    : [CLASS_S,READONLY] PACKED ARRAY
		[$L1..$U1:INTEGER] OF CHAR):INTEGER;EXTERNAL;


(************   Start of mainline program **************)
BEGIN
{
First try to set this process to have CMKRNL,CMEXEC & SYSPRV - If we can't
do this, the user has no right to run the program
}
SETUP_PRIVS::PRV$TYPE.PRV$V_CMKRNL := TRUE;
SETUP_PRIVS::PRV$TYPE.PRV$V_CMEXEC := TRUE;
SETUP_PRIVS::PRV$TYPE.PRV$V_SYSPRV := TRUE;

ISTAT := $SETPRV(
	ENBFLG	:= 1,
	PRVADR	:= SETUP_PRIVS);
IF ISTAT = SS$_NOTALLPRIV THEN $EXIT(SS$_NOPRIV);
IF NOT ODD (ISTAT) THEN $EXIT(ISTAT);
{
Now get the command from DCL which returns the new username
}
ISTAT := LIB$GET_FOREIGN(
	    GET_STR	:= COMMAND_STRING.BODY,
	    USER_PROMPT	:= 'Username: ',
	    OUT_LEN     := COMMAND_STRING.LENGTH);
IF NOT ODD (ISTAT) THEN
    IF ISTAT = RMS$_EOF THEN
	$EXIT(1) ELSE
	$EXIT(ISTAT);

ISTAT := CLI$DCL_PARSE(
    'SETUNAME ' + SUBSTR(COMMAND_STRING.BODY,1,COMMAND_STRING.LENGTH),
    %IMMED SETUNAMECLD);
IF NOT ODD(ISTAT) THEN $EXIT;

IF ODD(CLI$PRESENT('VERSION')) THEN
    BEGIN
    ISTAT := $GETMSG(SETUNAME_VERSION,ERRMSG.LENGTH,ERRMSG.BODY);
    IF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
    ERRMSG := ERRMSG + VER_STRING;
    WRITELN(ERRMSG);
    $EXIT;
    END;

ISTAT := CLI$GET_VALUE('P1',NEW_USERNAME);
IF NOT ODD(ISTAT) THEN $EXIT(ISTAT);

{
Now set up the item list for the $GETUAI system service
}
WITH GETUAI_LIST[1] DO
BEGIN
    BUFFER_LENGTH   := SIZE(UIC);
    ITEM_CODE	    := UAI$_UIC;
    BUFFER_ADDRESS  := IADDRESS(UIC);
    END;    
{
Get the poop on this new username from the UAF file
}
ISTAT := $GETUAI(
    USRNAM  := NEW_USERNAME,
    ITMLST  := GETUAI_LIST);
{
If we found one, do all the heavy work
}
IF ODD(ISTAT) THEN
BEGIN
    LIB$DISABLE_CTRL(LIB$M_CLI_CTRLY);	{ Disable CTRL/Y while in progress  }
    LIB$DISABLE_CTRL(LIB$M_CLI_CTRLY);	{ Disable CTRL/Y while in progress  }
    SET_USERNAME(NEW_USERNAME);		{ Set the new username fields	    }
    LIB$ENABLE_CTRL(LIB$M_CLI_CTRLY);	{ Re-enable control/y		    }
    END ELSE
{
Didn't find one (or other system service error) print out
an error msg
}
BEGIN
    IF ISTAT = RMS$_RNF THEN
	ISTAT := $GETMSG(SETUNAME_NOUSER,ERRMSG.LENGTH,ERRMSG.BODY) ELSE
	ISTAT := $GETMSG(ISTAT,ERRMSG.LENGTH,ERRMSG.BODY);
    IF NOT ODD(ISTAT) THEN $EXIT(ISTAT);
    WRITELN(ERRMSG);
    END;
END.