1 files changed, 140 insertions, 0 deletions
diff --git a/src/lib/midi/DELPHMCB.PAS b/src/lib/midi/DELPHMCB.PAS
new file mode 100644
index 00000000..ef0d5451
--- /dev/null
+++ b/src/lib/midi/DELPHMCB.PAS
@@ -0,0 +1,140 @@
+{ $Header: /MidiComp/DELPHMCB.PAS 2     10/06/97 7:33 Davec $ }
+
+{MIDI callback for Delphi, was DLL for Delphi 1}
+
+unit Delphmcb;
+
+{ These segment options required for the MIDI callback functions }
+{$IFNDEF FPC}
+{$C PRELOAD FIXED PERMANENT}
+{$ENDIF}
+
+interface
+
+{$IFDEF FPC}
+  {$MODE Delphi}
+  {$H+} // use long strings
+{$ENDIF}
+
+uses
+  Windows,
+  MMsystem,
+  Circbuf,
+  MidiDefs,
+  MidiCons;
+
+procedure midiHandler(
+		  hMidiIn: HMidiIn;
+		  wMsg: UINT;
+		  dwInstance: DWORD;
+		  dwParam1: DWORD;
+		  dwParam2: DWORD); stdcall; export;
+function CircbufPutEvent(PBuffer: PCircularBuffer; PTheEvent: PMidiBufferItem): Boolean; stdcall; export;
+
+implementation
+
+{ Add an event to the circular input buffer. }
+function CircbufPutEvent(PBuffer: PCircularBuffer; PTheEvent: PMidiBufferItem): Boolean; stdcall;
+begin
+	If (PBuffer^.EventCount < PBuffer^.Capacity) Then
+		begin
+		Inc(Pbuffer^.EventCount);
+
+		{ Todo: better way of copying this record }
+		with PBuffer^.PNextput^ do
+			begin
+			Timestamp := PTheEvent^.Timestamp;
+			Data := PTheEvent^.Data;
+			Sysex := PTheEvent^.Sysex;
+          end;
+
+		{ Move to next put location, with wrap }
+		Inc(Pbuffer^.PNextPut);
+		If (PBuffer^.PNextPut = PBuffer^.PEnd) then
+			PBuffer^.PNextPut := PBuffer^.PStart;
+
+		CircbufPutEvent := True;
+		end
+	else
+		CircbufPutEvent := False;
+end;
+
+{ This is the callback function specified when the MIDI device was opened
+  by midiInOpen. It's called at interrupt time when MIDI input is seen
+  by the MIDI device driver(s). See the docs for midiInOpen for restrictions
+  on the Windows functions that can be called in this interrupt. }
+procedure midiHandler(
+		  hMidiIn: HMidiIn;
+		  wMsg: UINT;
+		  dwInstance: DWORD;
+		  dwParam1: DWORD;
+		  dwParam2: DWORD); stdcall;
+var
+	thisEvent: TMidiBufferItem;
+	thisCtlInfo: PMidiCtlInfo;
+	thisBuffer: PCircularBuffer;
+Begin
+	case wMsg of
+
+		mim_Open: {nothing};
+
+		mim_Error: {TODO: handle (message to trigger exception?) };
+
+		mim_Data, mim_Longdata, mim_Longerror:
+			{ Note: mim_Longerror included because there's a bug in the Maui
+			input driver that sends MIM_LONGERROR for subsequent buffers when
+			the input buffer is smaller than the sysex block being received }
+
+			begin
+			{ TODO: Make filtered messages customisable, I'm sure someone wants to
+			do something with MTC! }
+			if (dwParam1 <> MIDI_ACTIVESENSING) and
+							(dwParam1 <> MIDI_TIMINGCLOCK) then
+				begin
+
+				{ The device driver passes us the instance data pointer we
+				specified for midiInOpen. Use this to get the buffer address
+				and window handle for the MIDI control }
+				thisCtlInfo := PMidiCtlInfo(dwInstance);
+				thisBuffer := thisCtlInfo^.PBuffer;
+
+				{ Screen out short messages if we've been asked to }
+				if ((wMsg <> mim_Data) or (thisCtlInfo^.SysexOnly = False))
+					and (thisCtlInfo <> Nil) and (thisBuffer <> Nil) then
+					begin
+					with thisEvent do
+						begin
+						timestamp := dwParam2;
+						if (wMsg = mim_Longdata) or
+							(wMsg = mim_Longerror) then
+							begin
+							data := 0;
+							sysex := PMidiHdr(dwParam1);
+							end
+						else
+							begin
+							data := dwParam1;
+							sysex := Nil;
+							end;
+						end;
+					if CircbufPutEvent( thisBuffer, @thisEvent ) then
+						{ Send a message to the control to say input's arrived }
+						PostMessage(thisCtlInfo^.hWindow, mim_Data, 0, 0)
+					else
+						{ Buffer overflow }
+						PostMessage(thisCtlInfo^.hWindow, mim_Overflow, 0, 0);
+					end;
+				end;
+			end;
+
+		mom_Done:	{ Sysex output complete, dwParam1 is pointer to MIDIHDR }
+			begin
+			{ Notify the control that its sysex output is finished.
+			  The control should call midiOutUnprepareHeader before freeing the buffer }
+			PostMessage(PMidiCtlInfo(dwInstance)^.hWindow, mom_Done, 0, dwParam1);
+			end;
+
+	end;	{ Case }
+end;
+
+end.