(******************************************************************************

:Remark.			Format: ein TAB in jeder 3. Spalte: ..tab..tab..tab..


:Program.		CheckQualifiers

:Contents.		checks for given qualifiers and returns warn if any of the given
:Contents.		qualifiers is pressed, ok else

:Bugs.			"Shit happens." (Murphy)


:Copyright.		PD

:Author.			Thomas Ansorge

:Address.		Dinkelackerring 55, 67435 Neustadt, Deutschland, Europa


:Language.		Modula-2

:Translator.	M2Amiga V4.3 (deutsch)


:History.		1.0 as of 24-Dec-1994:
:History.			- first working version

:History.		1.1 as of 02-Jan-1995
:History.			- checks for exactly the given set of qualifiers, not subset

:History.		1.2 as of 04-Jan-1995
:History.			- empty set allowed
:History.			- returnVal = fail if an error occurs
:History.			- "unknown args" message if ReadArgs () fails

:History.		1.3 as of 06-Jan-1995
:History.			- returns
:History.				0: none of the given qualifiers are pressed
:History.				1: at least one (but not all) of the given qualifiers are pressed
:History.				2: all of the given qualifiers are pressed and some more
:History.				3: exactly the given qualifiers are pressed

:History.		1.4 as of 15-Jan-1995
:History.			- PrintFault (IoErr (), NIL) instead of WriteString (...) after failure of ReadArgs ()


******************************************************************************)


MODULE CheckQualifiers;

FROM Arts IMPORT returnVal;

FROM DosD IMPORT fail, FileHandlePtr, RDArgsPtr;

FROM DosL IMPORT dosVersion, FreeArgs, IoErr, Output, PrintFault, ReadArgs, Write;

FROM ExecD IMPORT IOStdReq, IOStdReqPtr, MsgPortPtr;

FROM ExecL IMPORT CloseDevice, CreateIORequest, CreateMsgPort, DeleteIORequest, DeleteMsgPort, execVersion, OpenDevice;

(*$ IF M68881 *)
IMPORT FPUExc;
(*$ ENDIF *)

FROM Input IMPORT inputName, PeekQualifier;

FROM InputEvent IMPORT Qualifiers, QualifierSet;

FROM SYSTEM IMPORT ADR, CAST, LONGSET;

(* ------------------------------------------------------------------------- *)

CONST
	ver_str = "$VER: CheckQualifiers 1.4/";
	date_str = " (15.01.95)";

	(*$ IF M68881 OR M68040 *)
		ver_ptr = ADR (ver_str + "68020+FPU" + date_str);
	(*$ ELSIF M68020 *)
		ver_ptr = ADR (ver_str + "68020" + date_str);
	(*$ ELSIF M68010 *)
		ver_ptr = ADR (ver_str + "68010" + date_str);
	(*$ ELSE *)
		ver_ptr = ADR (ver_str + "68000" + date_str);
	(*$ ENDIF *)

	min_dos_version = 36;
	min_exec_version = 36;

	(* ACHTUNG! template, Quals und quals_array müssen übereinstimmen! *)
	template = "LSHIFT/S,RSHIFT/S,CAPSLOCK/S,CONTROL/S,LALT/S,RALT/S,LCOMMAND/S,RCOMMAND/S,MIDBUTTON/S,RIGHTBUTTON/S,LEFTBUTTON/S";

TYPE
	(* ACHTUNG! template, Quals und quals_array müssen übereinstimmen! *)
	Quals = (q_lshift, q_rshift, q_capsLock, q_control, q_lalt, q_ralt, q_lcommand, q_rcommand, q_midbutton, q_rightbutton, q_leftbutton);

	QualsArray = ARRAY Quals OF Qualifiers;
	QualFlagArray = ARRAY Quals OF LONGINT;

CONST
	(* ACHTUNG! template, Quals und quals_array müssen übereinstimmen! *)
	quals_array = QualsArray {lShift, rShift, capsLock, control, lAlt, rAlt, lCommand, rCommand, midButton, rightButton, leftButton};

VAR
	(* Pointers *)
	msg_port_ptr: MsgPortPtr;
	rd_args_ptr: RDArgsPtr;
	req_ptr: IOStdReqPtr;

	(* other 32bit stuff *)
	given_quals: QualFlagArray;

	(* other stuff *)
	check_quals: QualifierSet;
	i: Quals;
	quals: QualifierSet;

(* ------------------------------------------------------------------------- *)

PROCEDURE WriteString (str: ARRAY OF CHAR);

	VAR
		written: LONGINT;

	BEGIN (* Prozedur WriteString *)
		IF Output () # NIL THEN
			written := Write (Output (), ADR (str), -1);
		END; (* IF Output () # NIL *)
	END WriteString; (* Prozedur *)

(* ------------------------------------------------------------------------- *)

BEGIN
	IF (execVersion >= min_exec_version) AND (dosVersion >= min_dos_version) THEN
		rd_args_ptr := ReadArgs (ADR (template), ADR (given_quals), NIL);

		IF rd_args_ptr # NIL THEN
			check_quals := QualifierSet {};

			FOR i := MIN (Quals) TO MAX (Quals) DO
				IF given_quals [i] # 0 THEN
					INCL (check_quals, quals_array [i]);
				END; (* IF given_quals [i] # 0 *)
			END; (* FOR i := MIN (Quals) TO MAX (Quals) DO *)

			msg_port_ptr := CreateMsgPort ();

			IF msg_port_ptr # NIL THEN
				req_ptr := CreateIORequest (msg_port_ptr, SIZE (req_ptr^));

				IF req_ptr # NIL THEN
					OpenDevice (ADR (inputName), 0, req_ptr, LONGSET {});

					IF req_ptr^.error = 0 THEN
						quals := CAST (QualifierSet, PeekQualifier (req_ptr^.device));

						IF quals * check_quals # QualifierSet {} THEN
							(* at least one of the given qualifiers has been pressed *)
							IF quals * check_quals = check_quals THEN
								(* check_quals or more are pressed *)
								IF quals = check_quals THEN
									(* exactly check_quals are pressed *)
									returnVal := 3;

								ELSE (* IF quals = check_quals *)
									returnVal := 2;
								END; (* IF quals = check_quals ELSE *)

							ELSE (* IF quals * check_quals = check_quals *)
								returnVal := 1;
							END; (* IF quals * check_quals = check_quals ELSE *)

						ELSE (* IF quals * check_quals # QualifierSet {} *)
							returnVal := 0;
						END; (* IF quals * check_quals # QualifierSet {} ELSE *)

						CloseDevice (req_ptr);

					ELSE (* IF req_ptr^.error = 0 *)
						WriteString ("Sorry, could not open the input.device!\n");
						returnVal := fail;
					END; (* IF req_ptr^.error = 0 ELSE *)

					DeleteIORequest (req_ptr);

				ELSE (* IF req_ptr # NIL *)
					WriteString ("Sorry, could not create IOStdReq!\n");
					returnVal := fail;
				END; (* IF req_ptr # NIL ELSE *)

				DeleteMsgPort (msg_port_ptr);

			ELSE (* IF msg_port_ptr # NIL *)
				WriteString ("Sorry, could not open msg port!\n");
				returnVal := fail;
			END; (* IF msg_port_ptr # NIL ELSE *)

			FreeArgs (rd_args_ptr);

		ELSE (* IF rd_args_ptr # NIL *)
			IF PrintFault (IoErr (), NIL) THEN END;
			returnVal := fail;
		END; (* IF rd_args_ptr # NIL ELSE *)

	ELSE (* IF (execVersion >= min_exec_version ... *)
		WriteString ("Sorry, your OS is too old (2.0 recommended)!\n");
		returnVal := fail;
	END; (* IF execVersion >= min_exec_version ... ELSE *)
END CheckQualifiers. (* Programm *)