/*+

TITLE:	    	MDM_PARSE
    	    	Interface routines to $PARSE RMS call.

VERSION:    	V1.0-002

FACILITY:   	MDMLIB

ABSTRACT:   	This module contains a routine to obtain the parts of
    	    	a file specification using RMS $PARSE.

ENVIRONMENT:	User mode

AUTHOR:	    	M. Madison
    	    	COPYRIGHT © 1988, RENSSELAER POLYTECHNIC INSTITUTE.
    	    	    	    	  All rights reserved.

MODIFICATION HISTORY:

    10-Aug-1987	V1.0-001    Madison     Initial coding.
    08-FEB-1988	V1.0-002    Madison 	Code cleanup.

-*/
%INCLUDE VMS_TYPES;
%INCLUDE _MDMDEF;
%INCLUDE SYS$PARSE;
%INCLUDE $FABDEF;
%INCLUDE $NAMDEF;
%INCLUDE LIB$GET_VM;
%INCLUDE LIB$FREE_VM;
%INCLUDE LIB$ANALYZE_SDESC;
%INCLUDE LIB$SCOPY_DXDX;
%INCLUDE LIB$SCOPY_R_DX;

    DECLARE RMS$_NORMAL FIXED BINARY (31) GLOBALREF VALUE;

    DECLARE (ACTUALCOUNT, PRESENT, NULL) BUILTIN;
%PAGE;
MDM_PARSE:  PROCEDURE (KEYMASK, FSPEC, DEF_FSPEC, RESULT, RESLEN)
    	    RETURNS (VMS_COND_VALUE)
    	    OPTIONS (IDENT ('V1.0-002'));

/*+

DESCRIPTION:	This procedure provides a simple interface to the
    	    	$PARSE RMS service, much like the DCL F$PARSE lexical
    	    	function (sans related file specs).  Given a file
    	    	specification and an optional default file spec,
    	    	this routine allocates and fills in the appropriate
    	    	fields of a FAB and NAM block and invokes $PARSE.
    	    	The KEYMASK indicates which parts of the resulting
    	    	file spec are to be returned.  It also indicates
    	    	whether the NOCONCEAL, PWD, and/or SYNCHK bits of
    	    	the NAM$B_NOP field are to be set when $PARSE is
    	    	invoked.  Any or all parts of the result may be
    	    	returned.

PROTOTYPE:

    MDM_PARSE keymask, fspec, [def_fspec], result [,reslen]

RETURNS:    cond_value, longword (unsigned), write only, by reference

ARGUMENTS:

keymask:    unsigned_longword, longword (unsigned), read only, by reference
fspec:	    char_string, character string, read only, by descriptor
def_fspec:  char_string, character string, read only, by descriptor
result:	    char_string, character string, write only, by descriptor
reslen:	    unsigned_word, word (unsigned), write only, by reference

IMPLICIT INPUT:	    none.

COMPLETION CODES:   Any from SYS$PARSE, LIB$GET_VM, LIB$SCOPY_DXDX,
    	    	    or LIB$ANALYZE_SDESC.
    	    	    RMS$_NORMAL indicates success.

SIDE EFFECTS:	    none.

-*/

    DECLARE KEYMASK BIT (32) ALIGNED PARAMETER,
    	    FSPEC POINTER VALUE PARAMETER,
    	    DEF_FSPEC POINTER VALUE PARAMETER,
    	    RESULT POINTER VALUE PARAMETER,
    	    RESLEN FIXED BINARY (15) PARAMETER;

%INCLUDE $STSDEF;

    DECLARE TMPLEN FIXED BINARY (15),
    	    (FAB, NAM) POINTER,
    	    (XRESULT, TMPSTR) CHARACTER (255) VARYING,
    	    EXPAN_FSPEC CHARACTER (255),
    	    JUNK FIXED BINARY (31),
    	    FABARRAY (FAB$C_BLN) FIXED BINARY (7) BASED,
    	    NAMARRAY (NAM$C_BLN) FIXED BINARY (7) BASED;

/********************** BEGIN EXECUTABLE CODE *********************/

    STS$VALUE = LIB$GET_VM (FAB$C_BLN, FAB);
    IF ^ STS$SUCCESS THEN RETURN (STS$VALUE);
    FAB -> FABARRAY = 0;
    FAB -> FABDEF.FAB$B_BID = FAB$C_BID;
    FAB -> FABDEF.FAB$B_BLN = FAB$C_BLN;

    STS$VALUE = LIB$GET_VM (NAM$C_BLN, NAM);
    IF ^ STS$SUCCESS THEN DO;
    	JUNK = LIB$FREE_VM (FAB$C_BLN, FAB);
    	RETURN (STS$VALUE);
    END;
    NAM -> NAMARRAY = 0;
    NAM -> NAMDEF.NAM$B_BID = NAM$C_BID;
    NAM -> NAMDEF.NAM$B_BLN = NAM$C_BLN;
    NAM -> NAMDEF.NAM$L_ESA = ADDR (EXPAN_FSPEC);
    POSINT (NAM -> NAMDEF.NAM$B_ESS) = MIN (LENGTH (EXPAN_FSPEC), 255);

    FAB -> FABDEF.FAB$L_NAM = NAM;

    IF KEYMASK & MDM_M_SYNCHK THEN NAM -> NAMDEF.NAM$V_SYNCHK = '1'B;
    IF KEYMASK & MDM_M_PWD THEN NAM -> NAMDEF.NAM$V_PWD = '1'B;
    IF KEYMASK & MDM_M_NOCONCEAL THEN NAM -> NAMDEF.NAM$V_NOCONCEAL = '1'B;

    STS$VALUE = LIB$ANALYZE_SDESC (VALUE (FSPEC), TMPLEN,
    	FAB -> FABDEF.FAB$L_FNA);
    IF ^ STS$SUCCESS THEN DO;
    	JUNK = LIB$FREE_VM (FAB$C_BLN, FAB);
    	JUNK = LIB$FREE_VM (NAM$C_BLN, NAM);
    	RETURN (STS$VALUE);
    END;
    POSINT (FAB -> FABDEF.FAB$B_FNS) = MIN (TMPLEN, 255);

    IF DEF_FSPEC ^= NULL() THEN DO;
    	STS$VALUE = LIB$ANALYZE_SDESC (VALUE (DEF_FSPEC), TMPLEN,
    	    FAB -> FABDEF.FAB$L_DNA);
    	IF ^ STS$SUCCESS THEN DO;
    	    JUNK = LIB$FREE_VM (FAB$C_BLN, FAB);
    	    JUNK = LIB$FREE_VM (NAM$C_BLN, NAM);
    	    RETURN (STS$VALUE);
    	END;
    	POSINT (FAB -> FABDEF.FAB$B_DNS) = MIN (TMPLEN, 255);
    END;

    STS$VALUE = SYS$PARSE (FAB -> FABDEF);
    IF ^ STS$SUCCESS THEN DO;
    	JUNK = LIB$FREE_VM (FAB$C_BLN, FAB);
    	JUNK = LIB$FREE_VM (NAM$C_BLN, NAM);
    	RETURN (STS$VALUE);
    END;

    XRESULT = '';
    IF KEYMASK & MDM_M_NODE THEN
    	STS$VALUE = LIB$SCOPY_R_DX ((NAM -> NAMDEF.NAM$B_NODE),
    	    VALUE (NAM -> NAMDEF.NAM$L_NODE), XRESULT);

    IF KEYMASK & MDM_M_DEV THEN DO;
    	STS$VALUE = LIB$SCOPY_R_DX ((NAM -> NAMDEF.NAM$B_DEV),
    	    VALUE (NAM -> NAMDEF.NAM$L_DEV), TMPSTR);
    	XRESULT = XRESULT || TMPSTR;
    END;

    IF KEYMASK & MDM_M_DIR THEN DO;
    	STS$VALUE = LIB$SCOPY_R_DX ((NAM -> NAMDEF.NAM$B_DIR),
    	    VALUE (NAM -> NAMDEF.NAM$L_DIR), TMPSTR);
    	XRESULT = XRESULT || TMPSTR;
    END;

    IF KEYMASK & MDM_M_NAME THEN DO;
    	STS$VALUE = LIB$SCOPY_R_DX ((NAM -> NAMDEF.NAM$B_NAME),
    	    VALUE (NAM -> NAMDEF.NAM$L_NAME), TMPSTR);
    	XRESULT = XRESULT || TMPSTR;
    END;

    IF KEYMASK & MDM_M_TYPE THEN DO;
    	STS$VALUE = LIB$SCOPY_R_DX ((NAM -> NAMDEF.NAM$B_TYPE),
    	    VALUE (NAM -> NAMDEF.NAM$L_TYPE), TMPSTR);
    	XRESULT = XRESULT || TMPSTR;
    END;

    IF KEYMASK & MDM_M_VER THEN DO;
    	STS$VALUE = LIB$SCOPY_R_DX ((NAM -> NAMDEF.NAM$B_VER),
    	    VALUE (NAM -> NAMDEF.NAM$L_VER), TMPSTR);
    	XRESULT = XRESULT || TMPSTR;
    END;

    STS$VALUE = LIB$FREE_VM (FAB$C_BLN, FAB);
    STS$VALUE = LIB$FREE_VM (NAM$C_BLN, NAM);

    STS$VALUE = LIB$SCOPY_DXDX (XRESULT, VALUE (RESULT));
    IF ^ STS$SUCCESS THEN RETURN (STS$VALUE);                

    IF ACTUALCOUNT > 4 &: PRESENT (RESLEN) THEN RESLEN = LENGTH (XRESULT);

    RETURN (RMS$_NORMAL);

END MDM_PARSE;