Prima Shareware 3/DuCom_Prima-Shareware-3_cd1.bin/PROGRAMO/PASCAL/HUBI/MLB_NFIX.PAS

Pascal/Delphi Source File | 1995-05-25 | 8.1 KB | 272 lines

unit MLB_nfix;
{ non - permanent MIDI part }

{$C PRELOAD FIXED DISCARDABLE}

interface
uses MMSYSTEM;
const
      DRIVER_VERSION = 1;

procedure modGetDevCaps(id:WORD;var lpCaps; wSize:WORD);
procedure PortName( name:PChar; id:integer );
function midMessage(id:WORD; msg: WORD; dwUser, dwparam1, dwparam2:LongInt):Longint;export;

const       gszPort : PChar = 'LB%c';
            gszSection : PChar = 'midlpbk.drv';
            gszIniFile : PChar = 'system.ini';


implementation
uses WinTypes,WinProcs,MLB_fix;

{ --------------------------------------------------------------------------
  UTILITY Functions
  -------------------------------------------------------------------------- }
function Min(a:Word;b:Word):Word;
begin
  if a<b then Min:=a else Min:=b;
end;

{ return name of port[id] in name }
procedure PortName( name:PChar; id:integer );
begin
   inc(id,Ord('1'));
   wvsprintf(name,gszPort,id);
   { if an entry e.g. 'LB1=Cubase to Cakewalk' exist, use this as displayed device name }
   GetPrivateProfileString(gszSection,name,name,name,MaxPNameLen,gszIniFile);
end;

procedure modGetDevCaps(id:WORD;var lpCaps; wSize:WORD);
VAR mc : TMIDIOUTCAPS;
    name: array[0..MAXPNAMELEN-1] of char;
BEGIN
    mc.wMid := 0;
    mc.wPid := 0;
    mc.vDriverVersion := DRIVER_VERSION;
    mc.wTechnology := MOD_MIDIPORT;
    mc.wVoices := 0;           { not used for ports }
    mc.wNotes := 0;            { not used for ports }
    mc.wChannelMask := $FFFF;  { all channels }
    mc.dwSupport := 0;
    PortName(mc.szPname,id);
    Move(mc,lpCaps,Min(wSize,sizeof(mc)));
END;

{-------------------------------------------------------------------------
  BEGIN OF MIDI INPUT PART
  -------------------------------------------------------------------------  }
procedure midGetDevCaps(id:WORD;var lpCaps; wSize:WORD);
VAR mc : TMIDIINCAPS;
BEGIN
    mc.wMid := 0;
    mc.wPid := 0;
    mc.vDriverVersion := DRIVER_VERSION;
    PortName(mc.szPName,id);
    Move(mc,lpCaps, Min(wSize,sizeof(mc)));
END;

function midAddBuffer(id,cl:Integer; lpmh:PMIDIHDR ):Longint;
VAR lpN:PMIDIHDR;
BEGIN
    { check if it's been prepared }
    if (lpmh^.dwFlags and MHDR_PREPARED)=0 then
        midAddBuffer := MIDIERR_UNPREPARED
    else
    { check if it's in our queue already }
    if (lpmh^.dwFlags and MHDR_INQUEUE)<>0 then
        midAddBuffer := MIDIERR_STILLPLAYING
    else BEGIN
         { add the buffer to our queue }
         with lpmh^ do BEGIN
              dwFlags := dwFlags or MHDR_INQUEUE;
              dwFlags := dwFlags and (not MHDR_DONE);

              { sanity }
              dwBytesRecorded := 0;
              lpNext := nil;
         end;
{         CritEnter;}

         lpN := gMIMC[id,cl].lpmhQueue;
         if lpN<>nil then
            begin
               while ( lpN<>nil ) and ( lpN^.lpNext<>nil )
               do lpN := lpN^.lpNext;

               lpN^.lpNext := lpmh;
            end
        else
            gMIMC[id,cl].lpmhQueue := lpmh;

{       CritLeave;}

       { return success }
       midAddBuffer := 0;
    END;
END;

procedure midFreeQ(id,cl:integer);
VAR
     lpH, lpN:PMIDIHDR;
     dwTime:LongInt;
BEGIN
    With gMIMC[id,cl] do begin
       lpH := lpmhQueue;  { point to top of the queue }
       lpmhQueue := nil;  { mark the queue as empty }
       dwCurData := 0;
       dwTime := timeGetTime - dwRefTime;
    end;

    while (lpH <> nil) do BEGIN
        lpN := lpH^.lpNext;
        with lpH^ do begin
             dwFlags := dwFlags or MHDR_DONE;
             dwFlags := dwFlags and (not MHDR_INQUEUE);
        end;
        lpH^.dwBytesRecorded := 0;
        MsgCallBack(gMidiInClient[id,cl],MIM_LONGDATA, LongInt(lpH), dwTime);
        lpH := lpN;
    END;
END;

procedure midSendPartBuffer(id,cl:integer);
var lpH : PMIDIHDR;
BEGIN
   with gMIMC[id,cl] do
    if ( lpmhQueue <> nil) and (dwCurData<>0) then begin
        lpH := lpmhQueue;
        lpmhQueue := lpmhQueue^.lpNext;
        dwCurData := 0;
        lpH^.dwFlags := lpH^.dwflags or MHDR_DONE;
        lpH^.dwFlags := lpH^.dwFlags and (not MHDR_INQUEUE);
        MsgCallBack(gMidiInClient[id,cl],MIM_LONGERROR, LongInt(lpH), dwMsgTime);
   end;
end;


procedure midStop(id,cl:integer);
BEGIN
   if gMIMC[id,cl].bStarted then midSendPartBuffer(id,cl);
   gMIMC[id,cl].bstarted := false;
END;

{ -------------------------------------------------------------------------
  MIDI INPUT MESSAGE PROCESSING
  ------------------------------------------------------------------------- }
function midMessage(id:WORD; msg: WORD; dwUser, dwparam1, dwparam2:LongInt):Longint;
const { from MMDDK.INC}
     MIDM_GETNUMDEVS  =53;
     MIDM_GETDEVCAPS  =54;
     MIDM_OPEN        =55;
     MIDM_CLOSE       =56;
     MIDM_PREPARE     =57;
     MIDM_UNPREPARE   =58;
     MIDM_ADDBUFFER   =59;
     MIDM_START       =60;
     MIDM_STOP        =61;
     MIDM_RESET       =62;

var cl:integer;

BEGIN
     if (id >= gActivePorts) then begin
        midMessage := MMSYSERR_BADDEVICEID;
        exit;
     end;
     MidMessage := 0; { some fewer BEGINs req'd so}
     case msg of
     MIDM_GETNUMDEVS:
          midMessage := gActivePorts;
     MIDM_GETDEVCAPS:
          midGetDevCaps(id,Pointer(dwparam1)^,WORD(dwparam2));
     MIDM_OPEN:
          BEGIN
            midMessage:=MMSYSERR_ALLOCATED;
            for cl:=0 to gNumInClients-1 do begin
              if gMidiInClient[id,cl].h_Midi=0 then begin
                 { use this port }
                 PLongInt(dwUser)^:=cl;
                 { save client information }
                 with gMidiInClient[id,cl] do begin
                    dwCallback := PMIDIOPENDESC(dwParam1)^.dwCallback;
                    dwInstance := PMIDIOPENDESC(dwParam1)^.dwInstance;
                    h_Midi     := PMIDIOPENDESC(dwParam1)^.hMidi;
                    dwFlags    := dwParam2;

                 { initialize queue stuff }
                   with gMIMC[id,cl] do begin
                        dwCurData := 0;
                        lpmhQueue := nil;

                      {  NOTE: we must initialize reference time in case someone adds }
                      {  longdata buffers after opening, then resets the midi stream }
                      {  without starting midi input.  Otherwise, midFreeQ would give }
                      {  inconsistent timestamps }
                         dwRefTime := timeGetTime;

                         bStarted := false;
                   end;
                 end;
                 MsgCallBack(gMidiInClient[id,cl],MIM_OPEN,0,0);
                 midMessage:=0;
                 break;
              end;
            end;
          END;
     MIDM_CLOSE:
          begin
           cl:=dwUser;
           midStop(id,cl);
           if gMIMC[id,cl].lpmhQueue <> nil then
             midMessage := MIDIERR_STILLPLAYING
           else BEGIN
             MsgCallBack(gMidiInClient[id,cl],MIM_CLOSE,0,0);
             gMidiInClient[id,cl].h_Midi := 0; { Mark as closed }
           END;
          end;

       MIDM_ADDBUFFER:
            { attempt to add the buffer }
            midMessage := midAddBuffer(id,dwUser,PMIDIHDR(dwParam1));

       MIDM_START:
            with gMIMC[id,dwUser] do begin
            { initialize all the parsing status variables }
                 bstarted := true;
                 fSysEx := false;
                 bStatus := 0;
                 bBytesLeft := 0;
                 bBytePos := 0;
                 dwShortMsg := 0;
                 dwMsgTime := 0;
                 dwRefTime := 0;
                 dwCurData := 0;

                 { get a new reference time }
                 dwRefTime := timeGetTime;
            end;

        MIDM_STOP:
            midStop(id,dwUser);

        MIDM_RESET:
            BEGIN
             cl:=dwUser;
             { stop if it is started and release all buffers }
             midStop(id,cl);
             midFreeQ(id,cl);
            END;

{        MIDM_UNPREPARE:
        MIDM_PREPARE:
}
     else
          midMessage := MMSYSERR_NOTSUPPORTED;
     end;
END;



begin
end.