%TITLE 'FORWARD_MESSAGE'
MODULE FORWARD_MESSAGE (IDENT='V1.6-1',
    	ADDRESSING_MODE (EXTERNAL=LONG_RELATIVE, NONEXTERNAL=LONG_RELATIVE)) =
BEGIN
!++
! FACILITY: 	    MX_LOCAL local delivery agent
!
! ABSTRACT: 	    Routines for forwarding messages.
!
! MODULE DESCRIPTION:
!
!   This module contains routine FORWARD_MESSAGE, which forwards a message
!   to one or more users.
!
! AUTHOR:   	    M. Madison
!		    Copyright © 1993,1994, MadGoat Software.  All Rights Reserved.
!
! CREATION DATE:    15-DEC-1989
!
! MODIFICATION HISTORY:
!
!   15-DEC-1989	V1.0	Madison	    Initial coding.
!   21-DEC-1989	V1.0-1	Madison	    Added multiple-user support (for lists).
!   02-JAN-1990	V1.0-2	Madison	    Fixed FORWARD_ERROR call problem.
!   22-JAN-1990	V1.1-3	Madison	    Make Resent-From a bit more accurate.
!   04-APR-1990	V1.2-4	Madison	    Add debug/trace.
!   07-FEB-1991	V1.3	Madison	    Use new COPY_FILE routine.
!   22-OCT-1991	V1.4	Madison	    Use RCPTDEF structure, MSG_TEXT FID.
!   15-NOV-1991	V1.4-1	Madison	    New MEM RCPT rtns.
!   13-MAR-1992	V1.4-2	Madison	    Ditch the resent- headers stuff.
!   10-FEB-1994 V1.5	Goatley     Modify to work with FLQ V2.
!   27-FEB-1994	V1.6	Madison	    Limit number of recipients per message to 100.
!   24-SEP-1996 V1.6-1  Wing        Limit max recipients based on logical name
!--
    LIBRARY 'SYS$LIBRARY:STARLET';
    LIBRARY '[MX.COMMON]FLQ';
    LIBRARY 'MDM_LIBRARY:BLISSMDM';
    LIBRARY '[MX.COMMON]MX';
    LIBRARY '[MX.COMMON]AGENT';
    LIBRARY 'MLF';

    EXTERNAL LITERAL
    	MX__FWDLOOP;

    EXTERNAL ROUTINE
    	FORWARD_ERROR,
    	G_HAT (VMS_TO_MX),
    	G_HAT (WRITE_HDRS, WRITE_INFO, PARSE_MBOX, COPY_FILE,
    	    	MEM_GETRCPT, MEM_FREERCPT),
    	G_HAT (STR$CONCAT, STR$COPY_DX, STR$APPEND, LIB$CVT_DTB);

    OWN
    	FWD_MAX;

    EXTERNAL
    	CONFIG	    : CFGDEF,
    	DEBUG,
    	TRACE_UNIT;

%SBTTL 'FORWARD_MESSAGE'
GLOBAL ROUTINE FORWARD_MESSAGE (QCTX, QENT_A, SENDER_A, USR_A, HDRQ_A,
    	    	    	    	    FWDQUE_A, DUMMY_ARG) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!   Forwards a mail message.  If the message has already been resent from
!   this user, the message is returned to sender with a loop-detection
!   error message.
!
! RETURNS:  	cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
!   FORWARD_MESSAGE  qctx, qent, sender, usr, hdrq, fwdque [,irh]
!
! IMPLICIT INPUTS:  None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
!   SS$_NORMAL:	    	normal successful completion.
!
! SIDE EFFECTS:
!
!   None.
!--
    BUILTIN
    	ACTUALCOUNT;

    BIND
    	QENT	= .QENT_A   	: QENTDEF,
    	SENDER	= .SENDER_A 	: BLOCK [,BYTE],
    	USR 	= .USR_A    	: RCPTDEF,
    	HDRQ	= .HDRQ_A   	: QUEDEF,
    	FWDQUE	= .FWDQUE_A 	: QUEDEF;

    LOCAL
    	NEWENT	: QENTDEF,
    	SDSC	: BLOCK [DSC$K_S_BLN,BYTE],
    	STR 	: BLOCK [DSC$K_S_BLN,BYTE],
    	LCLP	: BLOCK [DSC$K_S_BLN,BYTE],
    	DOMP	: BLOCK [DSC$K_S_BLN,BYTE],
    	TXT 	: REF TXTDEF,
    	FWDUSR	: REF RCPTDEF,
    	R   	: REF RCPTDEF,
    	RCPQ	: QUEDEF,
    	HDRCT,
    	RCPCT,
    	COUNT,
    	STATUS;

    INIT_DYNDESC (STR, LCLP, DOMP);

    SDSC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
    SDSC [DSC$B_CLASS] = DSC$K_CLASS_S;

    HDRCT = 0;

    FWDUSR = .FWDQUE [QUE_L_HEAD];

    WHILE (.FWDUSR NEQA FWDQUE) DO
    BEGIN
    	FLQ_INIT_QENT (NEWENT);
    	NEWENT [QENT_L_STATUS] = FLQ_K_STINP;
    	NEWENT [QENT_V_LOCK] = 1;
    	newent [QENT_L_DSTPRC] = FLQ_K_MX_ROUTER;
    	newent [QENT_L_ORIGIN] = MX_K_ORG_LOCAL;
    	STATUS = FLQ_ADD (QCTX, NEWENT);
    	IF NOT .STATUS THEN
    	BEGIN
    	    TRACE ('  FORWARD_MESSAGE: Sts=!XL on adding queue entry.');
    	    FORWARD_ERROR (USR, FWDQUE, .STATUS);
    	    INCR I FROM 1 TO .HDRCT DO
    	    BEGIN
    	    	REMQUE (.HDRQ [QUE_L_HEAD], TXT);
    	    	FREETXT (TXT);
    	    END;
       	    RETURN .STATUS;
    	END;

    	TRACE ('  FORWARD_MESSAGE:  Forwarding queue entry number=!UL',
    	    .NEWENT [QENT_L_ENTNUM]);

    	WRITE_HDRS (.QCTX, NEWENT, %ASCID'HDR_INFO', HDRQ);

    	RCPCT = 0;
    	INIT_QUEUE (RCPQ);

!+
        FWD_MAX = 0;;
        MDM_SYS_TRNLNM (%ASCID'MX_MLF_FORWARD_MAXIMUM', 0, 0, 0, STR);
        IF .STR [DSC$W_LENGTH] GTR 0 THEN
             LIB$CVT_DTB (.STR [DSC$W_LENGTH], .STR [DSC$A_POINTER], FWD_MAX);
        IF .FWD_MAX EQL 0 THEN FWD_MAX = 100;
        TRACE('  FORWARD_MESSAGE:  FWD_MAX=!UL', .FWD_MAX);
!-
        
    	WHILE (.FWDUSR NEQA FWDQUE [QUE_L_HEAD]) AND (.RCPCT LSS .FWD_MAX) DO
    	BEGIN
    	    SDSC [DSC$W_LENGTH] = .FWDUSR [RCPT_W_ADDR];
    	    SDSC [DSC$A_POINTER] = FWDUSR [RCPT_T_ADDR];
    	    TRACE ('  FORWARD_MESSAGE: Forwarding to: !AS', SDSC);
    	    MEM_GETRCPT (R);
    	    CH$FILL (%CHAR (0), RCPT_S_RCPTDEF, .R);
    	    IF CH$RCHAR (FWDUSR [RCPT_T_ADDR]) NEQ %C'<' THEN
    	    BEGIN
    	    	STR$CONCAT (STR, %ASCID'<', SDSC, %ASCID'>');
    	    	R [RCPT_W_ADDR] = MIN (RCPT_S_ADDR, .STR [DSC$W_LENGTH]);
    	    	CH$MOVE (.R [RCPT_W_ADDR], .STR [DSC$A_POINTER], R [RCPT_T_ADDR]);
    	    	INSQUE (.R, .RCPQ [QUE_L_TAIL]);
    	    END
    	    ELSE
    	    BEGIN
    	    	R [RCPT_W_ADDR] = .FWDUSR [RCPT_W_ADDR];
    	    	CH$MOVE (.R [RCPT_W_ADDR], FWDUSR [RCPT_T_ADDR], R [RCPT_T_ADDR]);
    	    	INSQUE (.R, .RCPQ [QUE_L_TAIL]);
    	    END;
    	    RCPCT = .RCPCT + 1;
    	    FWDUSR = .FWDUSR [RCPT_L_FLINK];
    	END;

    	SDSC [DSC$W_LENGTH] = .USR [RCPT_W_ADDR];
    	SDSC [DSC$A_POINTER] = USR [RCPT_T_ADDR];
    	PARSE_MBOX (SENDER, LCLP, DOMP);
    	STR$CONCAT (STR, LCLP, %ASCID'@', DOMP);

    	STORE_ORGADR (newent, str);

    	WRITE_INFO (.QCTX, NEWENT, %ASCID'SRC_INFO', SENDER, RCPQ,
    	    MX_K_ORG_LOCAL, SDSC);
    	WHILE NOT REMQUE (.RCPQ [QUE_L_HEAD], R) DO
    	    MEM_FREERCPT (R);

    	FLQ_MAKE_FSPEC (.NEWENT [QENT_L_ENTNUM], %ASCID'MSG_TEXT', DOMP);
    	IF CH$EQL (MXQ_S_FILEID, QENT [MXQ_X_FILEID], 4, UPLIT (0), %CHAR (0)) THEN
    	BEGIN
    	    FLQ_MAKE_FSPEC (.QENT [MXQ_L_BACKREF], %ASCID'MSG_TEXT', LCLP);
    	    STATUS = COPY_FILE (LCLP, DOMP, 0, 0, COUNT);
    	END
    	ELSE STATUS = COPY_FILE (0, DOMP, 0, 0, COUNT, QENT [MXQ_X_FILEID]);
    	IF .STATUS THEN
    	BEGIN    	
    	    NEWENT [QENT_L_SIZE] = (.COUNT + .NEWENT [QENT_L_SIZE]) * .RCPCT;
    	    NEWENT [QENT_L_STATUS] = FLQ_K_STRDY;
    	END
    	ELSE
    	BEGIN
    	    FORWARD_ERROR (USR, FWDQUE, .STATUS);
    	    NEWENT [QENT_L_STATUS] = FLQ_K_STCAN;
    	END;

    	FLQ_UPDATE (QCTX, NEWENT);

    END;

    INCR I FROM 1 TO .HDRCT DO
    BEGIN
    	REMQUE (.HDRQ [QUE_L_HEAD], TXT);
    	FREETXT (TXT);
    END;

    FREE_STRINGS (STR, LCLP, DOMP);

    SS$_NORMAL

END; ! FORWARD_MESSAGE

END
ELUDOM