%title 'Type and Format and Dump MailBox Master commands'

module Type (
    ident = 'V4.0') =

begin

%sbttl 'module declarations'

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

forward routine
    Read_MailBox,
    Attn_ast: novalue,
    Type_Record,
    Dump_Record,
    RAB_Fao,
    Put_Message, Put_MessAct;


own
    Record_No,
    DevBufSiz;

bind
    ItmLst = uplit (DVI_ItmLst (
	<code = DEVBUFSIZ, buffer = DevBufSiz>));


%sbttl 'Type -- type mailbox to file'

global routine Type =
(
    return Read_MailBox (MBM_Cond (TYPE), Type_Record)
);

%sbttl 'Format -- interpret mailbox to file'

global routine Format =
(
    external routine Format_Record;


    return Read_MailBox (MBM_Cond (FORMAT), Format_Record)
);

%sbttl 'Dump -- hex dump of mailbox to file'

global routine Dump =
(
    return Read_MailBox (MBM_Cond (DUMP), Dump_Record);
);


%sbttl 'Read_MailBox -- read mailbox and process'

routine Read_MailBox (Info, Output_Routine) =
(
    external routine
	CLI$PRESENT: addressing_mode (general),
	CLI$GET_VALUE: addressing_mode (general),
	CLI_GET_TIME,
	STR$FREE1_DX: addressing_mode (general),
	STR$GET1_DX: addressing_mode (general),
	Get_MBX_DevNam;

    bind
	Wait_Label = %ascid 'Wait';
    local
	sts: VMS_sts, Wait: VMS_sts,
	End_Of_File: VMS_sts, WritEOF: VMS_sts, Pull: VMS_sts,
	Wait_Time: vector[2],
	eflags;

    local
	Sour_Buf: $dsc_dynamic,
	Sour_dsc: $dsc_dynamic,
	Sour_DevNam: $dsc_dynamic,
	Sour_Chan: word initial (0),
	Sour_iosb: IOSB$DEF;

    local
	Dest_dsc: $dsc_dynamic,
	Dest_FAB: $FAB_DECL,
	Dest_RAB: $RAB_DECL;

    local
	Copy_dsc: $dsc_dynamic,
	Copy_DevNam: $dsc_dynamic,
	Copy_Chan: word initial (0),
	Copy_Func;

    local
	READ_Arg_List: vector[13];

    label Read_Main;


Read_Main:
    (
	sts = CLI$GET_VALUE (%ascid 'MailBox', Sour_dsc);
	if not .sts then leave Read_Main;

	sts = CLI$GET_VALUE (%ascid 'Output', Dest_dsc);

	if (.sts neq 0) and not .sts then leave Read_Main;

	CLI$GET_VALUE (%ascid 'COPY', Copy_dsc);

	End_Of_File = CLI$PRESENT (%ascid 'END_OF_FILE');

	(
	    bind WritEOF_Qualifier = %ascid 'WRITEOF': $dsc;

	    WritEOF = CLI$PRESENT (WritEOF_Qualifier);
	    if (.Copy_dsc[DSC$W_LENGTH] eql 0) and
		((.WritEOF eql CLI$_PRESENT) or (.WritEOF eql CLI$_NEGATED))
	    then
		signal (MBM_Error (COPYQUAL, WritEOF_Qualifier));
	);

	(
	    bind Pull_Qualifier = %ascid 'PULL': $dsc;

	    Pull = CLI$PRESENT (Pull_Qualifier);
	    if (.Copy_dsc[DSC$W_LENGTH] eql 0) and
		((.Pull eql CLI$_PRESENT) or (.Pull eql CLI$_NEGATED))
	    then
	    (
		signal (MBM_Error (COPYQUAL, Pull_Qualifier));
		Pull = 0;
	    );
	);

	if Wait = CLI$PRESENT (Wait_Label) then
	(
	    sts = CLI_GET_TIME (Wait_Label, Wait_Time);
	    if not .sts then leave Read_Main;
	);

	sts = Get_MBX_DevNam (0, Sour_dsc, Sour_DevNam);
	if not .sts then
	(
	    if .sts eql MBM_Cond (NOTMBX) then
		signal (MBM_Error (NOTMBX, Sour_dsc, Sour_DevNam));
	    leave Read_Main;
	);

	$FAB_INIT (fab = Dest_FAB,
	    fac = <PUT>,
	    fop = <TEF,SQO>,
	    rat = <CR>);

	
	if .Dest_dsc[DSC$W_LENGTH] gtr 0 then
	(
	    Dest_FAB[FAB$B_FNS] = .Dest_dsc[DSC$W_LENGTH];
	    Dest_FAB[FAB$L_FNA] = .Dest_dsc[DSC$A_POINTER];
	)
	else
	(
	    Dest_FAB[FAB$B_FNS] = %charcount ('SYS$OUTPUT');
	    Dest_FAB[FAB$L_FNA] = uplit byte ('SYS$OUTPUT');
	);

	$RAB_INIT (rab = Dest_RAB, fab = Dest_FAB,
	    rop = <EOF>);

	if .Copy_dsc[DSC$W_LENGTH] gtr 0 then
	(
	    sts = Get_MBX_DevNam (0, Copy_dsc, Copy_DevNam);
	    if not .sts then
	    (
		if .sts eql MBM_Cond (NOTMBX) then
		    signal (MBM_Error (NOTMBX, Copy_dsc, Copy_DevNam));
		leave Read_Main;
	    );
	);

	if not (sts = $ASSIGN (devnam = Sour_DevNam, chan = Sour_Chan)) then
	(
	    signal (MBM_Error (ASSIGN, Sour_dsc, Sour_DevNam));
	    leave Read_Main;
	);

	if not (sts = $CREATE (fab = Dest_FAB)) then
	(
	    signal (
		MBM_Error (OPENOUT, .Dest_FAB[FAB$B_FNS], .Dest_FAB[FAB$L_FNA]),
		RMS_Error (fab = Dest_FAB));
	    leave Read_Main;
	);

	if not (sts = $CONNECT (rab = Dest_RAB)) then
	(
	    signal (
		MBM_Error (CONNECT, .Dest_FAB[FAB$B_FNS], .Dest_FAB[FAB$L_FNA]),
		RMS_Error (rab = Dest_RAB));
	    leave Read_Main;
	);

	if .Copy_dsc[DSC$W_LENGTH] gtr 0 then
	(
	    if not (sts = $ASSIGN (devnam = Copy_DevNam, chan = Copy_Chan)) then
	    (
		signal (
		    MBM_Error (ASSIGN, Copy_dsc, Copy_DevNam),
		    SS_Error (.sts));
		leave Read_Main;
	    );
	);

	sts = $GETDVI (efn = 0, chan = .Sour_Chan, itmlst = ItmLst);

	if not .sts then
	    signal (MBM_Error (GETDVI, Sour_dsc), SS_Error (.sts));

	sts = STR$GET1_DX (DevBufSiz, Sour_Buf);
	if not .sts then
	(
	    signal (SS_Error (.sts));
	    leave Read_Main;
	);

	READ_Arg_List[0] = 12;
	READ_Arg_List[1] = QIO_efn;
	READ_Arg_List[2] = .Sour_Chan;
	READ_Arg_List[3] = IO$_READVBLK;
	READ_Arg_List[4] = Sour_iosb;
	READ_Arg_List[5] = 0;
	READ_Arg_List[6] = 0;
	READ_Arg_List[7] = .Sour_Buf[DSC$A_POINTER];
	READ_Arg_List[8] = .Sour_Buf[DSC$W_LENGTH];
	READ_Arg_List[9] = 0;
	READ_Arg_List[10] = 0;
	READ_Arg_List[11] = 0;
	READ_Arg_List[12] = 0;

	$CLREF (efn = Ctrl_C_efn);

	$CANTIM ();
	if .Wait then
	    $SETIMR (efn = Timer_efn, daytim = Wait_Time)
	else
	    $CLREF (efn = Timer_efn);

	Record_No = 0;

	Put_Message (Dest_RAB, 4, .Info, 2, Sour_dsc, Sour_DevNam);

	while 1 do
	(
	    if .Pull then
	    (
		sts = $QIOW (
		    chan = .Copy_Chan,
		    func = IO$_SETMODE or IO$M_READATTN,
		    p1 = Attn_ast,
		    p2 = READ_Arg_List);
		if not .sts then
		    signal (
			MBM_Error (QIO, Copy_dsc, Copy_DevNam),
			SS_Error (.sts));
		$CLREF (efn = QIO_efn);
	    )
    	    else
	    (
		external routine SYS$QIO: addressing_mode (general);
		builtin callg;

		sts = callg (READ_Arg_List, SYS$QIO);
		if not .sts then
		(
		    signal (
			MBM_Error (QIO, Sour_dsc, Sour_DevNam),
			SS_Error (.sts));
		    leave Read_Main;
		);
	    );

	    $WFLOR (
		efn = QIO_efn,
		mask = ef_mask (QIO_efn, Timer_efn, Ctrl_C_efn));

	    $READEF (efn = QIO_efn, state = eflags);

	    if (.eflags and ef_mask (QIO_efn)) neq 0 then
	    (
		if .Sour_iosb[IOSB$W_STATUS] then
		(
		    Record_No = .Record_No + 1;

		    Copy_Func = IO$_WRITEVBLK;

		    sts = (.Output_Routine) (
			.Sour_Buf[DSC$A_POINTER],
			Sour_iosb,
			Dest_RAB);
		    if not .sts then
			leave Read_Main;
		)
		else
		(
		    Put_Message (Dest_RAB, 2, .Sour_iosb[IOSB$W_STATUS], 0);

		    if .Sour_iosb[IOSB$W_STATUS] eql SS$_ENDOFFILE then
		    (
			Copy_Func = IO$_WRITEOF;
		    )
		    else
		    (
			signal (
			    MBM_Error (QIO, Sour_dsc, Sour_DevNam),
			    SS_Error (.Sour_iosb[IOSB$W_STATUS]));
			sts = .Sour_iosb[IOSB$W_STATUS];
			leave Read_Main;
		    );
		);

		if (.Copy_Chan neq 0) and
		    ((.Copy_Func neq IO$_WRITEOF) or .WritEOF) then
		(
		    sts = $QIOW (
			chan = .Copy_Chan, func = .Copy_Func,
			p1 = .Sour_Buf[DSC$A_POINTER],
			p2 = .Sour_iosb[IOSB$W_IOLEN]);

		    if not .sts then
		    (
			signal (
			    MBM_Error (QIO, Copy_dsc, Copy_DevNam),
			    SS_Error (.sts));
			leave Read_Main;
		    );
		);

		if (.Sour_iosb[IOSB$W_STATUS] eql SS$_ENDOFFILE)
		    and .End_Of_File then
		(
		    sts = (SS$_ENDOFFILE and (not STS$M_SEVERITY)) or STS$K_INFO;
		    leave Read_Main;
		);
	    );

	    if (.eflags and ef_mask (Ctrl_C_efn)) neq 0 then
	    (
		sts = (SS$_CONTROLC and (not STS$M_SEVERITY)) or STS$K_INFO;
		Put_Message (Dest_RAB, 1, .sts);
		leave Read_Main;
	    );

	    if (.eflags and ef_mask (Timer_efn)) neq 0 then
	    (
		sts = MBM_Cond (TIMER);
		Put_Message (Dest_RAB, 2, .sts, 0);
		leave Read_Main;
	    );
	);
    );

    if .Sour_Buf[DSC$W_LENGTH] gtr 0 then STR$FREE1_DX (Sour_Buf);
    if .Sour_dsc[DSC$W_LENGTH] gtr 0 then STR$FREE1_DX (Sour_dsc);
    if .Sour_DevNam[DSC$W_LENGTH] gtr 0 then STR$FREE1_DX (Sour_DevNam);
    if .Sour_Chan neq 0 then $DASSGN (chan = .Sour_Chan);

    if .Dest_dsc[DSC$W_LENGTH] gtr 0 then STR$FREE1_DX (Dest_dsc);
    if .Dest_FAB[FAB$W_IFI] neq 0 then $CLOSE (fab = Dest_FAB);

    if .Copy_dsc[DSC$W_LENGTH] gtr 0 then STR$FREE1_DX (Copy_dsc);
    if .Copy_DevNam[DSC$W_LENGTH] gtr 0 then STR$FREE1_DX (Copy_DevNam);
    if .Copy_Chan neq 0 then $DASSGN (chan = .Copy_Chan);

    return .sts
);


%sbttl 'Attn_ast -- read attention ast'

routine Attn_ast (QIO_Arg_List: ref vector, r0, r1, pc, psl): novalue =
(
    external routine SYS$QIO: addressing_mode (general);
    builtin callg;

    callg (.QIO_Arg_List, SYS$QIO);
);


%sbttl 'Type_Record -- do not interpret data, just write'

routine Type_Record (
    Buffer: ref vector[,byte], iosb: ref IOSB$DEF, rab: ref $RAB_DECL) =
(
    rab[RAB$W_RSZ] = .iosb[IOSB$W_IOLEN];
    rab[RAB$L_RBF] = .Buffer;
    return $PUT (rab = .rab);
);


%sbttl 'Dump_Record -- interpret data as binary and write'

routine Dump_Record (
    Buffer: ref vector[,byte], iosb: ref IOSB$DEF, rab: ref $RAB_DECL) =
(
    RAB_Fao (
	.rab,
	%ascid 'From pid !8XL, at !%D',
	.iosb[IOSB$L_PID],
	0);

    RAB_Fao (
	.rab,
	%ascid 'Record !UL (!-!8XL), !UW (!-!4XW) byte!%S',
	.Record_No,
	.iosb[IOSB$W_IOLEN]);

    RAB_Fao (.rab, %ascid '');

    incr j from 0 to .iosb[IOSB$W_IOLEN] - 1 by 4*%upval do
    (
	bind LBuffer = Buffer[.j]: vector[,long];
	local
	    l: vector[4];

	incr k from 0 to 3 do
	    l[.k] = 2*min (4, max (0, .iosb[IOSB$W_IOLEN] - .j - .k*%upval));

	RAB_Fao (
	    .rab,
	    %ascid ' !#* !#XL !#* !#XL !#* !#XL !#* !#XL  !4XW  !AF',
	    8 - .l[3], .l[3], .LBuffer[3],
	    8 - .l[2], .l[2], .LBuffer[2],
	    8 - .l[1], .l[1], .LBuffer[1],
	    8 - .l[0], .l[0], .LBuffer[0],
	    .j,
	    min (4*%upval, (.iosb[IOSB$W_IOLEN] - .j)), LBuffer);
    );

    RAB_Fao (.rab, %ascid '');

    return SS$_NORMAL
);


%sbttl 'RAB_Fao -- format & output'

global routine RAB_Fao (rab: ref $RAB_DECL, ctrstr, p1) =
(
    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 = rab[RAB$W_RSZ],
	prmlst = (if actualcount () eql 1 then 0 else p1));

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

    rab[RAB$L_RBF] = Fao_ubf;
    return $PUT (rab = .rab);
);


%sbttl 'Put_Message -- put message to output file'

routine Put_Message (rab: ref $RAB_DECL, MsgVec) =
(
    return $PUTMSG (msgvec = MsgVec, actrtn = Put_MessAct,
	facnam = %ascid 'MBM', actprm = .rab)
);


%sbttl 'Put_MessAct -- action routine for $PUTMSG'

routine Put_MessAct (String: ref $dsc, rab: ref $RAB_DECL) =
(
    rab[RAB$W_RSZ] = .String[DSC$W_LENGTH];
    rab[RAB$L_RBF] = .String[DSC$A_POINTER];
    $PUT (rab = .rab);
    return 0
);

end
eludom