%title 'MailBox Master -- main program'

!
!   Version 4 of MailBox Master is a rewrite of MBM V3.2
!
!   See MBM.HLP for documentation.
!
!   Changes:
!   o	Use Command Language Definition rather than TPARSE.
!   o	Omit ATTACH command.
!   o	Omit WAIT command, but put /WAIT switch on FORMAT,
!	CREATE, DUMP, and TYPE commands.
!   o	Test status, don't set SFM.
!   o	Check for SET VERIFY to echo command input.
!   o	Info message for CREATE - new or old mailbox.
!   o	Add new message formats to FORMAT (formerly WATCH).
!   o	Add TYPE command.
!   o	Add DUMP command.
!   o	Use RTL VM routines.
!

module MBM (
    ident = 'V4.0',
    main = MBM) =

begin


%sbttl 'module declarations'

library 'SYS$LIBRARY:STARLET';
library 'MBMLIB';

forward routine
    MBM, Put_Message, Interpret, Get, Fao, Ctrl_C: novalue, Get_MBX_DevNam;

global
    cli: ref $bblock;


%sbttl 'MBM -- main program'

routine MBM =
(
    builtin argptr;
    external routine LIB$GET_FOREIGN: addressing_mode (general);
    literal
	Get_BufSiz = 128;
    local
	Get_Buffer: vector[Get_BufSiz, byte],
	Get_dsc: $dsc_static,
	Command_dsc: $dsc_static,
	sts: VMS_sts;

    enable Put_Message;


    cli = argptr ();

    Get_dsc[DSC$W_LENGTH] = Get_BufSiz;
    Get_dsc[DSC$A_POINTER] = Get_Buffer;

    Command_dsc[DSC$W_LENGTH] = Get_BufSiz;
    Command_dsc[DSC$A_POINTER] = Get_Buffer;

    LIB$GET_FOREIGN (Get_dsc, 0, Command_dsc[DSC$W_LENGTH], 0);

    if .Command_dsc[DSC$W_LENGTH] gtr 0 then
	return Interpret (Command_dsc) or STS$M_INHIB_MSG;

    Fao (%ascid '     MailBox Master - Version 4.0');

    while
	Get (Get_dsc, Command_dsc[DSC$W_LENGTH])
    do
	if Interpret (Command_dsc) eql MBM_Cond <EXIT> then exitloop;

    return SS$_NORMAL
);


%sbttl 'Put_Message -- Put error message signal handler'

routine Put_Message (Sig: ref vector, Mech: ref vector, Enbl: ref vector) =
(
    bind
	Sig_Count = Sig[0],
	Condition = Sig[1]: $bblock;

    Sig_Count = .Sig_Count - 2;
    $PUTMSG (msgvec = .Sig, facnam = %ascid 'MBM');
    Sig_Count = .Sig_Count + 2;

    if .Condition[STS$V_SEVERITY] leq STS$K_INFO then
	return 1
    else
	return $EXIT (code = .Condition or STS$M_INHIB_MSG)
);


%sbttl 'Interpret -- interpret one command'

routine Interpret (Command: ref $dsc) =
(
    external routine
	CLI$DCL_PARSE: addressing_mode (general),
	CLI$DISPATCH: addressing_mode (general);
    external
	MBM_CLI_Tables;
    local
	sts: VMS_sts;


    if .Command[DSC$W_LENGTH] eql 0 then return SS$_NORMAL;

    sts = CLI$DCL_PARSE (.Command, MBM_CLI_Tables);

    if not .sts then return .sts;

    return CLI$DISPATCH ()
);


%sbttl 'Get -- Get line from SYS$INPUT'

routine Get (Line: ref $dsc, RetLen: ref vector[1, word]) =
(
    own
	In_fab: $fab (fac = <GET>, fnm = 'SYS$INPUT', fop = <SQO>),
	In_rab: $rab (fab = In_fab);
    bind
	Prompt = %ascid 'MBM> ': $dsc,
	In_dev = In_fab[FAB$L_DEV]: $bblock[4];
    local
	sts: VMS_sts;


    if .In_fab[FAB$W_IFI] eql 0 then
    (
	if not $OPEN (fab = In_fab) then
	    signal (
		MBM_Error <SYSINPUT>,
		RMS_Error <fab = In_fab>);

	if not $CONNECT (rab = In_rab) then
	    signal (
		MBM_Error <SYSINPUT>,
		RMS_Error <rab = In_rab>);

	if .In_dev[DEV$V_TRM] then
	(
	    In_rab[RAB$V_PMT] = 1;
	    In_rab[RAB$B_PSZ] = .Prompt[DSC$W_LENGTH];
	    In_rab[RAB$L_PBF] = .Prompt[DSC$A_POINTER];
	    Ctrl_C ();
	);
    );

    In_rab[RAB$W_USZ] = .Line[DSC$W_LENGTH];
    In_rab[RAB$L_UBF] = .Line[DSC$A_POINTER];

    sts = $GET (rab = In_rab);
    if (not .sts) and (.sts neq RMS$_EOF) then
	signal (
	    MBM_Error <SYSINPUT>,
	    RMS_Error <rab = In_rab>);

    if .cli[CLI$V_VERIFY] and not .In_dev[DEV$V_TRM] then
	Fao (%ascid '!AS!AD',
	    Prompt,
	    .In_rab[RAB$W_RSZ], .In_rab[RAB$L_RBF]);

    RetLen[0] = .In_rab[RAB$W_RSZ];

    return .sts
);


%sbttl 'Fao -- format & output'

global routine Fao (ctrstr, p1) =
(
    external routine LIB$PUT_OUTPUT: addressing_mode (general);
    literal
	Fao_usz = 256;
    local
	Fao_ubf: vector[Fao_usz, byte],
	Fao_dsc: $dsc_static,
	sts: VMS_sts;
    builtin
	actualcount;


    Fao_dsc[DSC$W_LENGTH] = Fao_usz;
    Fao_dsc[DSC$A_POINTER] = Fao_ubf;

    sts = $FAOL (
	ctrstr = .ctrstr,
	outbuf = Fao_dsc,
	outlen = Fao_dsc[DSC$W_LENGTH],
	prmlst = (if actualcount () eql 1 then 0 else p1));

    if not .sts then
	signal (MBM_Error <FAO>, SS_Error <.sts>);

    return LIB$PUT_OUTPUT (Fao_dsc);
);


%sbttl 'Ctrl_C -- Terminal control-C AST routine'

routine Ctrl_C (AST_parameter, AST_r0, AST_r1, AST_pc, AST_psl): novalue =
(
    own
	TT_Chan: word initial (0);
    local
	sts: VMS_sts;


    if .TT_Chan eql 0
    then
    (
	sts = $ASSIGN (devnam = %ascid 'SYS$INPUT', chan = TT_Chan);
	if not .sts then
	    signal (MBM_Error <CTRLC>, SS_Error <.sts>);
    )
    else
	$SETEF (efn = Ctrl_C_efn);

    sts = $QIOW (
	chan = .TT_Chan,
	func = (IO$_SETMODE or IO$M_CTRLCAST),
	p1 = Ctrl_C);

    if not .sts then
	signal (MBM_Error <CTRLC>, SS_Error <.sts>);
);


%sbttl 'Get_MBX_DevNam -- and device name'

global routine Get_MBX_DevNam (Chan, Device: ref $dsc, DevNam: ref $dsc) =
(
    external routine STR$COPY_DX: addressing_mode (general);
    literal DevNam_Size = 64;
    local
	sts: VMS_sts,
	DevNam_dsc: $dsc_static,
	DevNam_Buffer: vector[DevNam_Size, byte],
	DevClass,
	ItmVec: vector[2*3 + 1];
    bind
	ItmLst = ItmVec: blockvector[2 + 1, 3*%upval, byte];
    macro
	DVI_BUFLEN = 0, 0, 16, 0 %,
	DVI_CODE   = 2, 0, 16, 0 %,
	DVI_BUFFER = 4, 0, 32, 0 %,
	DVI_RETLEN = 8, 0, 32, 0 %,
	DVI_LISTEND= 0, 0 ,32, 0 %;
    label
	Main;


Main:
    (
	DevNam_dsc[DSC$A_POINTER] = DevNam_Buffer;

	ItmLst[0, DVI_CODE]   = DVI$_DEVCLASS;
	ItmLst[0, DVI_BUFLEN] = %upval;
	ItmLst[0, DVI_BUFFER] = DevClass;
	ItmLst[0, DVI_RETLEN] = 0;

	ItmLst[1, DVI_CODE]   = DVI$_DEVNAM;
	ItmLst[1, DVI_BUFLEN] = DevNam_Size;
	ItmLst[1, DVI_BUFFER] = DevNam_Buffer;
	ItmLst[1, DVI_RETLEN] = DevNam_dsc[DSC$W_LENGTH];

	ItmLst[2, DVI_LISTEND] = 0;

	sts = $GETDVI (efn = 0, chan = .Chan, devnam = .Device, itmlst = ItmLst);
	if not .sts then
	(
	    signal (MBM_Error (GETDVI, .Device), SS_Error (.sts));
	    leave Main;
	);

	$WAITFR (efn = 0);

	sts = STR$COPY_DX (.DevNam, DevNam_dsc);

	if .DevClass neq DC$_MAILBOX then
	(
	    sts = MBM_Cond (NOTMBX);
	    leave Main;
	);
    );

    return .sts
);

end
eludom