%TITLE 'PROCESS'
MODULE PROCESS (IDENT='V4.2-2', ADDRESSING_MODE (EXTERNAL=LONG_RELATIVE)) =
BEGIN
!++
! FACILITY: 	    MX_LOCAL
!
! ABSTRACT: 	    Main processing routines for MX LOCAL agent.
!
! MODULE DESCRIPTION:
!
!   This module contains the standard MX processing agent's INIT and
!   PROCESS routines, for processing of messages destined for the
!   local system or cluster.
!
! 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:    12-DEC-1989
!
! MODIFICATION HISTORY:
!
!   12-DEC-1989	V1.0	Madison	    Initial coding.
!   10-JAN-1990	V1.0-1	Madison	    Added Fileserv support.
!   19-JAN-1990	V1.0-2	Madison	    Change local,list,fileserv check order.
!   16-MAR-1990	V1.0-3	Madison	    Fix retry count exceeded bug
!   04-APR-1990	V1.1-4	Madison	    Add debug/trace.
!   03-MAY-1990	V1.1-5	Madison	    Debug logs were going into SMTP directory.
!   25-JUN-1990	V1.2-6	Madison	    Use CHECK_REFS_ZERO.
!   27-JUN-1990	V1.3-7	Madison	    Move mlist/file stuff to separate agent.
!   24-SEP-1990	V1.4-8	Madison	    IPC update.
!   03-OCT-1990	V1.5	Madison	    Improve local-part de-quoting.
!   26-OCT-1990	V1.5-1	Madison	    Short-cut non-MX fwding addresses.
!   11-FEB-1991	V2.0	Madison	    Accounting, programmed header support.
!   14-FEB-1991	V2.0-1	Madison	    Slight accounting support change.
!   12-MAR-1991	V2.0-2	Madison	    Eliminate divide-by-zero possibility.
!   02-APR-1991	V2.0-3	Madison	    Retried entries weren't getting FIN'd.
!   22-OCT-1991	V2.1	Madison	    New RCPTDEF structure.
!   07-NOV-1991	V2.1-1	Madison	    Fix acctg reset.
!   15-NOV-1991	V2.1-2	Madison	    New MEM RCPT rtns.
!   05-MAR-1993	V2.2	Madison	    Add MM support.
!   29-AUG-1993 V2.3	Goatley     Modified to disallow MM delivery.
!    7-JAN-1994 V2.3-1	Goatley     Modified to allow MM delivery retries.
!   11-FEB-1994 V2.4	Goatley     Modify to work with FLQ V2.
!    4-DEC-1995 V3.0	Goatley     Beef up error handling during processing.
!   12-JAN-1997	V3.1	Madison	    Eliminate MDMLIB.
!   28-JUL-1997 V3.1-1	Goatley	    Fix TRACE msgs added in V3.0.
!   27-AUG-1997 V3.1-2	Goatley     Add call to get VMS version number.
!   29-AUG-1997	V3.2	Madison	    RCPT change.
!   19-APR-1998	V4.0	Madison	    Remove MM support, add folder delivery.
!   26-APR-1998	V4.0-1	Madison	    Give user control over folder deliveries.
!   01-JUN-1998	V4.0-2	Madison	    Fix reinit check in INIT.
!   11-JUL-1998	V4.1	Madison	    DSN support.
!   12-AUG-1998	V4.1-1	Madison	    DSN fix.
!   24-JAN-2000	V4.1-2	Madison	    Put back CC-to-postmaster support.
!   15-FEB-2002 V4.2    Madison     One-at-a-time delivery for Original-Recipient support.
!   23-NOV-2002 V4.2-1  Madison     Define SYS$BATCH and SYS$PRINT for FDL problem.
!   08-FEB-2003 V4.2-2  Madison     Local forwarder should use original RFC-format address.
!--
    LIBRARY 'SYS$LIBRARY:STARLET';
    LIBRARY 'MX_SRC_COMMON:FLQ';
    LIBRARY 'MX_SRC_COMMON:MX';
    LIBRARY 'MX_SRC_COMMON:AGENT';
    LIBRARY 'MX_SRC_COMMON:ACCOUNTING';
    LIBRARY 'MX_SRC_COMMON:MX_LCLDEFS';

    ACC_DEFINE;

    FORWARD ROUTINE
    	INIT,
    	PROCESS,
    	folder_name_ok;

    OWN
    	luctx;

    EXTERNAL LITERAL
    	MX__FWDUSER, MX__LCLUSER, MX__RETRYEXCD;

    EXTERNAL ROUTINE
    	DELIVER,
    	FORWARD_MESSAGE,
    	RFC_TO_LOCAL,
    	LOAD_MXCONFIG,
    	G_HAT (READ_ENVELOPE, WRITE_ENVELOPE, READ_HDRS, CHECK_REFS_ZERO, MEM_FREERCPT),
    	G_HAT (DISPOSE_ENVELOPE, DSN_REPORT_INIT, DSN_REPORT_ADD_RCPT, DSN_REPORT_SEND),
    	G_HAT (MX_LOCAL_USER_INIT, MX_LOCAL_USER, MX_LOCAL_USER_FINISH, MX_FMT_LCL_ADDR, QUOTE_STRING),
    	G_HAT (MX_FILE_OPEN, MX_FILE_READ, MX_FILE_CLOSE, LOG_EVENT, MEM_GETTXT, PARSE_MBOX),
    	G_HAT (STR$COPY_R, STR$COPY_DX, LIB$GET_VM, LIB$FREE_VM, LIB$SYS_FAO,
    	    LIB$DELETE_FILE, STR$CASE_BLIND_COMPARE, STR$UPCASE, LIB$ADD_TIMES);

    EXTERNAL
    	CONFIG	    : CFGDEF;

    GLOBAL
    	LOCAL_INFO  	: LOCALDEF,
	VMS_VERSION	: VECTOR[8,BYTE],
	SIGFILE_SUPPORT;			!Used by DELIVER.B32

    TRACE_DECLARATIONS (GLOBAL);

    BIND
        sys_batch   = %ASCID'SYS$BATCH'     : BLOCK [,BYTE],
        sys_print   = %ASCID'SYS$PRINT'     : BLOCK [,BYTE],
        lnm_process = %ASCID'LNM$PROCESS'   : BLOCK [,BYTE],
        nla0        = %ASCID'_NLA0:'        : BLOCK [,BYTE];

%SBTTL 'INIT'
GLOBAL ROUTINE INIT (REINIT) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!   Initialization routine.
!
! RETURNS:  	cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
!   INIT reinitflag
!
! IMPLICIT INPUTS:  None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
!   SS$_NORMAL:	    	normal successful completion.
!
! SIDE EFFECTS:
!
!   None.
!--
    BIND
    	RSTMSK	= REINIT : RSTDEF;

    LOCAL
        syi_items       : $ITMLST_DECL(ITEMS=1),
        iosb            : VECTOR[4,WORD],
    	lnmlst          : $ITMLST_DECL (ITEMS=1),
    	STATUS;

    ACC_CLOSE;

    IF .reinit EQL 0 THEN
    BEGIN
        $ITMLST_INIT (ITMLST = syi_items,
            (ITMCOD = SYI$_VERSION,
	     BUFADR = vms_version,
	     BUFSIZ = %ALLOCATION(vms_version)));

        sigfile_support = 0;
        status = $GETSYIW(ITMLST = syi_items, IOSB = iosb);
        IF .status AND .iosb [0] THEN
	    IF .vms_version[1] GEQU %C'7' THEN
	        sigfile_support = 1;
        $ITMLST_INIT (ITMLST=lnmlst,
            (ITMCOD=LNM$_STRING, BUFADR=.nla0 [DSC$A_POINTER],
             BUFSIZ=.nla0 [DSC$W_LENGTH]));
        status = $CRELNM (TABNAM=lnm_process, LOGNAM=sys_batch,
                          ITMLST=lnmlst);
        IF .status THEN
            status = $CRELNM (TABNAM=lnm_process, LOGNAM=sys_print,
                              ITMLST=lnmlst);
        IF NOT .status THEN
            RETURN .status;
    END;

    IF .reinit NEQ 0 THEN MX_LOCAL_USER_FINISH (luctx);

    IF .REINIT EQL 0 OR .RSTMSK [RST_V_CONFIG] THEN
    BEGIN
    	STATUS = LOAD_MXCONFIG (%ASCID'MX_CONFIG', %ASCID'MX_DIR:.MXCFG', 0, 
    	    	CFG_M_LOCALINFO);
    	IF NOT .STATUS THEN RETURN .STATUS;
    END;

    IF .LOCAL_INFO [LOCAL_V_ACCTG]
    THEN
    BEGIN
    	STATUS = ACC_INIT (%ASCID'MX_LOCAL_ACC', %ASCID'MX_LOCAL_DIR:.DAT',
    	    	    .RSTMSK [RST_V_ACCTG]);
    	IF NOT .STATUS THEN RETURN .STATUS;
    END;

    status = MX_LOCAL_USER_INIT (luctx);
    IF NOT .status THEN RETURN .status;

    SS$_NORMAL

END; ! INIT

%SBTTL 'PROCESS'
GLOBAL ROUTINE PROCESS (QCTX, QENT_A) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!   Processes a single queue entry.
!
! RETURNS:  	cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
!   PROCESS  qctx, qent
!
! IMPLICIT INPUTS:  None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
!   SS$_NORMAL:	    	normal successful completion.
!
! SIDE EFFECTS:
!
!   None.
!--
    BIND
    	QENT	= .QENT_A   : QENTDEF;

    LOCAL
    	envl	: ENVLDEF,
    	HDRQ	: QUEDEF,
    	RETRY	: QUEDEF,
    	decnetq : QUEDEF,
    	REFENT	: QENTDEF,
    	RCPT	: REF RCPTDEF,
    	RCPT1	: REF RCPTDEF,
    	RCPT2	: REF RCPTDEF,
    	TXT 	: REF TXTDEF,
    	MLST	: REF MLSTDEF,
    	USR 	: BLOCK [DSC$K_S_BLN,BYTE],
    	STR 	: BLOCK [DSC$K_S_BLN,BYTE],
    	folder	: BLOCK [DSC$K_S_BLN,BYTE],
    	INTBUF	: BLOCK [8,BYTE],
    	NOWTIM	: BLOCK [8,BYTE],
    	MSG_SIZE,
    	dsnctx,
    	STATUS;

    INIT_QUEUE (HDRQ);
    INIT_DYNDESC (STR, USR, folder);

    TRACE_INIT ('local', 'local');

    refent [QENT_L_ENTNUM] = 0;

    TRACE ('===================================================');
    TRACE ('Processing queue entry number !UL', .qent [QENT_L_ENTNUM]);

    status = 0;
    IF (.qent [MXQ_L_BACKREF] NEQU 0)
    THEN
	status = FLQ_READ (qctx, .qent [MXQ_L_BACKREF], refent);

    IF NOT(.status)
    THEN
	BEGIN
	ALARM ('MX Local: error reading BACKREF !UL for entry !UL: !XL',
			.qent [MXQ_L_BACKREF], .qent [QENT_L_ENTNUM], .status);
	!
	!  Cancel this entry and return
	!
	TRACE ('Cancelling entry---invalid BACKREF !UL', .qent [MXQ_L_BACKREF]);
	qent [QENT_L_STATUS] = FLQ_K_STCAN;
	FLQ_UPDATE (qctx, qent);
	RETURN (SS$_NORMAL);
	END
    ELSE
	status = FLQ_UPDATE (qctx, refent);

    !
    !  Now read the LOCAL_INFO file.
    !
    CH$FILL (%CHAR (0), ENVL_S_ENVLDEF, envl);
    INIT_QUEUE (envl [ENVL_Q_RCPTQUE]);
    status = READ_ENVELOPE (.qctx, qent, %ASCID'LOCAL_INFO', envl);
    IF NOT(.status)
    THEN
	BEGIN
	ALARM ('MX Local: error reading LOCAL_INFO file for entry !UL: !XL',
			.qent [QENT_L_ENTNUM], .status);
	TRACE ('%PROCESS, error reading LOCAL_INFO file for entry !UL: !XL',
			.qent [QENT_L_ENTNUM], .status);
	END
    ELSE
	BEGIN
	status = READ_HDRS (.qctx, refent, %ASCID'HDR_INFO', hdrq);
	IF NOT(.status)
	THEN
	    BEGIN
	    ALARM ('MX Local: error reading HDR_INFO file for entry !UL: !XL',
			.refent [QENT_L_ENTNUM], .status);
	    TRACE ('%PROCESS, error reading HDR_INFO file for entry !UL: !XL',
			.refent [QENT_L_ENTNUM], .status);
	    END;
	END;

    IF NOT(.status) OR .envl [ENVL_L_RCPTCOUNT] EQL 0
    THEN
	BEGIN
	!
	!  Eliminate pointer to this LOCAL entry and CANCEL the Router
	!  entry if there are no other forward pointers.
	!
	refent [MXQ_L_LOCALREF] = 0;
	IF CHECK_REFS_ZERO (refent)	!If there are no other forwards....
	THEN
	    BEGIN
	    ALARM ('MX Local: HOLDing Router entry !UL', .refent [QENT_L_ENTNUM]);
	    refent [QENT_L_STATUS] = FLQ_K_STOPH;
	    END;

	status = FLQ_UPDATE (qctx, refent);
	qent [QENT_L_STATUS] = FLQ_K_STCAN;	!Cancel this entry
	status = FLQ_UPDATE (qctx, qent);
	FREE_STRINGS (str);
	RETURN (SS$_NORMAL);
	END;

    DSN_REPORT_INIT (dsnctx, envl, .local_info [LOCAL_V_CC_POSTMASTER]);

    MSG_SIZE = .QENT [QENT_L_SIZE] / .envl [ENVL_L_RCPTCOUNT];

    INIT_QUEUE (decnetq, RETRY);

    WHILE NOT REMQUE_HEAD (envl [ENVL_Q_RCPTQUE], RCPT1) DO
    BEGIN
    	LOCAL
    	    ra	    : REF TXTDEF,
    	    actual  : REF TXTDEF,
    	    sdsc    : BLOCK [DSC$K_S_BLN,BYTE],
    	    sender : BLOCK [DSC$K_S_BLN,BYTE];
    	BIND_ENVL_FIELDS (envl);

    	INIT_SDESC (SENDER, .fromadr [TXT_W_LEN], fromadr [TXT_T_TEXT]);

    	IF NOT RFC_TO_LOCAL (.RCPT1, RCPT) THEN
    	    RCPT = .RCPT1;

    	ra = .RCPT [RCPT_A_ADDR];
    	TRACE ('  Checking local name: !AD', .ra [TXT_W_LEN], ra [TXT_T_TEXT]);

    	INIT_SDESC (sdsc, .ra [TXT_W_LEN], ra [TXT_T_TEXT]);

    	actual = 0;
    	STATUS = MX_LOCAL_USER (luctx, sdsc, actual, folder);

    	IF .status EQL MX__LCLUSER AND .folder [DSC$W_LENGTH] NEQ 0 THEN
    	    IF NOT folder_name_ok (.actual [TXT_W_LEN], actual [TXT_T_TEXT], folder) THEN
    	    	FREE_STRINGS (folder);

    	SELECTONE .STATUS OF
    	SET
    	    [MX__FWDUSER] :
    	    	BEGIN
    	    	    LOCAL
    	    	    	FWDQ : QUEDEF;

    	    	    INIT_QUEUE (FWDQ);

    	    	    TRACE ('    Forwarding to: !AD', .actual [TXT_W_LEN], actual [TXT_T_TEXT]);
    	    	    rcpt [RCPT_L_STATUS] = FORWARD_MESSAGE (.QCTX, QENT, SENDER, rcpt, HDRQ, actual, 0);
    	    	    DSN_REPORT_ADD_RCPT (dsnctx, rcpt, 2);
    	    	    MEM_FREERCPT (rcpt);
    	    	    IF .actual NEQA 0 THEN FREETXT (actual);
    	    	END;

    	    [MX__LCLUSER] :
    	    	BEGIN
                    LOCAL
                        tmpq    : QUEDEF;

                    INIT_QUEUE (tmpq);
    	    	    IF .folder [DSC$W_LENGTH] NEQ 0 THEN
    	    	    	TRACE ('    This is a folder delivery to !AD, folder !AS.',
    	    	    	    	    .actual [TXT_W_LEN], actual [TXT_T_TEXT], folder)
                    ELSE
    	    	    	TRACE ('    This is a regular delivery to !AD.', .actual [TXT_W_LEN], actual [TXT_T_TEXT]);
    	    	    INSQUE (.rcpt, .tmpq [QUE_L_TAIL]);
    	    	    IF .rcpt [RCPT_A_ROUTE] NEQA 0 THEN FREETXT (rcpt [RCPT_A_ROUTE]);
    	    	    rcpt [RCPT_A_ROUTE] = .actual;
    	    	    DELIVER (qent, sender, tmpq, hdrq, retry,
                             (IF .folder [DSC$W_LENGTH] EQL 0 THEN 0 ELSE folder), dsnctx);
    	    	END;

    	    [OTHERWISE] :
    	    	BEGIN
    	    	    LOCAL
    	    	    	lnmlst	: $ITMLST_DECL (ITEMS=1),
                        ora     : REF TXTDEF,
                        odsc    : BLOCK [DSC$K_S_BLN,BYTE],
    	    	    	tmp 	: BLOCK [DSC$K_S_BLN,BYTE],
    	    	    	fdsc	: BLOCK [DSC$K_S_BLN,BYTE],
    	    	    	flen	: WORD,
    	    	    	fbuf	: VECTOR [255,BYTE];
    	    	    $ITMLST_INIT (ITMLST=lnmlst,
    	    	    	    	    (ITMCOD=LNM$_STRING, BUFADR=fbuf, BUFSIZ=%ALLOCATION (fbuf),
    	    	    	    	     RETLEN=flen));
    	    	    IF $TRNLNM (TABNAM=%ASCID'LNM$FILE_DEV', LOGNAM=%ASCID'MX_LOCAL_FORWARDER',
    	    	    	    	ACMODE=%REF (PSL$C_EXEC), ITMLST=lnmlst) THEN
    	    	    BEGIN
    	    	    	INIT_SDESC (fdsc, .flen, fbuf);
                        ora = .rcpt1 [RCPT_A_ADDR];
                        INIT_SDESC (odsc, .ora [TXT_W_LEN], ora [TXT_T_TEXT]);
                        INIT_DYNDESC (tmp);
    	    	    	MX_FMT_LCL_ADDR (MX__FMT_ENVFROM OR FMT_M_LOWERCASE, odsc, tmp, 0, 0, fdsc);
    	    	    	TRACE ('     ... auto-forwarding to !AS', tmp);
    	    	    	actual = MEM_GETTXT (.tmp [DSC$W_LENGTH], .tmp [DSC$A_POINTER]);
    	    	    	rcpt [RCPT_L_STATUS] = FORWARD_MESSAGE (.qctx, qent, sender, rcpt, hdrq, actual, 1);
    	    	    	DSN_REPORT_ADD_RCPT (dsnctx, rcpt, 2);
    	    	    	MEM_FREERCPT (rcpt);
    	    	    	FREETXT (actual);
    	    	    	FREE_STRINGS (tmp);
    	    	    END
    	    	    ELSE
    	    	    BEGIN
    	    	    	TRACE ('     Don''t know what this is (status = !XL).', .status);
    	    	    	rcpt [RCPT_L_DSN_STATUS] = MX__DSN_FA_BADMBX;
    	    	    	rcpt [RCPT_L_STATUS] = .status;
    	    	    	DSN_REPORT_ADD_RCPT (dsnctx, rcpt, 2);
    	    	    	MEM_FREERCPT (RCPT);
    	    	    	IF .actual NEQA 0 THEN FREETXT (actual);
    	    	    END;
    	    	END;

    	TES;

        IF .rcpt NEQA .rcpt1 THEN
            MEM_FREERCPT (rcpt1);

    END; ! while not remque

    QENT [QENT_V_DELAY] = 0;

    envl [ENVL_L_RCPTCOUNT] = 0;
    WHILE NOT REMQUE (.retry [QUE_L_HEAD], rcpt) DO
    BEGIN
    	BIND ra = .rcpt [RCPT_A_ADDR] : TXTDEF;
    	IF .RCPT [RCPT_W_CNT1] GEQ .LOCAL_INFO [LOCAL_L_MAXTRIES] THEN
    	BEGIN
    	    LOCAL TMP : REF RCPTDEF;
    	    BIND ds = rcpt [RCPT_L_DSN_STATUS] : BLOCK [,BYTE];
    	    TRACE ('  No more retries allowed for !AD, count=!UL',
    	    	.ra [TXT_W_LEN], ra [TXT_T_TEXT], .RCPT [RCPT_W_CNT1]);
    	    ds [STS$V_SEVERITY] = STS$K_SEVERE;
    	    DSN_REPORT_ADD_RCPT (dsnctx, rcpt, 2);
    	    TMP = .RCPT [RCPT_L_FLINK];
    	    MEM_FREERCPT (RCPT);
    	    RCPT = .TMP;
    	END
    	ELSE
    	BEGIN
    	    DSN_REPORT_ADD_RCPT (dsnctx, rcpt, 2);
    	    RCPT [RCPT_W_CNT1] = .RCPT [RCPT_W_CNT1] + 1;
    	    envl [ENVL_L_RCPTCOUNT] = .envl [ENVL_L_RCPTCOUNT] + 1;
    	    INSQUE_TAIL (.rcpt, envl [ENVL_Q_RCPTQUE]);
    	END;
    END;

    DSN_REPORT_SEND (dsnctx, .qctx, MX_K_ORG_LOCAL, hdrq, refent, envl);

    IF NOT QUEUE_EMPTY (envl [ENVL_Q_RCPTQUE]) THEN
    BEGIN
    	WRITE_ENVELOPE (.QCTX, QENT, %ASCID'LOCAL_INFO', envl);
    	QENT [QENT_L_STATUS] = FLQ_K_STRDY;
    	QENT [QENT_L_SIZE] = .MSG_SIZE * .envl [ENVL_L_RCPTCOUNT];
    	QENT [QENT_V_DELAY] = 1;
    	QENT [QENT_V_LOCK] = 0;

    	$GETTIM (TIMADR=NOWTIM);
    	LIB$ADD_TIMES (NOWTIM, LOCAL_INFO [LOCAL_Q_RETRY],
    	    	    QENT [QENT_Q_DLYDT]);
    	TRACE ('  Setting up for retry at !%D', QENT [QENT_Q_DLYDT]);
    END;


    DISPOSE_ENVELOPE (envl);

    IF NOT .QENT [QENT_V_DELAY] THEN
    BEGIN
    	STATUS = FLQ_READ (QCTX, .QENT [MXQ_L_BACKREF], REFENT);
	IF NOT(.status)
	THEN
	    ALARM ('LOCAL BACKREF FLQ_READ error=!XL', .status);

    	REFENT [MXQ_L_LOCALREF] = 0;
    	IF CHECK_REFS_ZERO (REFENT) THEN REFENT [QENT_L_STATUS] = FLQ_K_STFIN;
    	status = FLQ_UPDATE (QCTX, REFENT);
	IF NOT(.status)
	THEN
	    ALARM ('LOCAL BACKREF FLQ_UPDATE error=!XL', .status);

    	QENT [QENT_L_STATUS] = FLQ_K_STFIN;
    	TRACE ('  All done with this entry.');
    END;

    status = FLQ_UPDATE (QCTX, QENT);
	IF NOT(.status)
	THEN
	    ALARM ('LOCAL FLQ_UPDATE error=!XL', .status);

    WHILE NOT REMQUE (.HDRQ [QUE_L_HEAD], TXT) DO FREETXT (TXT);

    FREE_STRINGS (STR, USR, folder);

    TRACE_CLOSE;

    IF .LOCAL_INFO [LOCAL_V_ACCTG] THEN ACC_FLUSH;

    SS$_NORMAL

END; ! PROCESS


%SBTTL 'folder_name_ok'
ROUTINE folder_name_ok (ulen, unam_a, fdsc_a) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!   Verifies that a folder delivery is allowed by the user by
!   looking it up in MX_FOLDERS.DAT in the user's login directory.
!
! RETURNS:  	cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
!   FOLDER_NAME_OK  ulen, uname, folder
!
! IMPLICIT INPUTS:  None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
!   SS$_NORMAL:	    	normal successful completion.
!
! SIDE EFFECTS:
!
!   None.
!--
    BIND
    	fdsc	= .fdsc_a   : BLOCK [,BYTE];

    LOCAL
    	sdsc	: BLOCK [DSC$K_S_BLN,BYTE],
    	logdev	: VECTOR [256,BYTE],
    	logdir	: VECTOR [256,BYTE],
    	uailst	: $ITMLST_DECL (ITEMS=2),
    	bufptr,
    	unit,
    	devlen	: WORD,
    	dirlen	: WORD,
    	maxrec	: WORD,
    	llen	: WORD,
    	status;

    BIND fildsc	= %ASCID'MX_FOLDERS.DAT'    : BLOCK [,BYTE];

    $ITMLST_INIT (ITMLST=uailst,
    	(ITMCOD=UAI$_DEFDEV, BUFSIZ=%ALLOCATION (logdev), BUFADR=logdev, RETLEN=devlen),
    	(ITMCOD=UAI$_DEFDIR, BUFSIZ=%ALLOCATION (logdir), BUFADR=logdir, RETLEN=dirlen));
    INIT_SDESC (sdsc, .ulen, .unam_a);
    status = $GETUAI (USRNAM=sdsc, ITMLST=uailst);
    IF NOT .status THEN RETURN .status;
    devlen = .logdev [0]; ! ASCIC string
    dirlen = .logdir [0]; ! ASCIC string

    IF .dirlen+.devlen GTRU %ALLOCATION (logdev)-(.fildsc [DSC$W_LENGTH]+1) THEN RETURN 0;
    CH$MOVE (.dirlen, CH$PLUS (logdir, 1), CH$PLUS (logdev, .devlen+1));
    CH$MOVE (.fildsc [DSC$W_LENGTH], .fildsc [DSC$A_POINTER], CH$PLUS (logdev, .dirlen+.devlen+1));
    INIT_SDESC (sdsc, .devlen + .dirlen + .fildsc [DSC$W_LENGTH], CH$PLUS (logdev, 1));
    status = MX_FILE_OPEN (MX__FILE_READ, sdsc, unit, 0, 0, maxrec);
    IF NOT .status THEN RETURN .status;

    IF .maxrec GTRU %ALLOCATION (logdir) THEN
    BEGIN
    	status = LIB$GET_VM (%REF (.maxrec), bufptr);
    	IF .status THEN INIT_SDESC (sdsc, .maxrec, .bufptr);
    END
    ELSE
    BEGIN
    	INIT_SDESC (sdsc, %ALLOCATION (logdir), logdir);
    	bufptr = 0;
    	status = SS$_NORMAL;
    END;

    IF NOT .status THEN
    BEGIN
    	MX_FILE_CLOSE (.unit);
    	RETURN .status;
    END;

    WHILE MX_FILE_READ (.unit, sdsc, llen) DO
    BEGIN
    	LOCAL
    	    front,
    	    cp,
    	    flen    : WORD,
    	    rlen    : WORD;

    	!
    	! Trim leading and trailing blanks
    	!
    	front = .sdsc [DSC$A_POINTER];
    	WHILE .llen GTRU 0 AND (CH$RCHAR (.front) EQL %C' ' OR CH$RCHAR (.front) EQL %CHAR (9)) DO
    	BEGIN
    	    llen = .llen - 1;
    	    front = CH$PLUS (.front, 1);
    	END;

    	WHILE .llen GTRU 0 DO
    	BEGIN
    	    LOCAL ch	: BYTE;
    	    ch = CH$RCHAR (CH$PLUS (.front, .llen-1));
    	    IF .ch NEQ %C' ' AND .ch NEQ %CHAR (9) THEN EXITLOOP;
    	    llen = .llen - 1;
    	END;
    	!
    	! Allow null lines, comments
    	!
    	IF .llen GTRU 0 AND CH$RCHAR (.front) NEQ %C'!' THEN
    	BEGIN
    	    ! Line format can be one of:
    	    !
    	    !	folder-name
    	    ! 	+folder-name
    	    !	+alias <whitespace> real-folder-name
    	    flen = .llen;
    	    rlen = 0;
    	    IF CH$RCHAR (.front) EQL %C'+' THEN
    	    BEGIN
    	    	front = CH$PLUS (.front, 1);
    	    	llen = .llen - 1;
    	    	flen = .llen;
    	    	IF .llen GTRU 0 THEN
    	    	BEGIN
    	    	    LOCAL cp1, cp2;
    	    	    cp1 = CH$FIND_CH (.llen, .front, %C' ');
    	    	    cp2 = CH$FIND_CH (.llen, .front, %CHAR (9));
    	    	    IF NOT (CH$FAIL (.cp1) AND CH$FAIL (.cp2)) THEN
    	    	    BEGIN
    	    	    	IF CH$FAIL (.cp1) THEN cp = .cp2
    	    	    	ELSE IF CH$FAIL (.cp2) THEN cp = .cp1
    	    	    	ELSE cp = MINA (.cp1, .cp2);
    	    	    	flen = CH$DIFF (.cp, .front);
    	    	    	rlen = .llen - .flen;
    	    	    	WHILE .rlen GTRU 0 AND (CH$RCHAR (.cp) EQL %C' ' OR CH$RCHAR (.cp) EQL %CHAR (9)) DO
    	    	    	BEGIN
    	    	    	    rlen = .rlen - 1;
    	    	    	    cp = CH$PLUS (.cp, 1);
    	    	    	END;
    	    	    END;
    	    	END;
    	    END;
    	    !
    	    ! We have folder name, now check it
    	    !
    	    IF .flen GTRU 0 THEN
    	    BEGIN
    	    	LOCAL
    	    	    adsc    : BLOCK [DSC$K_S_BLN,BYTE];
    	    	INIT_SDESC (adsc, .flen, .front);
    	    	IF STR$CASE_BLIND_COMPARE (adsc, fdsc) EQL 0 THEN
    	    	BEGIN
    	    	    MX_FILE_CLOSE (.unit);
    	    	    IF .bufptr NEQA 0 THEN LIB$FREE_VM (%REF (.maxrec), bufptr);
    	    	    IF .rlen NEQ 0 THEN
    	    	    BEGIN
    	    	    	INIT_SDESC (sdsc, MINU (.rlen, 39), .cp);
    	    	    	!
    	    	    	!   Make sure alias folder name only contains printable characters
    	    	    	!
    	    	    	INCR rp FROM .cp TO CH$PLUS (.cp, .sdsc [DSC$W_LENGTH]-1) DO
    	    	    	BEGIN
    	    	    	    LOCAL ch : BYTE;
    	    	    	    ch = CH$RCHAR (.rp);
    	    	    	    IF (.ch AND %X'7F') LSSU %X'20' OR .ch EQL %X'7F' OR .ch EQL %X'FF' THEN
    	    	    	    	CH$WCHAR (%C'_', .rp);
    	    	    	END;
    	    	    	STR$UPCASE (fdsc, sdsc);
    	    	    END;
    	    	    RETURN SS$_NORMAL;
    	    	END;
    	    END;
    	END;  ! non-null, non-comment line
    END; ! while loop

    MX_FILE_CLOSE (.unit);
    IF .bufptr NEQA 0 THEN LIB$FREE_VM (%REF (.maxrec), bufptr);

    0  ! folder not found

END; ! folder_name_ok
    	    	    	
END
ELUDOM