%TITLE	'ADDRESS_REWRITER'
MODULE ADDRESS_REWRITER (IDENT = 'V1.1'
%IF %VARIANT NEQU 0
%THEN
	, MAIN = main
%FI
) = 
BEGIN
!++
!
!  Facility:	ADDRESS_REWRITER
!
!  Author:	Hunter Goatley
!
!  Date:	August 2, 1994
!
! MODULE DESCRIPTION:
!
!   This module contains routines for use by MX modules (specifically the
!   MX_ROUTER agent process) for rewriting RFC822 addresses.
!
!   These routines read aliases from a file and store them in a B-tree
!   in memory for later retrieval.
!
!   To build it, use:
!
!	$ BLISS ADDRESS_REWRITER
!	$ LINK/NOTRACE/SHARE ADDRESS_REWRITER.OBJ, SYS$INPUT:/OPTION
!	MX_EXE:MX_SHR.EXE/SHARE
!	UNIVERSAL=INIT,REWRITE_HEADER,REWRITE_ENVELOPE,CLEANUP
!	^Z
!	$
!
!   On Alpha, use:
!
!	$ BLISS ADDRESS_REWRITER
!	$ LINK/NOTRACE/SHARE ADDRESS_REWRITER.OBJ, SYS$INPUT:/OPTION
!	MX_EXE:MX_SHR.EXE/SHARE
!	SYMBOL_VECTOR=(-
!	   INIT			= PROCEDURE,-
!	   REWRITE_HEADER	= PROCEDURE,-
!	   REWRITE_ENVELOPE	= PROCEDURE,-
!	   CLEANUP		= PROCEDURE)
!	^Z
!	$
!
!   Then copy it to MX_EXE: and make it available to the Router with the
!   following commands:
!
!       $ COPY ADDRESS_REWRITER.EXE MX_EXE:
!       $ DEFINE/SYSTEM/EXEC MX_SITE_ADDRESS_REWRITER MX_EXE:ADDRESS_REWRITER
!       $ MCP RESET ROUTER
!
!   The file used is MX_ALIAS_ADDRESSES in MX_DIR:.  A sample file
!   might look like this:
!
!	-----------------------------------------------------------------------
!	!  MX aliases for WKU addresses
!	!
!	!  Comments are denoted by a "!" in column 1.  All addresses must begin
!	! in column 1 and can be separated by multiple spaces or tabs.
!	!
!	!  Format:
!	!
!	!       actual address                  desired address
!	!
!	! TESTING
!	Real.Address@NODENAME.MADGOAT.COM	Alias@MadGoat.COM
!	goathunter@ALPHA.WKU.EDU		goathunter@PROCESS.COM
!	goathunter@ALPHA.WKU.EDU		Hunter@PROCESS.COM
!	-----------------------------------------------------------------------
!
!  Modified by:
!
!	01-001		Hunter Goatley		 3-SEP-1997 10:55
!		Remove references to MX sources.
!
!	01-000		Hunter Goatley		 2-AUG-1994 13:22
!		Original version.
!
!--
LIBRARY 'SYS$LIBRARY:STARLET';			!Pull stuff from STARLET

SWITCHES ADDRESSING_MODE (EXTERNAL = GENERAL, NONEXTERNAL = WORD_RELATIVE);

    FORWARD ROUTINE
	INIT,					!Initialization routine
	REWRITE_HEADER,				!Rewrite RFC822 header
	REWRITE_ENVELOPE,			!Rewrite RFC821 envelope
	CLEANUP,					!Cleanup routine
	alloc_node,
	compare_node,
	dealloc_node
	;

    EXTERNAL ROUTINE
	PARSE_MBOX,				!Found in MX_SHR
	LIB$GET_VM,
	LIB$FREE_VM,
	LIB$INSERT_TREE,
	LIB$TRAVERSE_TREE,
	LIB$LOOKUP_TREE,
	LIB$SYS_FAO,
	STR$CASE_BLIND_COMPARE,
	STR$COPY_R,
	STR$COPY_DX,
	STR$FREE1_DX,
	STR$LEN_EXTR,
	STR$CONCAT,
	STR$REPLACE,
	STR$POSITION
	;

    LITERAL
        CTX_S_CTXDEF    = 8;

    FIELD
	CTX_FIELDS =
	SET
	CTX_L_HHEAD	= [0,0,32,0],		!Head of header binary tree
	CTX_L_EHEAD	= [4,0,32,0]		!Head of envelope binary tree
	TES;

    MACRO
	CTXDEF		= BLOCK [CTX_S_CTXDEF,BYTE] FIELD (CTX_FIELDS)%;

    LITERAL
	NODE_S_NODEDEF	= 4+4+2+2+8+8;

    FIELD
	NODE_FIELDS =
	SET
	NODE_L_LEFT	= [0,0,32,0],		!Left child
	NODE_L_RIGHT	= [4,0,32,0],		!Right child
	NODE_W_TYPE	= [8,0,16,0],		!Only two bytes used....
	NODE_W_NODETYPE	= [10,0,16,0],		!Spare two bytes
	NODE_Q_REALADDR	= [12,0,64,0],		!Real address
	NODE_Q_DESIRED	= [20,0,64,0]		!Desired address
	TES;

    MACRO
	NODEDEF		= BLOCK [NODE_S_NODEDEF,BYTE] FIELD (NODE_FIELDS)%;

!++
! RFC822 header codes
!--

    LITERAL
    	MX_K_HDR_FIRSTCODE  	= 1,
    	MX_K_HDR_FROM	    	= 1,
    	MX_K_HDR_SENDER	    	= 2,
    	MX_K_HDR_TO   	    	= 3,
    	MX_K_HDR_R_TO	    	= 4,
    	MX_K_HDR_CC   	    	= 5,
    	MX_K_HDR_R_CC	    	= 6,
    	MX_K_HDR_BCC  	    	= 7,
    	MX_K_HDR_R_BCC	    	= 8,
    	MX_K_HDR_MESSAGE_ID 	= 9,
    	MX_K_HDR_R_MESSAGE_ID	= 10,
    	MX_K_HDR_IN_REPLY_TO	= 11,
    	MX_K_HDR_REFERENCES 	= 12,
    	MX_K_HDR_KEYWORDS   	= 13,
    	MX_K_HDR_SUBJECT    	= 14,
    	MX_K_HDR_ENCRYPTED  	= 15,
    	MX_K_HDR_DATE	    	= 16,
    	MX_K_HDR_REPLY_TO   	= 17,
    	MX_K_HDR_RECEIVED   	= 18,
    	MX_K_HDR_R_REPLY_TO 	= 19,
    	MX_K_HDR_R_FROM	    	= 20,
    	MX_K_HDR_R_SENDER   	= 21,
    	MX_K_HDR_R_DATE	    	= 22,
    	MX_K_HDR_RETURN_PATH	= 23,
    	MX_K_HDR_OTHER	    	= 24,
    	MX_K_HDR_X_WARNING  	= 25,
    	MX_K_HDR_X_TO	    	= 26,
    	MX_K_HDR_X_R_TO	    	= 27,
    	MX_K_HDR_X_CC	    	= 28,
    	MX_K_HDR_X_R_CC	    	= 29,
    	MX_K_HDR_X_BCC	    	= 30,
    	MX_K_HDR_X_R_BCC    	= 31,
	MX_K_HDR_MIME_VERSION	= 32,
	MX_K_HDR_MIME_C_T_E	= 33,
	MX_K_HDR_MIME_C_TYPE	= 34,
    	MX_K_HDR_LASTCODE   	= 34;

GLOBAL ROUTINE INIT (context_a_a) =
BEGIN
!++
!
! ROUTINE NAME:     INIT
!
! FUNCTIONAL DESCRIPTION:
!
!   Allocates and initializes context block for subsequent name conversions.
!
!   Two binary trees are maintained---one for header rewrites and one
!   for envelope rewrites.
!
! RETURNS:      cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
!   INIT  ctxptr
!
! ctxptr:   pointer, longword (unsigned), modify, by reference
!
! IMPLICIT INPUTS:  None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
!   SS$_NORMAL:         normal successful completion.
!
! SIDE EFFECTS:
!
!   None.
!--
    BIND
	context		= .context_a_a	: REF CTXDEF;

    LOCAL
	inbuff	: $BBLOCK [1024],
	fab	: $FAB (FNM = 'MX_ALIAS_ADDRESSES',
			DNM = 'MX_DIR:.TXT',
			FAC = GET,
			SHR = GET),
	rab	: $RAB (FAB = fab,
			RAC = SEQ,
			UBF = inbuff,
			USZ = %ALLOCATION(inbuff)),
	str1	: $BBLOCK [DSC$K_S_BLN],
	str2	: $BBLOCK [DSC$K_S_BLN],
	status;

    !
    !  Allocate memory for the context.
    !
    status = LIB$GET_VM (%REF(CTX_S_CTXDEF), context);
    IF NOT (.status) THEN RETURN (.status);
    CH$FILL (%CHAR(0), CTX_S_CTXDEF, .context);

    !
    !  Try to open the alias file.
    !
    IF (status = $OPEN (FAB = fab))
    THEN
	status = $CONNECT (RAB = rab);

    IF NOT(.status)
    THEN
	RETURN (SS$_NORMAL);

    $INIT_DYNDESC (str1);
    $INIT_DYNDESC (str2);

    !
    !  Read in the records and add the address to the two binary trees.
    !  One tree is used for header rewrites, the other for envelope rewrites.
    !
    WHILE ($GET (RAB = rab)) DO
	BEGIN
	LOCAL x;

	IF (.rab [RAB$W_RSZ] GTRU 0) AND (.inbuff[0,0,8,0] NEQU %C'!')
	THEN
	    BEGIN
	    x = CH$FIND_CH (.rab [RAB$W_RSZ], inbuff, %CHAR(32));
	    IF CH$FAIL(.x)
	    THEN
		x = CH$FIND_CH (.rab [RAB$W_RSZ], inbuff, %CHAR(9));

	    IF NOT(CH$FAIL(.x))
	    THEN
		BEGIN
		LOCAL len, new_node;

		str1 [DSC$W_LENGTH]  = str2 [DSC$W_LENGTH]  = 0;
		str1 [DSC$A_POINTER] = str2 [DSC$A_POINTER] = 0;

		len = .x - inbuff;
		STR$COPY_R (str1, len, inbuff);

		WHILE ((CH$RCHAR(.x) EQLU %CHAR(32)) OR
		       (CH$RCHAR(.x) EQLU %CHAR(9))) DO
		    x = .x+1;

		len = CH$PLUS(inbuff, .rab [RAB$W_RSZ]) - .x;
		STR$COPY_R (str2, len, .x);
	    
		!
		!  For each record read, store in both B-trees.  The data isn't
		!  copied, only the descriptors for the two pieces.
		!
		status = LIB$INSERT_TREE (
			context [CTX_L_HHEAD],		!The header tree
			str1,				!The real address
			%REF(0),			!No duplicates
			compare_node,			!Comparison routine
			alloc_node,			!Allocation routine
			new_node,			!Address of new node
			str2);				!The desired address

		status = LIB$INSERT_TREE (
			context [CTX_L_EHEAD],		!The envelope tree
			str2,				!The real address
			%REF(0),			!No duplicates
			compare_node,			!Comparison routine
			alloc_node,			!Allocation routine
			new_node,			!Address of new node
			str1);				!The desired address

		END;

	    END;

	END;

    $CLOSE (FAB = fab);


    RETURN (SS$_NORMAL);

END;


GLOBAL ROUTINE REWRITE_HEADER (ctx_a_a, instr_a, outstr_a, code) =
BEGIN
!++
!
! ROUTINE NAME:     REWRITE_HEADER
!
! FUNCTIONAL DESCRIPTION:
!
! RETURNS:      cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
!   REWRITE_HEADER ctxptr, instr, outstr, code
!
! ctxptr:   pointer, longword (unsigned), modify, by reference
! instr:    char_string, character string, read only, by descriptor (fixed)
! outstr:   char_string, character string, write only, by descriptor
! code:     word_unsigned, word (unsigned), read only, by value/reference?
!
! IMPLICIT INPUTS:  None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
!   SS$_NORMAL:         normal successful completion.
!
! SIDE EFFECTS:
!
!   None.
!--
    BIND
	ctx	= .ctx_a_a	: REF CTXDEF,
	instr	= .instr_a	: $BBLOCK,
	outstr	= .outstr_a	: $BBLOCK;

    LOCAL
	new_node	: REF NODEDEF,
	str		: $BBLOCK [DSC$K_S_BLN],
	lclp		: $BBLOCK [DSC$K_S_BLN],
	domp		: $BBLOCK [DSC$K_S_BLN],
	status;

    status = 0;
    SELECTONE (.code) OF
	SET
	[MX_K_HDR_FROM, MX_K_HDR_R_FROM] :
		BEGIN
		!
		!  The address comes in with any personal name intact,
		!  so call PARSE_MBOX to get just the address to be
		!  looked up.
		!
		$INIT_DYNDESC (str);
		$INIT_DYNDESC (lclp);
		$INIT_DYNDESC (domp);
		PARSE_MBOX (instr, lclp, domp);
		STR$CONCAT (str, lclp, %ASCID'@', domp);

		!
		!  See if it's in the header tree and get the desired
		!  address if so.
		!
		status = LIB$LOOKUP_TREE (ctx [CTX_L_HHEAD],
				str, compare_node, new_node);
		IF (.status)
		THEN
		    BEGIN
		    LOCAL start, endpos;
		    start = STR$POSITION (instr, str);
		    endpos = .start + .str [DSC$W_LENGTH] - 1;

		    STR$REPLACE (outstr, instr, start, endpos,
				new_node [NODE_Q_DESIRED]);

		    END;

		STR$FREE1_DX (str);
		STR$FREE1_DX (lclp);
		STR$FREE1_DX (domp);
		END;
	TES;

    RETURN (.status);

END;


GLOBAL ROUTINE REWRITE_ENVELOPE (ctx_a_a, instr_a, outstr_a) =
BEGIN
!++
!
! ROUTINE NAME:     REWRITE_ENVELOPE
!
! FUNCTIONAL DESCRIPTION:
!
! RETURNS:      cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
!   REWRITE_ENVELOPE  ctxptr, instr, outstr
!
! ctxptr:   pointer, longword (unsigned), modify, by reference
! instr:    char_string, character string, read only, by descriptor (fixed)
! outstr:   char_string, character string, write only, by descriptor
!
! IMPLICIT INPUTS:  None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
!   SS$_NORMAL:         normal successful completion.
!
! SIDE EFFECTS:
!
!   None.
!--
    BIND
	ctx	= .ctx_a_a	: REF CTXDEF,
	instr	= .instr_a	: $BBLOCK,
	outstr	= .outstr_a	: $BBLOCK;

    LOCAL
	status,
	new_node	: REF NODEDEF,
	str		: $BBLOCK [DSC$K_S_BLN];

    $INIT_DYNDESC (str);

    !
    !  The address comes surrounded by "<>".  Take them off first.
    !
    
    IF (CH$RCHAR(.instr [DSC$A_POINTER]) EQLU %C'<')
    THEN
	STR$LEN_EXTR (str, instr, %REF(2),
			%REF (.instr [DSC$W_LENGTH] - 2));

    status = LIB$LOOKUP_TREE (ctx [CTX_L_EHEAD],
				str, compare_node, new_node);
    IF (.status)
    THEN
	STR$CONCAT (outstr, %ASCID'<', new_node [NODE_Q_DESIRED], %ASCID'>');


    STR$FREE1_DX (str);

    RETURN (.status);

END;


GLOBAL ROUTINE CLEANUP (ctx_a_a) =
BEGIN

    BIND
	ctx	= .ctx_a_a	: REF CTXDEF;


    IF (.ctx [CTX_L_HHEAD] NEQU 0)
    THEN
	dealloc_node (.ctx [CTX_L_HHEAD], 1);
    IF (.ctx [CTX_L_EHEAD] NEQU 0)
    THEN
	dealloc_node (.ctx [CTX_L_EHEAD], 0);

    LIB$FREE_VM (%REF(CTX_S_CTXDEF), ctx);

    RETURN (SS$_NORMAL);

END;


%SBTTL	'ALLOC_NODE'
ROUTINE alloc_node (key_a, node_a, data_a) =
BEGIN
!+
!
!  Routine:	ALLOC_NODE
!
!  Functional Description:
!
!	This routine is called by LIB$INSERT_TREE to allocate memory for
!	the node.
!
!  Formal parameters:
!
!	key_a		= Address of descriptor for the key
!	node_a		= Address of longword to receive address of memory
!	data_a		= Address of descriptor for user data
!
!  Returns:
!
!	R0	- Status
!
!  Side effects:
!
!	Allocates memory via LIB$GET_VM.
!
!-
    REGISTER
	status	: UNSIGNED LONG;

    BIND
	key	= .key_a	: VECTOR[,LONG],
	node	= .node_a	: LONG,
	data	= .data_a	: VECTOR[,LONG];

    LOCAL
	noderef	: REF NODEDEF;			!points to the node allocated

    !
    !  Allocate memory for the node.
    !
    status = LIB$GET_VM (%REF(NODE_S_NODEDEF), noderef);
    IF (.status)				!successful allocation?
    THEN					!Yes,
	BEGIN
	BIND
	    realaddr	= noderef [NODE_Q_REALADDR] : VECTOR[,LONG],
	    desired 	= noderef [NODE_Q_DESIRED] : VECTOR[,LONG];

	!
	!  To conserve memory, we don't actually copy the strings,
	!  just the string descriptors themselves.  That way, there is
	!  only one copy of the strings in memory.  Both B-trees will
	!  contain copies of the descriptors.
	!
	realaddr [0] = .key [0];
	realaddr [1] = .key [1];

	desired [0] = .data [0];
	desired [1] = .data [1];

	node = .noderef;			!Return address of the node

	END;

  RETURN (.status);				!Return the final status

END;						!End of alloc_node


%SBTTL	'COMPARE_NODE'
ROUTINE compare_node (key_a, node_a, data_a) =
BEGIN
!+
!
!  Routine:	COMPARE_NODE
!
!  Functional Description:
!
!	This routine is called by LIB$INSERT_TREE to compare two nodes.
!
!  Formal parameters:
!
!	key_a		= Address of quadword time value
!	node_a		= Address of node to compare
!	data_a		= Address of descriptor for user data
!
!  Returns:
!
!	R0	- -1	- First is less than second
!		   0	- Two are equal
!		   1	- First is greater than second
!
!-
    BIND
	key	= .key_a	: VECTOR[2,LONG],
	node	= .node_a	: NODEDEF,
	data	= .data_a	: $BBLOCK;

    RETURN (STR$CASE_BLIND_COMPARE (key, node [NODE_Q_REALADDR]));

END;						!End of compare_node


%SBTTL	'DEALLOC_NODE'
ROUTINE dealloc_node (node_a, dealloc_strings) =
BEGIN
!+
!
!  Routine:	DEALLOC_NODE
!
!  Functional Description:
!
!	This routine is called to deallocate the b-tree nodes.
!
!	THIS IS A RECURSIVE ROUTINE!
!
!  Formal parameters:
!
!	node_a		= Address of node to compare (by reference)
!	dealloc_strings	= Flag indicating whether or not the dynamic
!			  strings are to be deallocated too (by value)
!
!-
    BIND
	node	= .node_a	: NODEDEF;

    !
    !  Deallocate the left child node, if it exists.
    !
    IF (.node [NODE_L_LEFT] NEQU 0)
    THEN
	dealloc_node (.node [NODE_L_LEFT], .dealloc_strings);

    !
    !  Deallocate the right child node, if it exists.
    !
    IF (.node [NODE_L_RIGHT] NEQU 0)
    THEN
	dealloc_node (.node [NODE_L_RIGHT], .dealloc_strings);

    !
    !  If the strings are to be deallocated, do so.
    !
    IF (.dealloc_strings)
    THEN
	BEGIN
	STR$FREE1_DX (node [NODE_Q_REALADDR]);
	STR$FREE1_DX (node [NODE_Q_DESIRED]);
	END;

    !
    !  Now free memory held by node itself.
    !
    LIB$FREE_VM (%REF (NODE_S_NODEDEF), node_a);

    RETURN (SS$_NORMAL);

END;						!End of dealloc_node


%IF %VARIANT NEQU 0
%THEN
    EXTERNAL ROUTINE
	LIB$PUT_OUTPUT,
	LIB$SYS_FAO;

ROUTINE print_node (node_a, data_a) =
BEGIN

    BIND
	node	= .node_a	: NODEDEF;

    LOCAL
	faoout : $BBLOCK [DSC$K_S_BLN];

    $INIT_DYNDESC (faoout);

    LIB$SYS_FAO (%ASCID'   Real: !AS      Desired: !AS', 0, faoout,
		node [NODE_Q_REALADDR], node [NODE_Q_DESIRED]);

    LIB$PUT_OUTPUT (faoout);

    STR$FREE1_DX (faoout);

    RETURN (SS$_NORMAL);
END;



ROUTINE MAIN =
BEGIN

    LOCAL
	context		: REF CTXDEF,
	status,
	outstr		: $BBLOCK [DSC$K_S_BLN];

    $INIT_DYNDESC (outstr);

    status = INIT (context);
    IF NOT(.status) THEN RETURN (.status);

    LIB$PUT_OUTPUT (%ASCID'R Tree:');
    status = LIB$TRAVERSE_TREE (context [CTX_L_HHEAD], print_node);
    IF NOT(.status) THEN RETURN (.status);
    LIB$PUT_OUTPUT (%ASCID'D Tree:');
    status = LIB$TRAVERSE_TREE (context [CTX_L_EHEAD], print_node);
    IF NOT(.status) THEN RETURN (.status);

    status = REWRITE_HEADER (context, %ASCID'Hunter <goatest@ALPHA.WKU.EDU>',
		outstr, MX_K_HDR_FROM);

    IF (.status)
    THEN
	LIB$PUT_OUTPUT (outstr);

    status = REWRITE_ENVELOPE (context, %ASCID'<HUNTER.UNIX@ALPHA.WKU.EDU>',
		outstr);

    IF (.status)
    THEN
	LIB$PUT_OUTPUT (outstr);

    STR$FREE1_DX (outstr);

    CLEANUP (context);

    RETURN (.status);

END;

%FI

END						!End of module BEGIN
ELUDOM						!End of module