mmringbf.pas

一套及时通讯的原码

         begin
            FStarted := True;
            {$IFDEF _MMDEBUG}
            DebugStr(0,'Duplex mode now started...')
            {$ENDIF};
         end;
         LeaveCritical;
         exit;
      end
      else LeaveCritical;

      if not Empty then
      begin
         { returns the next buffer from the queue }
         Size := Min(FBufferPool^[FOutIndex]^.dwSize,dwSize);
         GlobalMoveMem(FBufferPool^[FOutIndex]^.lpData^,lpData^,Size);
         dwSize := Size;
         dwUser := FBufferPool^[FOutIndex]^.dwUser;
         dwFlags:= FBufferPool^[FOutIndex]^.dwFlags;

         EnterCritical;
         try
            if (dwSize < FBufferPool^[FOutIndex]^.dwSize) then
            begin
               dec(FBufferPool^[FOutIndex]^.dwSize,Size);
               GlobalMoveMem(PChar(FBufferPool^[FOutIndex]^.lpData+Size)^,
                             FBufferPool^[FOutIndex]^.lpData^,
                             FBufferPool^[FOutIndex]^.dwSize);
            end
            else
            begin
               FLastIndex := FOutIndex;
               FOutIndex := (FOutIndex+1)mod FNumBuffers;
               dec(FQueueCount);
            end;
            dec(FBytesQueued,Size);

         finally
            LeaveCritical;
         end;

         {$IFDEF _MMDEBUG}
         DebugStr(2,'Buffer '+IntToStr(dwUser)+' removed from queue')
         {$ENDIF};
      end
      else
      begin
         {$IFDEF _MMDEBUG}
         DebugStr(2,'Queue is empty, loop last buffer...')
         {$ENDIF};

         { notify the user }
         DoEmpty;

         { buffer is empty }
         if FLoopIfEmpty or ((PWaveFormat <> nil) and (PWaveFormat^.wFormatTag <> WAVE_FORMAT_PCM)) then
         begin
            { return the last buffer (loop) }
            Size := Min(FBufferPool^[FLastIndex]^.dwSize,dwSize);
            GlobalMoveMem(FBufferPool^[FLastIndex]^.lpData^,lpData^,Size);
            dwSize := Size;
            dwUser := FBufferPool^[FLastIndex]^.dwUser;
            dwFlags:= FBufferPool^[FLastIndex]^.dwFlags;
         end
         else
         begin
            { simply fill the buffer }
            if (PWaveFormat <> nil) and (PWaveFormat^.wBitsPerSample = 8) then
               GlobalFillMem(lpData^,dwSize,128)
            else
               GlobalFillMem(lpData^,dwSize,0);

            dwUser := 0;
            dwFlags:= 0;
         end;
      end;
   end
   else dwSize := 0;
end;

{-- TMMRingBuffer --------------------------------------------------------}
function TMMRingBuffer.PutBlock(lpData: PChar; dwSize,dwFlags: DWORD): DWORD;
var
   Size,Flags: DWORD;

begin
   { puts a block of data with "dwSize" in the queue }
   Result := 0;
   Flags  := 0;
   while (dwSize > 0) do
   begin
      if Full then break;
      Size := Min(dwSize,BufferSize);
      { is this the last buffer ? if so then save the loop field }
      if (dwSize-Size <= 0) then Flags := dwFlags;
      PutBuffer(lpData,Size,0,Flags);
      dec(dwSize,Size);
      inc(lpData,Size);
      inc(Result,Size);
   end
end;

{-- TMMRingBuffer --------------------------------------------------------}
function TMMRingBuffer.GetBlock(lpData: PChar; dwSize: DWORD): DWORD;
var
   Size,Dummy: DWORD;

begin
   { returns a block of data with "dwSize" from the queue }
   Result := 0;
   while (dwSize > 0) do
   begin
      if Empty then break;
      Size := dwSize;
      GetBuffer(lpData,Size,Dummy,Dummy);
      if (Size > 0) then
      begin
         dec(dwSize,Size);
         inc(lpData,Size);
         inc(Result,Size);
      end
      else break;
   end;
end;

{-- TMMRingBuffer --------------------------------------------------------}
procedure TMMRingBuffer.Opened;
begin
   inherited Opened;

   Open;
end;

{-- TMMRingBuffer --------------------------------------------------------}
procedure TMMRingBuffer.Closed;
begin
   {$IFDEF _MMDEBUG}
   DebugStr(0,'Close received...');
   {$ENDIF}

   Close;

   inherited Closed;
end;

{-- TMMRingBuffer --------------------------------------------------------}
procedure TMMRingBuffer.Started;
begin
   FStopping := False;

   {$IFDEF _MMDEBUG}
   DebugStr(0,'Queue started...');
   {$ENDIF}

   inherited Started;
end;

{-- TMMRingBuffer --------------------------------------------------------}
procedure TMMRingBuffer.Stopped;
begin
   {$IFDEF _MMDEBUG}
   DebugStr(0,'Try to stop Queue...');
   {$ENDIF}

   FStarted := False;
   FStopping := True;
   FLoopRec.dwLoop := False;

   { make sure the queue is flushed in write mode }
   Flush;

   {$IFDEF _MMDEBUG}
   DebugStr(0,'Queue stopped...');
   {$ENDIF}

   inherited Stopped;
end;

{-- TMMRingBuffer --------------------------------------------------------}
procedure TMMRingBuffer.Reseting;
begin
   FStarted := False;
   FStopping := True;
   FLoopRec.dwLoop := False;

   { make sure the queue is flushed in write mode }
   Flush;

   Clear;

   FStopping := False;
   
   inherited Reseting;
end;

{-- TMMRingBuffer --------------------------------------------------------}
procedure TMMRingBuffer.BufferReady(lpwh: PWaveHdr);
begin
   if (FQueueMode in [qmWrite,qmDuplex]) then
   begin
      { the input has some data so put in the queue }
      PutBuffer(lpwh^.lpData,lpwh^.dwBytesRecorded,lpwh^.dwUser,0);
   end
   else inherited BufferReady(lpwh)
end;

{-- TMMRingBuffer --------------------------------------------------------}
procedure TMMRingBuffer.BufferLoad(lpwh: PWaveHdr; var MoreBuffers: Boolean);
var
   Flags: DWORD;
begin
   { the Output needs some data, try to get it }
   if (FQueueMode in [qmRead,qmDuplex]) then
   begin
      if FOpen then
      begin
         with PMMWaveHdr(lpwh)^ do
         begin
            if FEnabled or (BytesQueued > 0) or (FQueueMode in [qmDuplex]) then
            begin
               { setup the loop handling }
               if FLoopRec.dwLoop <> LoopRec.dwLoop then
               begin
                  FLoopRec.dwLoop := LoopRec.dwLoop;
                  if FLoopRec.dwLoop then
                  begin
                     FLoopRec.dwLoopCnt    := LoopRec.dwLoopCnt;
                     FLoopRec.dwLoopTmpCnt := LoopRec.dwLoopTmpCnt;
                     FLoopRec.dwLooping    := False;
                  end;
               end;

               wh.dwBytesRecorded := wh.dwBufferLength;
               GetBuffer(wh.lpData,wh.dwBytesRecorded,wh.dwUser,Flags);

               { is looped ? }
               LoopRec.dwLooping := (Flags and HDR_LOOP = HDR_LOOP);

               if (FQueueMode = qmDuplex) then
                   MoreBuffers := True
               else                    { last Block ? }
                   MoreBuffers := not (Flags and HDR_END = HDR_END);
            end
            else inherited BufferLoad(lpwh,MoreBuffers);
         end;
      end;
   end
   else inherited BufferLoad(lpwh,MoreBuffers);
end;

{-- TMMRingBuffer --------------------------------------------------------}
procedure TMMRingBuffer.FillQueue;
var
   MoreBuffers: Boolean;
   Flags: DWORD;

begin
   StartDSPMeter;
   try
      if FOpen and (BytesFree > 0) then
      begin
         DoFillQueue;

         while (BytesFree > 0) and not FStopping do
         begin
            with FTempBuffer^ do
            begin
               dwBufferLength := Min(BytesFree,FReadSize);
               dwBytesRecorded := 0;

               PMMWaveHdr(FTempBuffer)^.LoopRec := FLoopRec;

               MoreBuffers := False;
               inherited BufferLoad(FTempBuffer, MoreBuffers);

               { let other threads have some time }
               Sleep(SLEEPTIME);

               if (dwBytesRecorded <= 0) then
               begin
                  { mark the previous buffer as last and exit }
                  EnterCritical;
                  with FBufferPool^[FLastIndex]^ do dwFlags := dwFlags or HDR_END;
                  LeaveCritical;
                  break;
               end;

               FLoopRec := PMMWaveHdr(FTempBuffer)^.LoopRec;

               Flags := 0;
               if not MoreBuffers then Flags := Flags or HDR_END;
               if FloopRec.dwLooping then Flags := Flags or HDR_LOOP;

               PutBlock(lpData,dwBytesRecorded,FLags);
               FLoopRec.dwLooping    := False;

               if not MoreBuffers or FStopping then break;
            end;
            { let other threads have some time }
            Sleep(SLEEPTIME);
         end;

         DoFillQueueEnd;
      end;

   finally
      ResetEvent(FQueueEvent);
      SetEvent(FDoneEvent);
      StopDSPMeter;
   end;
end;

{-- TMMRingBuffer --------------------------------------------------------}
procedure TMMRingBuffer.FlushQueue;
var
   Size: Longint;
begin
   StartDSPMeter;
   try
      if FOpen and (BytesQueued > 0) then
      begin
         DoFlushQueue;

         while (BytesQueued > 0) do
         begin
            Size := Min(BytesQueued,FWriteSize);
            Size := GetBlock(FTempBuffer^.lpData,Size);

            if (Size <= 0) then break;

            FTempBuffer^.dwBytesRecorded := Size;
            FTempBuffer^.dwBufferLength  := FWriteSize;

            inherited BufferReady(FTempBuffer);

            { let other threads have some time }
            Sleep(SLEEPTIME);
         end;

         DoFlushQueueEnd;
      end;

   finally
      ResetEvent(FQueueEvent);
      SetEvent(FDoneEvent);
      StopDSPMeter;
   end;
end;

{-------------------------------------------------------------------------}
procedure TMMQueueThread.Execute;
var
   Res    : DWORD;
   Handles: array[0..1] of THandle;
   {$IFDEF _MMDEBUG}
   Error  : Longint;
   {$ENDIF}

begin
   with TMMRingBuffer(Owner) do
   try
      Priority := CACHE_PRIORITY;

      { Ready to go, set the general event }
      SetEvent(FGeneralEvent);

      Handles[0] := FCloseEvent;
      Handles[1] := FQueueEvent;

      { Repeat until closed }
      while not Terminated do
      try
         Res := WaitForMultipleObjects(2, @Handles, False, INFINITE);
         case Res of
            WAIT_FAILED:       { Wait failed.  Shouldn't happen. }
            begin
               {$IFDEF _MMDEBUG}
               Error := GetLastError;
               DebugStr(0,'Wait Failed... Error: '+SysErrorMessage(Error));
               {$ENDIF}
            end;
            WAIT_OBJECT_0:     { CloseEvent signaled!            }
            begin
               { Finished here, okay to close device }
               {$IFDEF _MMDEBUG}
               DebugStr(0,'CloseEvent signaled...');
               {$ENDIF}
               exit;
            end;
            WAIT_OBJECT_0+1:    { queue event received.          }
            begin
               if (FQueueMode = qmRead) then
               begin
                  {$IFDEF _MMDEBUG}
                  DebugStr(1,'ReadEvent received...');
                  {$ENDIF}

                  FillQueue;

                  {$IFDEF _MMDEBUG}
                  DebugStr(1,'Reading done...');
                  {$ENDIF}
               end
               else
               begin
                  {$IFDEF _MMDEBUG}
                  DebugStr(1,'WriteEvent received...');
                  {$ENDIF}

                  FlushQueue;

                  {$IFDEF _MMDEBUG}
                  DebugStr(1,'Writing done...');
                  {$ENDIF}
               end;
            end;
         end;

      except
         PulseEvent(FDoneEvent);
         Close;
         FThreadError := True;
         Application.HandleException(nil);
         exit;
      end;

   finally
     SetEvent(FGeneralEvent);

     {$IFDEF _MMDEBUG}
     DebugStr(0,'Exit Thread-Proc');
     {$ENDIF}
   end;
end;

initialization
{$IFDEF _MMDEBUG}
   DB_Level(DEBUGLEVEl);
{$ENDIF}
end.