[INHERIT ( 'SYS$LIBRARY:STARLET' )]

PROGRAM psi$x29_destination_pascal (input, output);

{
*************************************************************************
**                                                                      *
**         COPYRIGHT  (c)  DIGITAL EQUIPMENT CORPORATION, 1993          *
**         ALL RIGHTS RESERVED.  UNPUBLISHED - RIGHTS RESERVED          *
**         UNDER THE COPYRIGHT LAWS OF THE UNITED STATES.               *
**                                                                      *
**         RESTRICTED RIGHTS LEGEND: USE, DUPLICATION, OR DISCLOSURE    *
**         BY THE U.S. GOVERNMENT IS SUBJECT TO RESTRICTIONS AS SET     *
**         FORTH IN SUBPARAGRAPH (C)(1)(II) OF DFARS 252.227-7013,      *
**         OR IN FAR 52.227-19, OR IN FAR 52.227-14 ALT. III, AS        *
**         APPLICABLE.                                                  *
**                                                                      *
**         THIS SOFTWARE IS PROPRIETARY TO AND EMBODIES CONFIDENTIAL    *
**         TECHNOLOGY OF DIGITAL.  POSSESSION, USE, OR COPYING OF THE   *
**         SOFTWARE AND MEDIA IS AUTHORIZED ONLY PURSUANT TO A VALID    *
**         WRITTEN LICENSE FROM DIGITAL.                                *
**                                                                      *
*************************************************************************
**++
**
**  FACILITY:
**
**      X29 Destination Example Program
**
**  ABSTRACT:
**
**      Digital is furnishing this example software "as is" without
**      warranty of any kind, express or implied, including the implied
**      warranties of merchantability and fitness for a particular purpose.
**      Digital disclaims any and all liability for the performance or
**      non-performance of this software.
**
**
**	This program is a simple example of an X.29 destination that
**	asks the X.29 user for a password before allowing them to log in.
**
**	The link command should include psilib.obj in the object list.
**
**	The following NCL commands can be used to configure X.25.  This 
**      configeration assumes the following
**	    - the estination example is started by a application entity
**	    - the file specified by the application entity contains a DCL
**	      command to run the destination executable.
**	      
**
**    create x25 access
**    create x25 client
**    !
**    !	Create DTE classes
**    !
**    create x25 access dte class crock type remote
**    set x25 access dte class crock service node ((node=dundee, -
**	    rating=512))
**    create x25 access dte class crock1 type remote
**    set x25 access dte class crock1 service node ((node=dundee, -
**	    rating=512))
**    !                                                                 
**    !	Create security DTE class
**    !
**    create x25 access security dte class default
**    !
**    !	Create remote DTE entity
**    !
**    create x25 access security dte class default remote dte match_all -
**	    remote address prefix *
**    set x25 access security dte class default remote dte match_all -
**	    rights identifier (match_all)
**    !
**    !	Create template
**    !
**    create x25 access template net_template1
**    set x25 access template net_template1 dte class crock
**    create x25 access template default
**    !
**    !	Create filter
**    !
**    create x25 access filter receive
**    set x25 access filter receive incoming dte address 12345
**    !
**    !	Create security filter
**    !
**    create x25 access security filter default
**    set x25 access security filter default acl -
**	    ((identifier=(match_all),access=all))
**    !
**    !	Create application entity
**    !
**    create x25 access application receive
**    set x25 access application receive filters (receive)
**    set x25 access application receive type x29
**    set x25 access application receive user system
**    set x25 access application receive file sys$system:x25$destination.com
**    !
**    !	Enable everything
**    !
**    enable x25 access
**    enable x25 client
**    enable x25 access application receive
**
**  FUNCTIONAL DESCRIPTION:
**
**      * Inherit external declarations from 'starlet' environment
**      * Declare local constants, types and variables
**      * Declare structures for mailbox, FAO, NW and NV descriptors, and IOSB
**      * Assign a channel to NW
**      * Assign a channel to mailbox
**      * Read mailbox to obtain nv_unit and convert it to a device name string
**      * Assign a channel to NV
**      * Output a welcome message
**      * Determine local echo mode from terminal characteristics
**        if local echo mode make sure PAD echo parameter is turned off
**      * Read the password from the terminal and validate it
**      * If password was correct then clear the typeahead characteristics
**	  and set the temp nohang bit else deaccess NW
**      * Deassign NV so that login will start on NV unit
**      * Deassign channels to NW and mailbox
**
**--
}



CONST	    pswd_len	= 20;


TYPE	    t_word	= [word] -32768..32767;	    { 16bits 2bytes signed   }
	    t_long	= [long] integer;	    { 32bits 4bytes signed   }
	    t_ubyte	= [byte] 0..255;	    { 08bits 1byte  unsigned }
	    t_uword	= [word] 0..65535;	    { 16bits 2bytes unsigned }
	    t_ulong	= [long] unsigned;	    { 32bits 4bytes unsigned }
	    t_uquad	= [quad, unsafe]    RECORD
					        l0,l1:unsigned
					    END;    { 64bits 8bytes unsigned }
	    t_deftyp	= [unsafe] integer;
	    t_defptr	= [unsafe] ^t_deftyp;

	    t_mbx_buf	=   RECORD
				msg_typ	: t_uword;
				unit	: t_uword;
 				name_sz	: t_ubyte;
				name	: PACKED ARRAY [1..15] OF char;
				info_sz	: t_ubyte;
				info	: PACKED ARRAY [1..491] OF char
			    END;

	    t_iosb	=   RECORD
				status,
				dlen	: t_uword;
				iosb_1	: t_long
			    END;

	    t_nv_name	=   VARYING [20] OF char;


	    t_pad_param_block	=   RECORD
					param_num,
					param_val   : t_ulong
				    END;

	    t_descrip		=   RECORD
					dsc$w_length	: t_uword;
					dsc$b_dtype	: t_ubyte;
					dsc$b_class	: t_ubyte;
					dsc$a_pointer	: t_defptr
				    END;

	    t_pswd_string	=   PACKED ARRAY [1..pswd_len] OF char;



VAR	    fn_code		:   [unsafe] t_uword;

	    tt2$v_localecho,
	    psi$k_x29_par_echo,
	    psi$k_x29_pad_params,
	    psi$k_x29_temp_nohang,
	    psi$k_x29_set,
	    psi$k_x29_read,
	    psi$k_x29_read_specific	:   [value, external] t_ubyte;

	    term_char		:   PACKED ARRAY [0..3] OF t_ulong;

	    term_char_mask	:   t_ulong;

	    term_rcv_buff	:   t_pswd_string;

	    welcome_msg		:   PACKED ARRAY [1..48] OF char :=
			'Welcome to the X.29 Example Program'(13,10);

	    pwd_prmpt		:   [volatile] PACKED ARRAY [1..15] OF char :=
					    'X.29 Password: ';

	    password		:   t_pswd_string := 'STEVE';

	    temp_nohang_on	:   [volatile] t_ulong := 1;

	    mailbox		:   [volatile] t_mbx_buf;

	    iosb		:   t_iosb;

	    status		:   t_uword;

	    nv_chan,
	    nw_chan,
	    mbx_chan		:   t_word := 0;

	    nv_unit		:   t_long;

	    mbx_name		:   [volatile] PACKED ARRAY [1..7] OF char :=
							'SYS$NET';

	    nw_name		:   [volatile] PACKED ARRAY [1..6] OF char :=
							'_NWA0:';

	    fao_control		:   [volatile] PACKED ARRAY [1..6] OF char :=
							'!AC!UW';

	    nv_name		:   t_nv_name;

	    pad_param_block	:   t_pad_param_block;

	    pad_echo            :   boolean;






PROCEDURE check_status( status: t_uword; iosb: t_iosb );

{   Check System Service return status and return code   }

BEGIN
    IF status <> SS$_NORMAL
    THEN $EXIT(status)
    ELSE IF iosb.status <> SS$_NORMAL
	 THEN BEGIN
		  $PUTMSG(iosb.status);   {output VMS return code}
		  $EXIT(iosb.iosb_1)      {output P.S.I. return code}
              END
END;   { check_status }






FUNCTION fill_string(	input_string : t_pswd_string;
			string_size  : integer )
				     : t_pswd_string;

{   This function pads a string with spaces.  It takes an input string
    and copies it character by character to an output string until a
    carriage return character is detected after which spaces are written
    to the output string.						    }

CONST	cr	= 13;
	space	= ' ';

VAR	n	: integer;
	str	: t_pswd_string;

BEGIN
    n := 1;
    WHILE (ord(input_string[n]) <> cr) AND (n <= string_size) DO
	BEGIN
	    str[n] := input_string[n];
	    n := n + 1
	END;

    WHILE (n <= string_size) DO
	BEGIN
	    str[n] := space;
	    n := n + 1
	END;

    fill_string := str

END;   {fill_string}






BEGIN	{ main }

    {   Initialise pad parameter block   }

    pad_param_block.param_num	:=  psi$k_x29_par_echo;
    pad_param_block.param_val	:=  0;



    {   Assign a channel to NW   }

    status := $assign(	devnam	:= nw_name,
			chan	:= nw_chan );

    IF NOT odd(status) THEN $EXIT(status);





    {   Assign a channel to mailbox   }

    status := $assign(	devnam	:= mbx_name,
			chan	:= mbx_chan );

    IF NOT odd(status) THEN $EXIT(status);






    {	Read mailbox to get connect message  }

    status := $QIOW(	chan	:= mbx_chan,
			func	:= IO$_READVBLK,
			iosb	:= iosb,
			p1	:= mailbox,
			p2	:= size(mailbox));

    check_status(status, iosb);



    nv_unit := mailbox.unit;


    {   Convert unit number to device name string   }

    status := $fao( fao_control,			{ctrstr}
		    nv_name.length,			{outlen}
		    nv_name.body,			{outbuf}
		    %IMMED address(mailbox.name_sz),	{p1    }
		    %IMMED nv_unit			{p2    }
		    );

    IF NOT odd(status) THEN $EXIT(status);





    {   Assign a channel to NV   }

    status := $assign(	devnam	:= nv_name,
			chan	:= nv_chan );

    IF NOT odd(status) THEN $EXIT(status);





    {   Output welcome message   }

    status := $QIOW(    chan    := nv_chan,
			func    := IO$_WRITEVBLK,
			iosb    := iosb,
			p1	:= welcome_msg,
			p2	:= size(welcome_msg) );

    check_status(status, iosb);




    { See if the PAD echo parameter is set }
    status := $QIOW(    chan    := nw_chan,
				func    := IO$_NETCONTROL,
				iosb    := iosb,
				p1	:= pad_param_block,
				p2	:= size(pad_param_block),
				p3	:= psi$k_x29_pad_params, 
				p4	:= psi$k_x29_read_specific,
				p6	:= nv_unit  );

    check_status(status, iosb);

    pad_echo := pad_param_block.param_val = 1;

    IF (pad_echo)
    THEN BEGIN
    	    pad_param_block.param_num	:=  psi$k_x29_par_echo;
    	    pad_param_block.param_val	:=  0;
	    status := $QIOW(    chan    := nw_chan,
				func    := IO$_NETCONTROL,
				iosb    := iosb,
				p1	:= pad_param_block,
				p2	:= size(pad_param_block),
				p3	:= psi$k_x29_pad_params, 
				p4	:= psi$k_x29_set,
				p6	:= nv_unit  );

	    check_status(status, iosb)
	END;




    {   Read password from the terminal   }

    fn_code := uor(IO$_READPROMPT, IO$M_NOECHO);
    fn_code := uor(fn_code, IO$M_CVTLOW);

    status := $QIOW(    chan    := nv_chan,
			func    := fn_code,
			iosb    := iosb,
			p1	:= term_rcv_buff,
			p2	:= size(term_rcv_buff),
			p5	:= iaddress(pwd_prmpt), 
			p6	:= size(pwd_prmpt)  );

    check_status(status, iosb);

    term_rcv_buff := fill_string(term_rcv_buff, pswd_len);


    IF (pad_echo)
    THEN BEGIN
    	    pad_param_block.param_num	:=  psi$k_x29_par_echo;
    	    pad_param_block.param_val	:=  1;
	    status := $QIOW(    chan    := nw_chan,
				func    := IO$_NETCONTROL,
				iosb    := iosb,
				p1	:= pad_param_block,
				p2	:= size(pad_param_block),
				p3	:= psi$k_x29_pad_params, 
				p4	:= psi$k_x29_set,
				p6	:= nv_unit  );

	    check_status(status, iosb)
	END;


    {   Validate the password   }

    {   This code could be much more complex, looking up a coded form
	in a file for example                                           }


    IF (term_rcv_buff = password)
    THEN BEGIN
	    {   Clear the notypeahead characteristics   }
	    {   NOTE: This requires PHY_IO privilege    }

	    status := $QIOW(    chan    := nv_chan,
				func    := IO$_SENSECHAR,
				iosb    := iosb,
				p1	:= term_char,
				p2	:= size(term_char) );

	    check_status(status, iosb);


	    if (uand(term_char[1], TT$M_NOTYPEAHD) <> 0)
	    then
		term_char[1] := uxor(term_char[1], TT$M_NOTYPEAHD);

	    status := $QIOW(    chan    := nv_chan,
				func    := IO$_SETCHAR,
				iosb    := iosb,
				p1	:= term_char,
				p2	:= size(term_char),
				p3	:= iosb.dlen,
				p4	:= iosb.iosb_1 );

	    check_status(status, iosb);



	    {   Password was correct so set the temp nohang bit
		to enable login					    }

	    status := $QIOW(    chan    := nw_chan,
				func    := IO$_NETCONTROL,
				iosb    := iosb,
				p1	:= temp_nohang_on,
				p2	:= 4,
				p3	:= psi$k_x29_temp_nohang,
				p4	:= psi$k_x29_set,
				p6	:= nv_unit  );

	    check_status(status, iosb);

	 END
    ELSE BEGIN
	    {   password was incorrect so clear the call   }

	    status := $QIOW(    chan    := nw_chan,
				func    := IO$_DEACCESS,
				iosb    := iosb,
				p6	:= nv_unit );

	    check_status(status, iosb);

	    {   When the NV channel is deassigned the NV unit
		will disappear                                  }

	 END;




    {   Deassign NV channel   }

    status := $dassgn(	chan	:= nv_chan );

    IF NOT odd(status) THEN $EXIT(status);



    {   Deassign NW channel   }

    status := $dassgn(	chan	:= nw_chan );

    IF NOT odd(status) THEN $EXIT(status);



    {   Deassign mailbox channel   }

    status := $dassgn(	chan	:= mbx_chan );

    IF NOT odd(status) THEN $EXIT(status);



    {   Exit with good status   }

    $exit( SS$_NORMAL );


END.  { main }