%TITLE 'DOM_EXPANSION_UCX'
MODULE DOM_EXPANSION_UCX (IDENT='V1.0', ADDRESSING_MODE (EXTERNAL=GENERAL)) =
BEGIN
!++
! FACILITY: 	    MX Examples
!
! ABSTRACT: 	    Example of a domain name expander for use with MX.
!   	    	    For use with VMS/ULTRIX Connection >>> V1.3 or later <<<
!
! MODULE DESCRIPTION:
!
!   This module contains the routines necessary for implementing
!   a domain name expander for use by the MX Router agent.  These
!   routines can be used to eliminate SMTP mail loops when mail
!   is addressed using an abbreviated host name, without having
!   to DEFINE PATH LOCAL for each abbreviation.
!
!   To use this module: modify it, if needed, then compile it
!   and link it with the commands:
!
!   	$ BLISS DOM_EXPANSION_UCX
!   	$ LINK/SHARE=DOM_EXPANSION/NOTRACE DOM_EXPANSION_UCX,SYS$INPUT:/OPT
!   	    UNIVERSAL=INIT,EXPAND,CLEANUP
!   	    <ctrl/Z>
!
!   Then copy it to MX_EXE and make it available to the Router with
!   the commands:
!
!   	$ COPY DOM_EXPANSION.EXE MX_EXE:
!   	$ DEFINE/SYSTEM/EXEC MX_SITE_DOM_EXPANSION MX_EXE:DOM_EXPANSION
!   	$ MCP RESET ROUTER
!
!   (You need a suitably privileged account to do this.)
!
! AUTHOR:   	    M. Madison
!
! Copyright (c) 2008, Matthew Madison.
! 
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 
!     * Redistributions of source code must retain the above
!       copyright notice, this list of conditions and the following
!       disclaimer.
!     * Redistributions in binary form must reproduce the above
!       copyright notice, this list of conditions and the following
!       disclaimer in the documentation and/or other materials provided
!       with the distribution.
!     * Neither the name of the copyright owner nor the names of any
!       other contributors may be used to endorse or promote products
!       derived from this software without specific prior written
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! CREATION DATE:    07-DEC-1990
!
! MODIFICATION HISTORY:
!
!   07-DEC-1990	V1.0	Madison	    Initial coding.
!--
    LIBRARY 'SYS$LIBRARY:STARLET';
    LIBRARY 'SYS$LIBRARY:UCX$INETDEF';

    EXTERNAL ROUTINE
    	STR$CONCAT, STR$COPY_R, STR$FREE1_DX, STR$UPCASE, STR$TRANSLATE,
    	LIB$GET_VM, LIB$FREE_VM;

    LITERAL
    	CTX_S_CTXDEF	= 2;

    FIELD
    	CTX_FIELDS =
    	SET
    	    CTX_W_CHAN	=   [0,0,16,0]
    	TES;

    MACRO
    	CTXDEF	= BLOCK [CTX_S_CTXDEF,BYTE] FIELD (CTX_FIELDS)%;

%SBTTL 'INIT'
GLOBAL ROUTINE INIT (CTX_A_A) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!   Called by the Router to initialize the module.  Could be used to
!   allocate any storage that will be needed by the EXPAND routine
!   (these routines must be reentrant, so OWN storage is right out).
!
! 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
    	CTX 	= .CTX_A_A  	: REF CTXDEF;

    LOCAL
    	STATUS;

    STATUS = LIB$GET_VM (%REF (CTX_S_CTXDEF), CTX);
    IF .STATUS THEN
    BEGIN
    	STATUS = $ASSIGN (DEVNAM=%ASCID'UCX$DEVICE', CHAN=CTX [CTX_W_CHAN]);
    	IF NOT .STATUS THEN LIB$FREE_VM (%REF (CTX_S_CTXDEF), CTX);
    END;

    .STATUS

END; ! INIT

%SBTTL 'EXPAND'
GLOBAL ROUTINE EXPAND (CTX_A_A, INSTR_A, OUTSTR_A) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!   This routine is called to perform a domain name expansion.
!
!   INSTR can be assumed to be a DTYPE_T, CLASS_S string descriptor
!   (or compatible).  You must use STR$ routines to copy the result
!   to OUTSTR!
!
! RETURNS:  	cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
!   EXPAND  ctxptr, instr, outstr
!
! ctxptr:   pointer, longword (unsigned), modify, by reference
! instr:    char_string, character string, read only, by descriptor
! 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,
    	CHN 	= CTX [CTX_W_CHAN]  : WORD,
    	INSTR	= .INSTR_A  	    : BLOCK [DSC$K_S_BLN,BYTE],
    	OUTSTR	= .OUTSTR_A 	    : BLOCK [DSC$K_S_BLN,BYTE];

    LOCAL
    	SUBF,
    	ADDR,
    	DSC1	: VECTOR [2,LONG],
    	DSC2	: VECTOR [2,LONG],
    	DSC3	: VECTOR [2,LONG],
    	IOSB	: VECTOR [4,WORD],
    	STR 	: BLOCK [DSC$K_S_BLN,BYTE],
    	NAMBUF	: VECTOR [255,BYTE],
    	OUTLEN	: WORD,
    	STATUS;

    $INIT_DYNDESC (STR);
    STR$UPCASE (STR, INSTR);
    SUBF = INETACP$C_TRANS * 256 + INETACP_FUNC$C_GETHOSTBYNAME;
    DSC1 [0] = 4;
    DSC1 [1] = SUBF;
    DSC2 [0] = 4;
    DSC2 [1] = ADDR;
    STATUS = $QIOW (CHAN=.CHN, FUNC=IO$_ACPCONTROL, IOSB=IOSB,
    	P1=DSC1, P2=STR, P3=OUTLEN, P4=DSC2);
    IF .STATUS THEN STATUS = .IOSB [0];
    IF NOT .STATUS THEN
    BEGIN
    	STR$TRANSLATE (STR, INSTR, %ASCID'abcdefghijklmnopqrstuvwxyz',
    	    	    %ASCID'ABCDEFGHIJKLMNOPQRSTUVWXYZ');
    	STATUS = $QIOW (CHAN=.CHN, FUNC=IO$_ACPCONTROL, IOSB=IOSB,
    	    P1=DSC1, P2=STR, P3=OUTLEN, P4=DSC2);
    	IF .STATUS THEN STATUS = .IOSB [0];
    END;
    STR$FREE1_DX (STR);
    IF .STATUS THEN
    BEGIN
    	SUBF = INETACP$C_TRANS * 256 + INETACP_FUNC$C_GETHOSTBYADDR;
    	DSC3 [0] = %ALLOCATION (NAMBUF);
    	DSC3 [1] = NAMBUF;
    	STATUS = $QIOW (CHAN=.CHN, FUNC=IO$_ACPCONTROL, IOSB=IOSB,
    	    P1=DSC1, P2=DSC2, P3=OUTLEN, P4=DSC3);
    	IF .STATUS THEN STATUS = .IOSB [0];
    END;
    IF .STATUS THEN STATUS = STR$COPY_R (OUTSTR, OUTLEN, NAMBUF);

    .STATUS

END; ! EXPAND

%SBTTL 'CLEANUP'
GLOBAL ROUTINE CLEANUP (CTX_A_A) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!   Called by the Router to clean up any context info set up by
!   INIT.
!
! RETURNS:  	cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
!   CLEANUP  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
    	CTX 	= .CTX_A_A  	: REF CTXDEF;

    $DASSGN (CHAN=.CTX [CTX_W_CHAN]);
    LIB$FREE_VM (%REF (CTX_S_CTXDEF), CTX);
    CTX = 0;

    SS$_NORMAL

END; ! CLEANUP

END
ELUDOM