Delphi控件源码

开发平台：

Delphi

BaseClass.pas：源码内容

FObjectCreationLock.Lock;
try
// Should only ever be called with zero
Assert(n = 0);
if (n <> 0) then
begin
Result := nil;
Exit;
end;
// Create the input pin if not already done so
if (FInputPin = nil) then
begin
// hr must be initialized to NOERROR because
// CRendererInputPin's constructor only changes
// hr's value if an error occurs.
hr := NOERROR;
FInputPin := TBCRendererInputPin.Create(Self, hr, 'In');
if (FInputPin = nil) then
begin
Result := nil;
Exit;
end;
if Failed(hr) then
begin
FreeAndNil(FInputPin);
Result := nil;
Exit;
end;
end;
Result := FInputPin;
finally
FObjectCreationLock.UnLock;
end;
end;
function DumbItDownFor95(const S1, S2: WideString; CmpFlags: Integer): Integer;
var
a1, a2: AnsiString;
begin
a1 := s1;
a2 := s2;
Result := CompareStringA(LOCALE_USER_DEFAULT, CmpFlags, PChar(a1), Length(a1),
PChar(a2), Length(a2)) - 2;
end;
function WideCompareText(const S1, S2: WideString): Integer;
begin
SetLastError(0);
Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PWideChar(S1),
Length(S1), PWideChar(S2), Length(S2)) - 2;
case GetLastError of
0: ;
ERROR_CALL_NOT_IMPLEMENTED: Result := DumbItDownFor95(S1, S2, NORM_IGNORECASE);
end;
end;
// If "In" then return the IPin for our input pin, otherwise NULL and error
function TBCBaseRenderer.FindPin(id: PWideChar; out Pin: IPin): HResult;
begin
// Milenko start
if (@Pin = nil) then
begin
Result := E_POINTER;
Exit;
end;
// Milenko end
// milenko start (delphi 5 doesn't know WideCompareText)
if WideCompareText(id, 'In') = 0 then
// milenko end
begin
Pin := GetPin(0);
Assert(Pin <> nil);
// ??? Pin.AddRef;
Result := NOERROR;
end
else
begin
Pin := nil;
Result := VFW_E_NOT_FOUND;
end;
end;
// Called when the input pin receives an EndOfStream notification. If we have
// not got a sample, then notify EC_COMPLETE now. If we have samples, then set
// m_bEOS and check for this on completing samples. If we're waiting to pause
// then complete the transition to paused state by setting the state event
function TBCBaseRenderer.EndOfStream: HResult;
begin
// Ignore these calls if we are stopped
if (FState = State_Stopped) then
begin
Result := NOERROR;
Exit;
end;
// If we have a sample then wait for it to be rendered
FIsEOS := True;
if Assigned(FMediaSample) then
begin
Result := NOERROR;
Exit;
end;
// If we are waiting for pause then we are now ready since we cannot now
// carry on waiting for a sample to arrive since we are being told there
// won't be any. This sets an event that the GetState function picks up
Ready;
// Only signal completion now if we are running otherwise queue it until
// we do run in StartStreaming. This is used when we seek because a seek
// causes a pause where early notification of completion is misleading
if FIsStreaming then
SendEndOfStream;
Result := NOERROR;
end;
// When we are told to flush we should release the source thread
function TBCBaseRenderer.BeginFlush: HResult;
begin
// If paused then report state intermediate until we get some data
if (FState = State_Paused) then
NotReady;
SourceThreadCanWait(False);
CancelNotification;
ClearPendingSample;
// Wait for Receive to complete
WaitForReceiveToComplete;
Result := NOERROR;
end;
// After flushing the source thread can wait in Receive again
function TBCBaseRenderer.EndFlush: HResult;
begin
// Reset the current sample media time
if Assigned(FPosition) then
FPosition.ResetMediaTime;
// There should be no outstanding advise
Assert(CancelNotification = S_FALSE);
SourceThreadCanWait(True);
Result := NOERROR;
end;
// We can now send EC_REPAINTs if so required
function TBCBaseRenderer.CompleteConnect(ReceivePin: IPin): HResult;
begin
// The caller should always hold the interface lock because
// the function uses CBaseFilter::m_State.
{$IFDEF DEBUG}
Assert(FInterfaceLock.CritCheckIn);
{$ENDIF}
FAbort := False;
if (State_Running = GetRealState) then
begin
Result := StartStreaming;
if Failed(Result) then
Exit;
SetRepaintStatus(False);
end
else
SetRepaintStatus(True);
Result := NOERROR;
end;
// Called when we go paused or running
function TBCBaseRenderer.Active: HResult;
begin
Result := NOERROR;
end;
// Called when we go into a stopped state
function TBCBaseRenderer.Inactive: HResult;
begin
if Assigned(FPosition) then
FPosition.ResetMediaTime;
// People who derive from this may want to override this behaviour
// to keep hold of the sample in some circumstances
ClearPendingSample;
Result := NOERROR;
end;
// Tell derived classes about the media type agreed
function TBCBaseRenderer.SetMediaType(MediaType: PAMMediaType): HResult;
begin
Result := NOERROR;
end;
// When we break the input pin connection we should reset the EOS flags. When
// we are asked for either IMediaPosition or IMediaSeeking we will create a
// CPosPassThru object to handles media time pass through. When we're handed
// samples we store (by calling CPosPassThru::RegisterMediaTime) their media
// times so we can then return a real current position of data being rendered
function TBCBaseRenderer.BreakConnect: HResult;
begin
// Do we have a quality management sink
if Assigned(FQSink) then
FQSink := nil;
// Check we have a valid connection
if not FInputPin.IsConnected then
begin
Result := S_FALSE;
Exit;
end;
// Check we are stopped before disconnecting
if (FState <> State_Stopped) and (not FInputPin.CanReconnectWhenActive) then
begin
Result := VFW_E_NOT_STOPPED;
Exit;
end;
SetRepaintStatus(False);
ResetEndOfStream;
ClearPendingSample;
FAbort := False;
if (State_Running = FState) then
StopStreaming;
Result := NOERROR;
end;
// Retrieves the sample times for this samples (note the sample times are
// passed in by reference not value). We return S_FALSE to say schedule this
// sample according to the times on the sample. We also return S_OK in
// which case the object should simply render the sample data immediately
function TBCBaseRenderer.GetSampleTimes(MediaSample: IMediaSample;
out StartTime: TReferenceTime; out EndTime: TReferenceTime): HResult;
begin
Assert(FAdvisedCookie = 0);
Assert(Assigned(MediaSample));
// If the stop time for this sample is before or the same as start time,
// then just ignore it (release it) and schedule the next one in line
// Source filters should always fill in the start and end times properly!
if Succeeded(MediaSample.GetTime(StartTime, EndTime)) then
begin
if (EndTime < StartTime) then
begin
Result := VFW_E_START_TIME_AFTER_END;
Exit;
end;
end
else
begin
// no time set in the sample... draw it now?
Result := S_OK;
Exit;
end;
// Can't synchronise without a clock so we return S_OK which tells the
// caller that the sample should be rendered immediately without going
// through the overhead of setting a timer advise link with the clock
if (FClock = nil) then
Result := S_OK
else
Result := ShouldDrawSampleNow(MediaSample, StartTime, EndTime);
end;
// By default all samples are drawn according to their time stamps so we
// return S_FALSE. Returning S_OK means draw immediately, this is used
// by the derived video renderer class in its quality management.
function TBCBaseRenderer.ShouldDrawSampleNow(MediaSample: IMediaSample;
StartTime: TReferenceTime; out EndTime: TReferenceTime): HResult;
begin
Result := S_FALSE;
end;
// We must always reset the current advise time to zero after a timer fires
// because there are several possible ways which lead us not to do any more
// scheduling such as the pending image being cleared after state changes
procedure TBCBaseRenderer.SignalTimerFired;
begin
FAdvisedCookie := 0;
end;
// Cancel any notification currently scheduled. This is called by the owning
// window object when it is told to stop streaming. If there is no timer link
// outstanding then calling this is benign otherwise we go ahead and cancel
// We must always reset the render event as the quality management code can
// signal immediate rendering by setting the event without setting an advise
// link. If we're subsequently stopped and run the first attempt to setup an
// advise link with the reference clock will find the event still signalled
function TBCBaseRenderer.CancelNotification: HResult;
var
dwAdvisedCookie: DWord;
begin
Assert((FAdvisedCookie = 0) or Assigned(FClock));
dwAdvisedCookie := FAdvisedCookie;
// Have we a live advise link
if (FAdvisedCookie <> 0) then
begin
FClock.Unadvise(FAdvisedCookie);
SignalTimerFired;
Assert(FAdvisedCookie = 0);
end;
// Clear the event and return our status
FRenderEvent.Reset;
if (dwAdvisedCookie <> 0) then
Result := S_OK
else
Result := S_FALSE;
end;
// Responsible for setting up one shot advise links with the clock
// Return FALSE if the sample is to be dropped (not drawn at all)
// Return TRUE if the sample is to be drawn and in this case also
// arrange for m_RenderEvent to be set at the appropriate time
function TBCBaseRenderer.ScheduleSample(MediaSample: IMediaSample): Boolean;
var
StartSample, EndSample: TReferenceTime;
hr: HResult;
begin
// Is someone pulling our leg
if (MediaSample = nil) then
begin
Result := False;
Exit;
end;
// Get the next sample due up for rendering. If there aren't any ready
// then GetNextSampleTimes returns an error. If there is one to be done
// then it succeeds and yields the sample times. If it is due now then
// it returns S_OK other if it's to be done when due it returns S_FALSE
hr := GetSampleTimes(MediaSample, StartSample, EndSample);
if Failed(hr) then
begin
Result := False;
Exit;
end;
// If we don't have a reference clock then we cannot set up the advise
// time so we simply set the event indicating an image to render. This
// will cause us to run flat out without any timing or synchronisation
if (hr = S_OK) then
begin
// ???Assert(SetEvent(FRenderEvent.Handle));
FRenderEvent.SetEv;
Result := True;
Exit;
end;
Assert(FAdvisedCookie = 0);
Assert(Assigned(FClock));
Assert(Wait_Timeout = WaitForSingleObject(FRenderEvent.Handle, 0));
// We do have a valid reference clock interface so we can ask it to
// set an event when the image comes due for rendering. We pass in
// the reference time we were told to start at and also the current
// stream time which is the offset from the start reference time
hr := FClock.AdviseTime(
FStart, // Start run time
StartSample, // Stream time
FRenderEvent.Handle, // Render notification
FAdvisedCookie); // Advise cookie
if Succeeded(hr) then
begin
Result := True;
Exit;
end;
// We could not schedule the next sample for rendering despite the fact
// we have a valid sample here. This is a fair indication that either
// the system clock is wrong or the time stamp for the sample is duff
Assert(FAdvisedCookie = 0);
Result := False;
end;
// This is called when a sample comes due for rendering. We pass the sample
// on to the derived class. After rendering we will initialise the timer for
// the next sample, NOTE signal that the last one fired first, if we don't
// do this it thinks there is still one outstanding that hasn't completed
function TBCBaseRenderer.Render(MediaSample: IMediaSample): HResult;
begin
// If the media sample is NULL then we will have been notified by the
// clock that another sample is ready but in the mean time someone has
// stopped us streaming which causes the next sample to be released
if (MediaSample = nil) then
begin
Result := S_FALSE;
Exit;
end;
// If we have stopped streaming then don't render any more samples, the
// thread that got in and locked us and then reset this flag does not
// clear the pending sample as we can use it to refresh any output device
if Not FIsStreaming then
begin
Result := S_FALSE;
Exit;
end;
// Time how long the rendering takes
OnRenderStart(MediaSample);
DoRenderSample(MediaSample);
OnRenderEnd(MediaSample);
Result := NOERROR;
end;
// Checks if there is a sample waiting at the renderer
function TBCBaseRenderer.HaveCurrentSample: Boolean;
begin
FRendererLock.Lock;
try
Result := (FMediaSample <> nil);
finally
FRendererLock.UnLock;
end;
end;
// Returns the current sample waiting at the video renderer. We AddRef the
// sample before returning so that should it come due for rendering the
// person who called this method will hold the remaining reference count
// that will stop the sample being added back onto the allocator free list
function TBCBaseRenderer.GetCurrentSample: IMediaSample;
begin
FRendererLock.Lock;
try
(* ???
if (m_pMediaSample) {
m_pMediaSample->AddRef();
*)
Result := FMediaSample;
finally
FRendererLock.Unlock;
end;
end;
// Called when the source delivers us a sample. We go through a few checks to
// make sure the sample can be rendered. If we are running (streaming) then we
// have the sample scheduled with the reference clock, if we are not streaming
// then we have received an sample in paused mode so we can complete any state
// transition. On leaving this function everything will be unlocked so an app
// thread may get in and change our state to stopped (for example) in which
// case it will also signal the thread event so that our wait call is stopped
function TBCBaseRenderer.PrepareReceive(MediaSample: IMediaSample): HResult;
var
hr: HResult;
begin
FInterfaceLock.Lock;
try
FInReceive := True;
// Check our flushing and filter state
// This function must hold the interface lock because it calls
// CBaseInputPin::Receive() and CBaseInputPin::Receive() uses
// CBasePin::m_bRunTimeError.
// ??? HRESULT hr = m_pInputPin->CBaseInputPin::Receive(MediaSample);
hr := FInputPin.InheritedReceive(MediaSample);
if (hr <> NOERROR) then
begin
FInReceive := False;
Result := E_FAIL;
Exit;
end;
// Has the type changed on a media sample. We do all rendering
// synchronously on the source thread, which has a side effect
// that only one buffer is ever outstanding. Therefore when we
// have Receive called we can go ahead and change the format
// Since the format change can cause a SendMessage we just don't
// lock
if Assigned(FInputPin.SampleProps.pMediaType) then
begin
hr := FInputPin.SetMediaType(FInputPin.FSampleProps.pMediaType);
if Failed(hr) then
begin
Result := hr;
FInReceive := False;
Exit;
end;
end;
FRendererLock.Lock;
try
Assert(IsActive);
Assert(not FInputPin.IsFlushing);
Assert(FInputPin.IsConnected);
Assert(FMediaSample = nil);
// Return an error if we already have a sample waiting for rendering
// source pins must serialise the Receive calls - we also check that
// no data is being sent after the source signalled an end of stream
if (Assigned(FMediaSample) or FIsEOS or FAbort) then
begin
Ready;
FInReceive := False;
Result := E_UNEXPECTED;
Exit;
end;
// Store the media times from this sample
if Assigned(FPosition) then
FPosition.RegisterMediaTime(MediaSample);
// Schedule the next sample if we are streaming
if (FIsStreaming and (not ScheduleSample(MediaSample))) then
begin
Assert(WAIT_TIMEOUT = WaitForSingleObject(FRenderEvent.Handle, 0));
Assert(CancelNotification = S_FALSE);
FInReceive := False;
Result := VFW_E_SAMPLE_REJECTED;
Exit;
end;
// Store the sample end time for EC_COMPLETE handling
FSignalTime := FInputPin.FSampleProps.tStop;
// BEWARE we sometimes keep the sample even after returning the thread to
// the source filter such as when we go into a stopped state (we keep it
// to refresh the device with) so we must AddRef it to keep it safely. If
// we start flushing the source thread is released and any sample waiting
// will be released otherwise GetBuffer may never return (see BeginFlush)
FMediaSample := MediaSample;
//??? m_pMediaSample->AddRef();
if not FIsStreaming then
SetRepaintStatus(True);
Result := NOERROR;
finally
FRendererLock.Unlock;
end;
finally
FInterfaceLock.UnLock;
end;
end;
// Called by the source filter when we have a sample to render. Under normal
// circumstances we set an advise link with the clock, wait for the time to
// arrive and then render the data using the PURE virtual DoRenderSample that
// the derived class will have overriden. After rendering the sample we may
// also signal EOS if it was the last one sent before EndOfStream was called
function TBCBaseRenderer.Receive(MediaSample: IMediaSample): HResult;
begin
Assert(Assigned(MediaSample));
// It may return VFW_E_SAMPLE_REJECTED code to say don't bother
Result := PrepareReceive(MediaSample);
Assert(FInReceive = Succeeded(Result));
if Failed(Result) then
begin
if (Result = VFW_E_SAMPLE_REJECTED) then
Result := NOERROR;
Exit;
end;
// We realize the palette in "PrepareRender()" so we have to give away the
// filter lock here.
if (FState = State_Paused) then
begin
PrepareRender;
// no need to use InterlockedExchange
FInReceive := False;
// We must hold both these locks
FInterfaceLock.Lock;
try
if (FState = State_Stopped) then
begin
Result := NOERROR;
Exit;
end;
FInReceive := True;
FRendererLock.Lock;
try
OnReceiveFirstSample(MediaSample);
finally
FRendererLock.UnLock;
end;
finally
FInterfaceLock.UnLock;
end;
Ready;
end;
// Having set an advise link with the clock we sit and wait. We may be
// awoken by the clock firing or by a state change. The rendering call
// will lock the critical section and check we can still render the data
Result := WaitForRenderTime;
if Failed(Result) then
begin
FInReceive := False;
Result := NOERROR;
Exit;
end;
PrepareRender;
// Set this here and poll it until we work out the locking correctly
// It can't be right that the streaming stuff grabs the interface
// lock - after all we want to be able to wait for this stuff
// to complete
FInReceive := False;
// We must hold both these locks
FInterfaceLock.Lock;
try
// since we gave away the filter wide lock, the sate of the filter could
// have chnaged to Stopped
if (FState = State_Stopped) then
begin
Result := NOERROR;
Exit;
end;
FRendererLock.Lock;
try
// Deal with this sample
Render(FMediaSample);
ClearPendingSample;
// milenko start (why commented before?)
SendEndOfStream;
// milenko end
CancelNotification;
Result := NOERROR;
finally
FRendererLock.UnLock;
end;
finally
FInterfaceLock.UnLock;
end;
end;
// This is called when we stop or are inactivated to clear the pending sample
// We release the media sample interface so that they can be allocated to the
// source filter again, unless of course we are changing state to inactive in
// which case GetBuffer will return an error. We must also reset the current
// media sample to NULL so that we know we do not currently have an image
function TBCBaseRenderer.ClearPendingSample: HResult;
begin
FRendererLock.Lock;
try
if Assigned(FMediaSample) then
FMediaSample := nil;
Result := NOERROR;
finally
FRendererLock.Unlock;
end;
end;
// Used to signal end of stream according to the sample end time
// Milenko start (use this callback outside of the class and with stdcall;)
procedure EndOfStreamTimer(uID, uMsg: UINT;
dwUser, dw1, dw2: DWord); stdcall;
var
Renderer: TBCBaseRenderer;
begin
Renderer := TBCBaseRenderer(dwUser);
{$IFDEF DEBUG}
//NOTE1("EndOfStreamTimer called (%d)",uID);
DbgLog(Format('EndOfStreamTimer called (%d)', [uID]));
{$ENDIF}
Renderer.TimerCallback;
{
???
CBaseRenderer *pRenderer = (CBaseRenderer * ) dwUser;
pRenderer->TimerCallback();
}
end;
// Milenko end
// Do the timer callback work
procedure TBCBaseRenderer.TimerCallback;
begin
// Lock for synchronization (but don't hold this lock when calling
// timeKillEvent)
FRendererLock.Lock;
try
// See if we should signal end of stream now
if (FEndOfStreamTimer <> 0) then
begin
FEndOfStreamTimer := 0;
// milenko start (why commented before?)
SendEndOfStream;
// milenko end
end;
finally
FRendererLock.Unlock;
end;
end;
// If we are at the end of the stream signal the filter graph but do not set
// the state flag back to FALSE. Once we drop off the end of the stream we
// leave the flag set (until a subsequent ResetEndOfStream). Each sample we
// get delivered will update m_SignalTime to be the last sample's end time.
// We must wait this long before signalling end of stream to the filtergraph
const
TIMEOUT_DELIVERYWAIT = 50;
TIMEOUT_RESOLUTION = 10;
function TBCBaseRenderer.SendEndOfStream: HResult;
var
Signal, CurrentTime: TReferenceTime;
Delay: Longint;
begin
{$IFDEF DEBUG}
Assert(FRendererLock.CritCheckIn);
{$ENDIF}
if ((not FIsEOS) or FIsEOSDelivered or (FEndOfStreamTimer <> 0)) then
begin
Result := NOERROR;
Exit;
end;
// If there is no clock then signal immediately
if (FClock = nil) then
begin
Result := NotifyEndOfStream;
Exit;
end;
// How long into the future is the delivery time
Signal := FStart + FSignalTime;
FClock.GetTime(int64(CurrentTime));
// Milenko Start (important!)
// Delay := (Longint(Signal) - CurrentTime) div 10000;
Delay := LongInt((Signal - CurrentTime) div 10000);
// Milenko end
// Dump the timing information to the debugger
{$IFDEF DEBUG}
DbgLog(Self, Format('Delay until end of stream delivery %d', [Delay]));
// ??? NOTE1("Current %s",(LPCTSTR)CDisp((LONGLONG)CurrentTime));
// ??? NOTE1("Signal %s",(LPCTSTR)CDisp((LONGLONG)Signal));
DbgLog(Self, Format('Current %d', [CurrentTime]));
DbgLog(Self, Format('Signal %d', [Signal]));
{$ENDIF}
// Wait for the delivery time to arrive
if (Delay < TIMEOUT_DELIVERYWAIT) then
begin
Result := NotifyEndOfStream;
Exit;
end;
// Signal a timer callback on another worker thread
FEndOfStreamTimer := CompatibleTimeSetEvent(
Delay, // Period of timer
TIMEOUT_RESOLUTION, // Timer resolution
// ???
// Milenko start (callback is now outside of the class)
@EndOfStreamTimer,// Callback function
// Milenko end
Cardinal(Self), // Used information
TIME_ONESHOT); // Type of callback
if (FEndOfStreamTimer = 0) then
begin
Result := NotifyEndOfStream;
Exit;
end;
Result := NOERROR;
end;
// Signals EC_COMPLETE to the filtergraph manager
function TBCBaseRenderer.NotifyEndOfStream: HResult;
var
Filter: IBaseFilter;
begin
FRendererLock.Lock;
try
Assert(not FIsEOSDelivered);
Assert(FEndOfStreamTimer = 0);
// Has the filter changed state
if not FIsStreaming then
begin
Assert(FEndOfStreamTimer = 0);
Result := NOERROR;
Exit;
end;
// Reset the end of stream timer
FEndOfStreamTimer := 0;
// If we've been using the IMediaPosition interface, set it's start
// and end media "times" to the stop position by hand. This ensures
// that we actually get to the end, even if the MPEG guestimate has
// been bad or if the quality management dropped the last few frames
if Assigned(FPosition) then
FPosition.EOS;
FIsEOSDelivered := True;
{$IFDEF DEBUG}
DbgLog('Sending EC_COMPLETE...');
{$ENDIF}
// ??? return NotifyEvent(EC_COMPLETE,S_OK,(LONG_PTR)(IBaseFilter *)this);
// milenko start (Delphi 5 compatibility)
QueryInterface(IID_IBaseFilter,Filter);
Result := NotifyEvent(EC_COMPLETE, S_OK, Integer(Filter));
Filter := nil;
// milenko end
finally
FRendererLock.UnLock;
end;
end;
// Reset the end of stream flag, this is typically called when we transfer to
// stopped states since that resets the current position back to the start so
// we will receive more samples or another EndOfStream if there aren't any. We
// keep two separate flags one to say we have run off the end of the stream
// (this is the m_bEOS flag) and another to say we have delivered EC_COMPLETE
// to the filter graph. We need the latter otherwise we can end up sending an
// EC_COMPLETE every time the source changes state and calls our EndOfStream
function TBCBaseRenderer.ResetEndOfStream: HResult;
begin
ResetEndOfStreamTimer;
FRendererLock.Lock;
try
FIsEOS := False;
FIsEOSDelivered := False;
FSignalTime := 0;
Result := NOERROR;
finally
FRendererLock.UnLock;
end;
end;
// Kills any outstanding end of stream timer
procedure TBCBaseRenderer.ResetEndOfStreamTimer;
begin
{$IFDEF DEBUG}
Assert(FRendererLock.CritCheckOut);
{$ENDIF}
if (FEndOfStreamTimer <> 0) then
begin
timeKillEvent(FEndOfStreamTimer);
FEndOfStreamTimer := 0;
end;
end;
// This is called when we start running so that we can schedule any pending
// image we have with the clock and display any timing information. If we
// don't have any sample but we have queued an EOS flag then we send it. If
// we do have a sample then we wait until that has been rendered before we
// signal the filter graph otherwise we may change state before it's done
function TBCBaseRenderer.StartStreaming: HResult;
begin
FRendererLock.Lock;
try
if FIsStreaming then
begin
Result := NOERROR;
Exit;
end;
// Reset the streaming times ready for running
FIsStreaming := True;
timeBeginPeriod(1);
OnStartStreaming;
// There should be no outstanding advise
Assert(WAIT_TIMEOUT = WaitForSingleObject(FRenderEvent.Handle, 0));
Assert(CancelNotification = S_FALSE);
// If we have an EOS and no data then deliver it now
if (FMediaSample = nil) then
begin
Result := SendEndOfStream;
Exit;
end;
// Have the data rendered
Assert(Assigned(FMediaSample));
if not ScheduleSample(FMediaSample) then
FRenderEvent.SetEv;
Result := NOERROR;
finally
FRendererLock.UnLock;
end;
end;
// This is called when we stop streaming so that we can set our internal flag
// indicating we are not now to schedule any more samples arriving. The state
// change methods in the filter implementation take care of cancelling any
// clock advise link we have set up and clearing any pending sample we have
function TBCBaseRenderer.StopStreaming: HResult;
begin
FRendererLock.Lock;
try
FIsEOSDelivered := False;
if FIsStreaming then
begin
FIsStreaming := False;
OnStopStreaming;
timeEndPeriod(1);
end;
Result := NOERROR;
finally
FRendererLock.Unlock;
end;
end;
// We have a boolean flag that is reset when we have signalled EC_REPAINT to
// the filter graph. We set this when we receive an image so that should any
// conditions arise again we can send another one. By having a flag we ensure
// we don't flood the filter graph with redundant calls. We do not set the
// event when we receive an EndOfStream call since there is no point in us
// sending further EC_REPAINTs. In particular the AutoShowWindow method and
// the DirectDraw object use this method to control the window repainting
procedure TBCBaseRenderer.SetRepaintStatus(Repaint: Boolean);
begin
FRendererLock.Lock;
try
FRepaintStatus := Repaint;
finally
FRendererLock.Unlock;
end;
end;
// Pass the window handle to the upstream filter
procedure TBCBaseRenderer.SendNotifyWindow(Pin: IPin; Handle: HWND);
var
Sink: IMediaEventSink;
hr: HResult;
begin
// Does the pin support IMediaEventSink
hr := Pin.QueryInterface(IID_IMediaEventSink, Sink);
if Succeeded(hr) then
begin
Sink.Notify(EC_NOTIFY_WINDOW, Handle, 0);
Sink := nil;
end;
NotifyEvent(EC_NOTIFY_WINDOW, Handle, 0);
end;
// Signal an EC_REPAINT to the filter graph. This can be used to have data
// sent to us. For example when a video window is first displayed it may
// not have an image to display, at which point it signals EC_REPAINT. The
// filtergraph will either pause the graph if stopped or if already paused
// it will call put_CurrentPosition of the current position. Setting the
// current position to itself has the stream flushed and the image resent
// ??? #define RLOG(_x_) DbgLog((LOG_TRACE,1,TEXT(_x_)));
procedure TBCBaseRenderer.SendRepaint;
var
Pin: IPin;
begin
FRendererLock.Lock;
try
Assert(Assigned(FInputPin));
// We should not send repaint notifications when...
// - An end of stream has been notified
// - Our input pin is being flushed
// - The input pin is not connected
// - We have aborted a video playback
// - There is a repaint already sent
if (not FAbort) and
(FInputPin.IsConnected) and
(not FInputPin.IsFlushing) and
(not IsEndOfStream) and
FRepaintStatus then
begin
// milenko start (delphi 5 compatibility)
// Pin := FInputPin as IPin;
FInputPin.QueryInterface(IID_IPin,Pin);
NotifyEvent(EC_REPAINT, Integer(Pin), 0);
Pin := nil;
// milenko end
SetRepaintStatus(False);
{$IFDEF DEBUG}
DbgLog('Sending repaint');
{$ENDIF}
end;
finally
FRendererLock.Unlock;
end;
end;
// When a video window detects a display change (WM_DISPLAYCHANGE message) it
// can send an EC_DISPLAY_CHANGED event code along with the renderer pin. The
// filtergraph will stop everyone and reconnect our input pin. As we're then
// reconnected we can accept the media type that matches the new display mode
// since we may no longer be able to draw the current image type efficiently
function TBCBaseRenderer.OnDisplayChange: Boolean;
var
Pin: IPin;
begin
// Ignore if we are not connected yet
FRendererLock.Lock;
try
if not FInputPin.IsConnected then
begin
Result := False;
Exit;
end;
{$IFDEF DEBUG}
DbgLog('Notification of EC_DISPLAY_CHANGE');
{$ENDIF}
// Pass our input pin as parameter on the event
// milenko start (Delphi 5 compatibility)
// Pin := FInputPin as IPin;
FInputPin.QueryInterface(IID_IPin,Pin);
// ??? m_pInputPin->AddRef();
NotifyEvent(EC_DISPLAY_CHANGED, Integer(Pin), 0);
SetAbortSignal(True);
ClearPendingSample;
// FreeAndNil(FInputPin);
Pin := nil;
// milenko end
Result := True;
finally
FRendererLock.Unlock;
end;
end;
// Called just before we start drawing.
// Store the current time in m_trRenderStart to allow the rendering time to be
// logged. Log the time stamp of the sample and how late it is (neg is early)
procedure TBCBaseRenderer.OnRenderStart(MediaSample: IMediaSample);
{$IFDEF PERF}
var
StartTime, EndTime, StreamTime: TReferenceTime;
{$ENDIF}
begin
{$IFDEF PERF}
MediaSample.GetTime(StartTime, EndTime);
MSR_INTEGER(FBaseStamp, Integer(StartTime)); // dump low order 32 bits
FClock.GetTime(pint64(@FRenderStart)^);
MSR_INTEGER(0, Integer(FRenderStart));
StreamTime := FRenderStart - FStart; // convert reftime to stream time
MSR_INTEGER(0, Integer(StreamTime));
MSR_INTEGER(FBaseAccuracy, RefTimeToMiliSec(StreamTime - StartTime)); // dump in mSec
{$ENDIF}
end;
// Called directly after drawing an image.
// calculate the time spent drawing and log it.
procedure TBCBaseRenderer.OnRenderEnd(MediaSample: IMediaSample);
{$IFDEF PERF}
var
NowTime: TReferenceTime;
t: Integer;
{$ENDIF}
begin
{$IFDEF PERF}
FClock.GetTime(int64(NowTime));
MSR_INTEGER(0, Integer(NowTime));
t := RefTimeToMiliSec(NowTime - FRenderStart); // convert UNITS->msec
MSR_INTEGER(FBaseRenderTime, t);
{$ENDIF}
end;
function TBCBaseRenderer.OnStartStreaming: HResult;
begin
Result := NOERROR;
end;
function TBCBaseRenderer.OnStopStreaming: HResult;
begin
Result := NOERROR;
end;
procedure TBCBaseRenderer.OnWaitStart;
begin
end;
procedure TBCBaseRenderer.OnWaitEnd;
begin
end;
procedure TBCBaseRenderer.PrepareRender;
begin
end;
// Constructor must be passed the base renderer object
constructor TBCRendererInputPin.Create(Renderer: TBCBaseRenderer;
out hr: HResult; Name: PWideChar);
begin
inherited Create('Renderer pin', Renderer, Renderer.FInterfaceLock,
hr, Name);
FRenderer := Renderer;
Assert(Assigned(FRenderer));
end;
// Signals end of data stream on the input pin
function TBCRendererInputPin.EndOfStream: HResult;
begin
FRenderer.FInterfaceLock.Lock;
FRenderer.FRendererLock.Lock;
try
// Make sure we're streaming ok
Result := CheckStreaming;
if (Result <> NOERROR) then
Exit;
// Pass it onto the renderer
Result := FRenderer.EndOfStream;
if Succeeded(Result) then
Result := inherited EndOfStream;
finally
FRenderer.FRendererLock.UnLock;
FRenderer.FInterfaceLock.UnLock;
end;
end;
// Signals start of flushing on the input pin - we do the final reset end of
// stream with the renderer lock unlocked but with the interface lock locked
// We must do this because we call timeKillEvent, our timer callback method
// has to take the renderer lock to serialise our state. Therefore holding a
// renderer lock when calling timeKillEvent could cause a deadlock condition
function TBCRendererInputPin.BeginFlush: HResult;
begin
FRenderer.FInterfaceLock.Lock;
try
FRenderer.FRendererLock.Lock;
try
inherited BeginFlush;
FRenderer.BeginFlush;
finally
FRenderer.FRendererLock.UnLock;
end;
Result := FRenderer.ResetEndOfStream;
finally
FRenderer.FInterfaceLock.UnLock;
end;
end;
// Signals end of flushing on the input pin
function TBCRendererInputPin.EndFlush: HResult;
begin
FRenderer.FInterfaceLock.Lock;
FRenderer.FRendererLock.Lock;
try
Result := FRenderer.EndFlush;
if Succeeded(Result) then
Result := inherited EndFlush;
finally
FRenderer.FRendererLock.UnLock;
FRenderer.FInterfaceLock.UnLock;
end;
end;
// Pass the sample straight through to the renderer object
function TBCRendererInputPin.Receive(MediaSample: IMediaSample): HResult;
var
hr: HResult;
begin
hr := FRenderer.Receive(MediaSample);
if Failed(hr) then
begin
// A deadlock could occur if the caller holds the renderer lock and
// attempts to acquire the interface lock.
{$IFDEF DEBUG}
Assert(FRenderer.FRendererLock.CritCheckOut);
{$ENDIF}
// The interface lock must be held when the filter is calling
// IsStopped or IsFlushing. The interface lock must also
// be held because the function uses m_bRunTimeError.
FRenderer.FInterfaceLock.Lock;
try
// We do not report errors which occur while the filter is stopping,
// flushing or if the FAborting flag is set . Errors are expected to
// occur during these operations and the streaming thread correctly
// handles the errors.
if (not IsStopped) and (not IsFlushing) and
(not FRenderer.FAbort) and
(not FRunTimeError) then
begin
// EC_ERRORABORT's first parameter is the error which caused
// the event and its' last parameter is 0. See the Direct
// Show SDK documentation for more information.
FRenderer.NotifyEvent(EC_ERRORABORT, hr, 0);
FRenderer.FRendererLock.Lock;
try
if (FRenderer.IsStreaming and
(not FRenderer.IsEndOfStreamDelivered)) then
FRenderer.NotifyEndOfStream;
finally
FRenderer.FRendererLock.UnLock;
end;
FRunTimeError := True;
end;
finally
FRenderer.FInterfaceLock.UnLock;
end;
end;
Result := hr;
end;
function TBCRendererInputPin.InheritedReceive(MediaSample: IMediaSample): HResult;
begin
Result := Inherited Receive(MediaSample);
end;
// Called when the input pin is disconnected
function TBCRendererInputPin.BreakConnect: HResult;
begin
Result := FRenderer.BreakConnect;
if Succeeded(Result) then
Result := inherited BreakConnect;
end;
// Called when the input pin is connected
function TBCRendererInputPin.CompleteConnect(ReceivePin: IPin): HResult;
begin
Result := FRenderer.CompleteConnect(ReceivePin);
if Succeeded(Result) then
Result := inherited CompleteConnect(ReceivePin);
end;
// Give the pin id of our one and only pin
function TBCRendererInputPin.QueryId(out Id: PWideChar): HRESULT;
begin
// milenko start (AMGetWideString bugged before, so this call only will do fine now)
Result := AMGetWideString('In', Id);
// milenko end
end;
// Will the filter accept this media type
function TBCRendererInputPin.CheckMediaType(MediaType: PAMMediaType): HResult;
begin
Result := FRenderer.CheckMediaType(MediaType);
end;
// Called when we go paused or running
function TBCRendererInputPin.Active: HResult;
begin
Result := FRenderer.Active;
end;
// Called when we go into a stopped state
function TBCRendererInputPin.Inactive: HResult;
begin
// The caller must hold the interface lock because
// this function uses FRunTimeError.
{$IFDEF DEBUG}
Assert(FRenderer.FInterfaceLock.CritCheckIn);
{$ENDIF}
FRunTimeError := False;
Result := FRenderer.Inactive;
end;
// Tell derived classes about the media type agreed
function TBCRendererInputPin.SetMediaType(MediaType: PAMMediaType): HResult;
begin
Result := inherited SetMediaType(MediaType);
if Succeeded(Result) then
Result := FRenderer.SetMediaType(MediaType);
end;
// We do not keep an event object to use when setting up a timer link with
// the clock but are given a pointer to one by the owning object through the
// SetNotificationObject method - this must be initialised before starting
// We can override the default quality management process to have it always
// draw late frames, this is currently done by having the following registry
// key (actually an INI key) called DrawLateFrames set to 1 (default is 0)
(* ???
const TCHAR AMQUALITY[] = TEXT("ActiveMovie");
const TCHAR DRAWLATEFRAMES[] = TEXT("DrawLateFrames");
*)
resourcestring
AMQUALITY = 'ActiveMovie';
DRAWLATEFRAMES = 'DrawLateFrames';
constructor TBCBaseVideoRenderer.Create(RenderClass: TGUID; Name: PChar;
Unk: IUnknown; hr: HResult);
begin
// milenko start (not sure if this is really needed, but looks better)
// inherited;
inherited Create(RenderClass,Name,Unk,hr);
// milenko end
FFramesDropped := 0;
FFramesDrawn := 0;
FSupplierHandlingQuality:= False;
ResetStreamingTimes;
{$IFDEF PERF}
FTimeStamp := MSR_REGISTER('Frame time stamp');
FEarliness := MSR_REGISTER('Earliness fudge');
FTarget := MSR_REGISTER('Target(mSec)');
FSchLateTime := MSR_REGISTER('mSec late when scheduled');
FDecision := MSR_REGISTER('Scheduler decision code');
FQualityRate := MSR_REGISTER('Quality rate sent');
FQualityTime := MSR_REGISTER('Quality time sent');
FWaitReal := MSR_REGISTER('Render wait');
FWait := MSR_REGISTER('wait time recorded (msec)');
FFrameAccuracy := MSR_REGISTER('Frame accuracy(msecs)');
FDrawLateFrames := Boolean(GetProfileInt(PChar(AMQUALITY),
PChar(DRAWLATEFRAMES), Integer(False)));
FSendQuality := MSR_REGISTER('Processing Quality message');
FRenderAvg := MSR_REGISTER('Render draw time Avg');
FFrameAvg := MSR_REGISTER('FrameAvg');
FWaitAvg := MSR_REGISTER('WaitAvg');
FDuration := MSR_REGISTER('Duration');
FThrottle := MSR_REGISTER('Audio - video throttle wait');
FDebug := MSR_REGISTER('Debug stuff');
{$ENDIF}
end;
// Destructor is just a placeholder
destructor TBCBaseVideoRenderer.Destroy;
begin
Assert(FAdvisedCookie = 0);
// ??? seems should leave it, but...
// milenko start (not really needed...)
// inherited;
inherited Destroy;
// milenko end
end;
// The timing functions in this class are called by the window object and by
// the renderer's allocator.
// The windows object calls timing functions as it receives media sample
// images for drawing using GDI.
// The allocator calls timing functions when it starts passing DCI/DirectDraw
// surfaces which are not rendered in the same way; The decompressor writes
// directly to the surface with no separate rendering, so those code paths
// call direct into us. Since we only ever hand out DCI/DirectDraw surfaces
// when we have allocated one and only one image we know there cannot be any
// conflict between the two.
//
// We use timeGetTime to return the timing counts we use (since it's relative
// performance we are interested in rather than absolute compared to a clock)
// The window object sets the accuracy of the system clock (normally 1ms) by
// calling timeBeginPeriod/timeEndPeriod when it changes streaming states
// Reset all times controlling streaming.
// Set them so that
// 1. Frames will not initially be dropped
// 2. The first frame will definitely be drawn (achieved by saying that there
// has not ben a frame drawn for a long time).
function TBCBaseVideoRenderer.ResetStreamingTimes: HResult;
begin
FLastDraw := -1000; // set up as first frame since ages (1 sec) ago
FStreamingStart := timeGetTime;
FRenderAvg := 0;
FFrameAvg := -1; // -1000 fps :=:= "unset"
FDuration := 0; // 0 - strange value
FRenderLast := 0;
FWaitAvg := 0;
FRenderStart := 0;
FFramesDrawn := 0;
FFramesDropped := 0;
FTotAcc := 0;
FSumSqAcc := 0;
FSumSqFrameTime := 0;
FFrame := 0; // hygiene - not really needed
FLate := 0; // hygiene - not really needed
FSumFrameTime := 0;
FNormal := 0;
FEarliness := 0;
FTarget := -300000; // 30mSec early
FThrottle := 0;
FRememberStampForPerf := 0;
{$IFDEF PERF}
FRememberFrameForPerf := 0;
{$ENDIF}
Result := NOERROR;
end;
// Reset all times controlling streaming. Note that we're now streaming. We
// don't need to set the rendering event to have the source filter released
// as it is done during the Run processing. When we are run we immediately
// release the source filter thread and draw any image waiting (that image
// may already have been drawn once as a poster frame while we were paused)
function TBCBaseVideoRenderer.OnStartStreaming: HResult;
begin
ResetStreamingTimes;
Result := NOERROR;
end;
// Called at end of streaming. Fixes times for property page report
function TBCBaseVideoRenderer.OnStopStreaming: HResult;
begin
// milenko start (better to use int64 instead of integer)
// FStreamingStart := Integer(timeGetTime) - FStreamingStart;
FStreamingStart := Int64(timeGetTime) - FStreamingStart;
// milenko end
Result := NOERROR;
end;
// Called when we start waiting for a rendering event.
// Used to update times spent waiting and not waiting.
procedure TBCBaseVideoRenderer.OnWaitStart;
begin
{$IFDEF PERF}
MSR_START(FWaitReal);
{$ENDIF}
end;
// Called when we are awoken from the wait in the window OR by our allocator
// when it is hanging around until the next sample is due for rendering on a
// DCI/DirectDraw surface. We add the wait time into our rolling average.
// We grab the interface lock so that we're serialised with the application
// thread going through the run code - which in due course ends up calling
// ResetStreaming times - possibly as we run through this section of code
procedure TBCBaseVideoRenderer.OnWaitEnd;
{$IFDEF PERF}
var
RealStream, RefTime: TReferenceTime;
// the real time now expressed as stream time.
Late, Frame: Integer;
{$ENDIF}
begin
{$IFDEF PERF}
MSR_STOP(FWaitReal);
// for a perf build we want to know just exactly how late we REALLY are.
// even if this means that we have to look at the clock again.
{$IFDEF 0}
FClock.GetTime(RealStream); // Calling clock here causes W95 deadlock!
{$ELSE}
// We will be discarding overflows like mad here!
// This is wrong really because timeGetTime() can wrap but it's
// only for PERF
RefTime := timeGetTime * 10000;
RealStream := RefTime + FTimeOffset;
{$ENDIF}
Dec(RealStream, FStart); // convert to stream time (this is a reftime)
if (FRememberStampForPerf = 0) then
// This is probably the poster frame at the start, and it is not scheduled
// in the usual way at all. Just count it. The rememberstamp gets set
// in ShouldDrawSampleNow, so this does invalid frame recording until we
// actually start playing.
PreparePerformanceData(0, 0)
else
begin
Late := RealStream - FRememberStampForPerf;
Frame := RefTime - FRememberFrameForPerf;
PreparePerformanceData(Late, Frame);
end;
FRememberFrameForPerf := RefTime;
{$ENDIF}
end;
// Put data on one side that describes the lateness of the current frame.
// We don't yet know whether it will actually be drawn. In direct draw mode,
// this decision is up to the filter upstream, and it could change its mind.
// The rules say that if it did draw it must call Receive(). One way or
// another we eventually get into either OnRenderStart or OnDirectRender and
// these both call RecordFrameLateness to update the statistics.
procedure TBCBaseVideoRenderer.PreparePerformanceData(Late, Frame: Integer);
begin
FLate := Late;
FFrame := Frame;
end;
// update the statistics:
// m_iTotAcc, m_iSumSqAcc, m_iSumSqFrameTime, m_iSumFrameTime, m_cFramesDrawn
// Note that because the properties page reports using these variables,
// 1. We need to be inside a critical section
// 2. They must all be updated together. Updating the sums here and the count
// elsewhere can result in imaginary jitter (i.e. attempts to find square roots
// of negative numbers) in the property page code.
procedure TBCBaseVideoRenderer.RecordFrameLateness(Late, Frame: Integer);
var
_Late, _Frame: Integer;
begin
// Record how timely we are.
_Late := Late div 10000;
// Best estimate of moment of appearing on the screen is average of
// start and end draw times. Here we have only the end time. This may
// tend to show us as spuriously late by up to 1/2 frame rate achieved.
// Decoder probably monitors draw time. We don't bother.
{$IFDEF PERF}
MSR_INTEGER(FFrameAccuracy, _Late);
{$ENDIF}
// This is a kludge - we can get frames that are very late
// especially (at start-up) and they invalidate the statistics.
// So ignore things that are more than 1 sec off.
if (_Late > 1000) or (_Late < -1000) then
if (FFramesDrawn <= 1) then
_Late := 0
else if (_Late > 0) then
_Late := 1000
else
_Late := -1000;
// The very first frame often has a invalid time, so don't
// count it into the statistics. (???)
if (FFramesDrawn > 1) then
begin
Inc(FTotAcc, _Late);
Inc(FSumSqAcc, _Late * _Late);
end;
// calculate inter-frame time. Doesn't make sense for first frame
// second frame suffers from invalid first frame stamp.
if (FFramesDrawn > 2) then
begin
_Frame := Frame div 10000; // convert to mSec else it overflows
// This is a kludge. It can overflow anyway (a pause can cause
// a very long inter-frame time) and it overflows at 2**31/10**7
// or about 215 seconds i.e. 3min 35sec
if (_Frame > 1000) or (_Frame < 0) then
_Frame := 1000;
Inc(FSumSqFrameTime, _Frame * _Frame);
Assert(FSumSqFrameTime >= 0);
Inc(FSumFrameTime, _Frame);
end;
Inc(FFramesDrawn);
end;
procedure TBCBaseVideoRenderer.ThrottleWait;
var
Throttle: Integer;
begin
if (FThrottle > 0) then
begin
Throttle := FThrottle div 10000; // convert to mSec
MSR_INTEGER(FThrottle, Throttle);
{$IFDEF DEBUG}
DbgLog(Self, Format('Throttle %d ms', [Throttle]));
{$ENDIF}
Sleep(Throttle);
end
else
Sleep(0);
end;
// Whenever a frame is rendered it goes though either OnRenderStart
// or OnDirectRender. Data that are generated during ShouldDrawSample
// are added to the statistics by calling RecordFrameLateness from both
// these two places.
// Called in place of OnRenderStart..OnRenderEnd
// When a DirectDraw image is drawn
procedure TBCBaseVideoRenderer.OnDirectRender(MediaSample: IMediaSample);
begin
FRenderAvg := 0;
FRenderLast := 5000000; // If we mode switch, we do NOT want this
// to inhibit the new average getting going!
// so we set it to half a second
// MSR_INTEGER(m_idRenderAvg, m_trRenderAvg div 10000);
RecordFrameLateness(FLate, FFrame);
ThrottleWait;
end;
// Called just before we start drawing. All we do is to get the current clock
// time (from the system) and return. We have to store the start render time
// in a member variable because it isn't used until we complete the drawing
// The rest is just performance logging.
procedure TBCBaseVideoRenderer.OnRenderStart(MediaSample: IMediaSample);
begin
RecordFrameLateness(FLate, FFrame);
FRenderStart := timeGetTime;
end;
// Called directly after drawing an image. We calculate the time spent in the
// drawing code and if this doesn't appear to have any odd looking spikes in
// it then we add it to the current average draw time. Measurement spikes may
// occur if the drawing thread is interrupted and switched to somewhere else.
procedure TBCBaseVideoRenderer.OnRenderEnd(MediaSample: IMediaSample);
var
RefTime: Integer;
begin
// The renderer time can vary erratically if we are interrupted so we do
// some smoothing to help get more sensible figures out but even that is
// not enough as figures can go 9,10,9,9,83,9 and we must disregard 83
// milenko start
// RefTime := (Integer(timeGetTime) - FRenderStart) * 10000;
RefTime := (Int64(timeGetTime) - FRenderStart) * 10000;
// milenko end
// convert mSec->UNITS
if (RefTime < FRenderAvg * 2) or (RefTime < 2 * FRenderLast) then
// DO_MOVING_AVG(m_trRenderAvg, tr);
FRenderAvg := (RefTime + (AVGPERIOD - 1) * FRenderAvg) div AVGPERIOD;
FRenderLast := RefTime;
ThrottleWait;
end;
function TBCBaseVideoRenderer.SetSink(QualityControl: IQualityControl): HResult;
begin
FQSink := QualityControl;
Result := NOERROR;
end;
function TBCBaseVideoRenderer.Notify(Filter: IBaseFilter;
Q: TQuality): HResult;
begin
// NOTE: We are NOT getting any locks here. We could be called
// asynchronously and possibly even on a time critical thread of
// someone else's - so we do the minumum. We only set one state
// variable (an integer) and if that happens to be in the middle
// of another thread reading it they will just get either the new
// or the old value. Locking would achieve no more than this.
// It might be nice to check that we are being called from m_pGraph, but
// it turns out to be a millisecond or so per throw!
// This is heuristics, these numbers are aimed at being "what works"
// rather than anything based on some theory.
// We use a hyperbola because it's easy to calculate and it includes
// a panic button asymptote (which we push off just to the left)
// The throttling fits the following table (roughly)
// Proportion Throttle (msec)
// >=1000 0
// 900 3
// 800 7
// 700 11
// 600 17
// 500 25
// 400 35
// 300 50
// 200 72
// 125 100
// 100 112
// 50 146
// 0 200
// (some evidence that we could go for a sharper kink - e.g. no throttling
// until below the 750 mark - might give fractionally more frames on a
// P60-ish machine). The easy way to get these coefficients is to use
// Renbase.xls follow the instructions therein using excel solver.
if (q.Proportion >= 1000) then
FThrottle := 0
else
// The DWORD is to make quite sure I get unsigned arithmetic
// as the constant is between 2**31 and 2**32
FThrottle := -330000 + (388880000 div (q.Proportion + 167));
Result := NOERROR;
end;
// Send a message to indicate what our supplier should do about quality.
// Theory:
// What a supplier wants to know is "is the frame I'm working on NOW
// going to be late?".
// F1 is the frame at the supplier (as above)
// Tf1 is the due time for F1
// T1 is the time at that point (NOW!)
// Tr1 is the time that f1 WILL actually be rendered
// L1 is the latency of the graph for frame F1 = Tr1-T1
// D1 (for delay) is how late F1 will be beyond its due time i.e.
// D1 = (Tr1-Tf1) which is what the supplier really wants to know.
// Unfortunately Tr1 is in the future and is unknown, so is L1
//
// We could estimate L1 by its value for a previous frame,
// L0 = Tr0-T0 and work off
// D1' = ((T1+L0)-Tf1) = (T1 + (Tr0-T0) -Tf1)
// Rearranging terms:
// D1' = (T1-T0) + (Tr0-Tf1)
// adding (Tf0-Tf0) and rearranging again:
// = (T1-T0) + (Tr0-Tf0) + (Tf0-Tf1)
// = (T1-T0) - (Tf1-Tf0) + (Tr0-Tf0)
// But (Tr0-Tf0) is just D0 - how late frame zero was, and this is the
// Late field in the quality message that we send.
// The other two terms just state what correction should be applied before
// using the lateness of F0 to predict the lateness of F1.
// (T1-T0) says how much time has actually passed (we have lost this much)
// (Tf1-Tf0) says how much time should have passed if we were keeping pace
// (we have gained this much).
//
// Suppliers should therefore work off:
// Quality.Late + (T1-T0) - (Tf1-Tf0)
// and see if this is "acceptably late" or even early (i.e. negative).
// They get T1 and T0 by polling the clock, they get Tf1 and Tf0 from
// the time stamps in the frames. They get Quality.Late from us.
//
function TBCBaseVideoRenderer.SendQuality(Late,
RealStream: TReferenceTime): HResult;
var
q: TQuality;
hr: HResult;
QC: IQualityControl;
OutputPin: IPin;
begin
// If we are the main user of time, then report this as Flood/Dry.
// If our suppliers are, then report it as Famine/Glut.
//
// We need to take action, but avoid hunting. Hunting is caused by
// 1. Taking too much action too soon and overshooting
// 2. Taking too long to react (so averaging can CAUSE hunting).
//
// The reason why we use trLate as well as Wait is to reduce hunting;
// if the wait time is coming down and about to go into the red, we do
// NOT want to rely on some average which is only telling is that it used
// to be OK once.
q.TimeStamp := RealStream;
if (FFrameAvg < 0) then
q.Typ := Famine // guess
// Is the greater part of the time taken bltting or something else
else if (FFrameAvg > 2 * FRenderAvg) then
q.Typ := Famine // mainly other
else
q.Typ := Flood; // mainly bltting
q.Proportion := 1000; // default
if (FFrameAvg < 0) then
// leave it alone - we don't know enough
else if (Late > 0) then
begin
// try to catch up over the next second
// We could be Really, REALLY late, but rendering all the frames
// anyway, just because it's so cheap.
q.Proportion := 1000 - (Late div (UNITS div 1000));
if (q.Proportion < 500) then
q.Proportion := 500; // don't go daft. (could've been negative!)
end
// milenko start
else if (FWaitAvg > 20000) and (Late < -20000) then
begin
// if (FWaitAvg > 20000) and (Late < -20000) then
// Go cautiously faster - aim at 2mSec wait.
if (FWaitAvg >= FFrameAvg) then
begin
// This can happen because of some fudges.
// The waitAvg is how long we originally planned to wait
// The frameAvg is more honest.
// It means that we are spending a LOT of time waiting
q.Proportion := 2000 // double.
end else
begin
if (FFrameAvg + 20000 > FWaitAvg) then
q.Proportion := 1000 * (FFrameAvg div (FFrameAvg + 20000 - FWaitAvg))
else
// We're apparently spending more than the whole frame time waiting.
// Assume that the averages are slightly out of kilter, but that we
// are indeed doing a lot of waiting. (This leg probably never
// happens, but the code avoids any potential divide by zero).
q.Proportion := 2000;
end;
if (q.Proportion > 2000) then
q.Proportion := 2000; // don't go crazy.
end;
// milenko end
// Tell the supplier how late frames are when they get rendered
// That's how late we are now.
// If we are in directdraw mode then the guy upstream can see the drawing
// times and we'll just report on the start time. He can figure out any
// offset to apply. If we are in DIB Section mode then we will apply an
// extra offset which is half of our drawing time. This is usually small
// but can sometimes be the dominant effect. For this we will use the
// average drawing time rather than the last frame. If the last frame took
// a long time to draw and made us late, that's already in the lateness
// figure. We should not add it in again unless we expect the next frame
// to be the same. We don't, we expect the average to be a better shot.
// In direct draw mode the RenderAvg will be zero.
q.Late := Late + FRenderAvg div 2;
{$IFDEF PERF}
// log what we're doing
MSR_INTEGER(FQualityRate, q.Proportion);
MSR_INTEGER(FQualityTime, refTimeToMiliSec(q.Late));
{$ENDIF}
// A specific sink interface may be set through IPin
if (FQSink = nil) then
begin
// Get our input pin's peer. We send quality management messages
// to any nominated receiver of these things (set in the IPin
// interface), or else to our source filter.
QC := nil;
OutputPin := FInputPin.GetConnected;
Assert(Assigned(OutputPin));
// And get an AddRef'd quality control interface
hr := OutputPin.QueryInterface(IID_IQualityControl, QC);
if Succeeded(hr) then
FQSink := QC;
end;
if Assigned(FQSink) then
Result := FQSink.Notify(Self, q)
else
Result := S_FALSE;
end;
// We are called with a valid IMediaSample image to decide whether this is to
// be drawn or not. There must be a reference clock in operation.
// Return S_OK if it is to be drawn Now (as soon as possible)
// Return S_FALSE if it is to be drawn when it's due
// Return an error if we want to drop it
// m_nNormal=-1 indicates that we dropped the previous frame and so this
// one should be drawn early. Respect it and update it.
// Use current stream time plus a number of heuristics (detailed below)
// to make the decision
(* ??? StartTime is changing inside routine:
Inc(StartTime, E); // N.B. earliness is negative
So, maybe it should be declared as var or out?
*)
function TBCBaseVideoRenderer.ShouldDrawSampleNow(MediaSample: IMediaSample;
StartTime: TReferenceTime; out EndTime: TReferenceTime): HResult;
var
RealStream: TReferenceTime; // the real time now expressed as stream time.
RefTime: TReferenceTime;
TrueLate, Late, Duration, t, WaitAvg, L, Frame, E, Delay
{$IFNDEF PERF} , Accuracy{$ENDIF}: Integer;
hr: HResult;
JustDroppedFrame, Res, PlayASAP: Boolean;
begin
// Don't call us unless there's a clock interface to synchronise with
Assert(Assigned(FClock));
{$IFDEF PERF}
MSR_INTEGER(FTimeStamp, Integer(StartTime shr 32)); // high order 32 bits
MSR_INTEGER(FTimeStamp, Integer(StartTime)); // low order 32 bits
{$ENDIF}
// We lose a bit of time depending on the monitor type waiting for the next
// screen refresh. On average this might be about 8mSec - so it will be
// later than we think when the picture appears. To compensate a bit
// we bias the media samples by -8mSec i.e. 80000 UNITs.
// We don't ever make a stream time negative (call it paranoia)
if (StartTime >= 80000) then
begin
Dec(StartTime, 80000);
Dec(EndTime, 80000); // bias stop to to retain valid frame duration
end;
// Cache the time stamp now. We will want to compare what we did with what
// we started with (after making the monitor allowance).
FRememberStampForPerf := StartTime;
// Get reference times (current and late)
FClock.GetTime(int64(RealStream));
{$IFDEF PERF}
// While the reference clock is expensive:
// Remember the offset from timeGetTime and use that.
// This overflows all over the place, but when we subtract to get
// differences the overflows all cancel out.
FTimeOffset := RealStream - timeGetTime * 10000;
{$ENDIF}
Dec(RealStream, FStart); // convert to stream time (this is a reftime)
// We have to wory about two versions of "lateness". The truth, which we
// try to work out here and the one measured against m_trTarget which
// includes long term feedback. We report statistics against the truth
// but for operational decisions we work to the target.
// We use TimeDiff to make sure we get an integer because we
// may actually be late (or more likely early if there is a big time
// gap) by a very long time.
TrueLate := TimeDiff(RealStream - StartTime);
Late := TrueLate;
{$IFDEF PERF}
MSR_INTEGER(FSchLateTime, refTimeToMiliSec(TrueLate));
{$ENDIF}
// Send quality control messages upstream, measured against target
hr := SendQuality(Late, RealStream);
// Note: the filter upstream is allowed to this FAIL meaning "you do it".
FSupplierHandlingQuality := (hr = S_OK);
// Decision time! Do we drop, draw when ready or draw immediately?
Duration := EndTime - StartTime;
// We need to see if the frame rate of the file has just changed.
// This would make comparing our previous frame rate with the current
// frame rate inefficent. Hang on a moment though. I've seen files
// where the frames vary between 33 and 34 mSec so as to average
// 30fps. A minor variation like that won't hurt us.
t := FDuration div 32;
if (Duration > FDuration + t) or (Duration < FDuration - t) then
begin
// There's a major variation. Reset the average frame rate to
// exactly the current rate to disable decision 9002 for this frame,
// and remember the new rate.
FFrameAvg := Duration;
FDuration := Duration;
end;
{$IFDEF PERF}
MSR_INTEGER(FEarliness, refTimeToMiliSec(FEarliness));
MSR_INTEGER(FRenderAvg, refTimeToMiliSec(FRenderAvg));
MSR_INTEGER(FFrameAvg, refTimeToMiliSec(FFrameAvg));
MSR_INTEGER(FWaitAvg, refTimeToMiliSec(FWaitAvg));
MSR_INTEGER(FDuration, refTimeToMiliSec(FDuration));
if (S_OK = MediaSample.IsDiscontinuity) then
MSR_INTEGER(FDecision, 9000);
{$ENDIF}
// Control the graceful slide back from slow to fast machine mode.
// After a frame drop accept an early frame and set the earliness to here
// If this frame is already later than the earliness then slide it to here
// otherwise do the standard slide (reduce by about 12% per frame).
// Note: earliness is normally NEGATIVE
JustDroppedFrame :=
(FSupplierHandlingQuality and
// Can't use the pin sample properties because we might
// not be in Receive when we call this
(S_OK = MediaSample.IsDiscontinuity) // he just dropped one
) or
(FNormal = -1); // we just dropped one
// Set m_trEarliness (slide back from slow to fast machine mode)
if (Late > 0) then
FEarliness := 0 // we are no longer in fast machine mode at all!
else if ((Late >= FEarliness) or JustDroppedFrame) then
FEarliness := Late // Things have slipped of their own accord
else
FEarliness := FEarliness - FEarliness div 8; // graceful slide
// prepare the new wait average - but don't pollute the old one until
// we have finished with it.
// We never mix in a negative wait. This causes us to believe in fast machines
// slightly more.
if (Late < 0) then
L := -Late
else
L := 0;
WaitAvg := (L + FWaitAvg * (AVGPERIOD - 1)) div AVGPERIOD;
RefTime := RealStream - FLastDraw; // Cd be large - 4 min pause!
if (RefTime > 10000000) then
RefTime := 10000000; // 1 second - arbitrarily.
Frame := RefTime;
if FSupplierHandlingQuality then
Res := (Late <= Duration * 4)
else
Res := (Late + Late < Duration);
// We will DRAW this frame IF...
if (
// ...the time we are spending drawing is a small fraction of the total
// observed inter-frame time so that dropping it won't help much.
(3 * FRenderAvg <= FFrameAvg)
// ...or our supplier is NOT handling things and the next frame would
// be less timely than this one or our supplier CLAIMS to be handling
// things, and is now less than a full FOUR frames late.
or Res
// ...or we are on average waiting for over eight milliseconds then
// this may be just a glitch. Draw it and we'll hope to catch up.
or (FWaitAvg > 80000)
// ...or we haven't drawn an image for over a second. We will update
// the display, which stops the video looking hung.
// Do this regardless of how late this media sample is.
or ((RealStream - FLastDraw) > UNITS)
) then
begin
// We are going to play this frame. We may want to play it early.
// We will play it early if we think we are in slow machine mode.
// If we think we are NOT in slow machine mode, we will still play
// it early by m_trEarliness as this controls the graceful slide back.
// and in addition we aim at being m_trTarget late rather than "on time".
PlayASAP := False;
// we will play it AT ONCE (slow machine mode) if...
// ...we are playing catch-up
if (JustDroppedFrame) then
begin
PlayASAP := True;
{$IFDEF PERF}
MSR_INTEGER(FDecision, 9001);
{$ENDIF}
end
// ...or if we are running below the true frame rate
// exact comparisons are glitchy, for these measurements,
// so add an extra 5% or so
else if (FFrameAvg > Duration + Duration div 16)
// It's possible to get into a state where we are losing ground, but
// are a very long way ahead. To avoid this or recover from it
// we refuse to play early by more than 10 frames.
and (Late > -Duration * 10) then
begin
PlayASAP := True;
{$IFDEF PERF}
MSR_INTEGER(FDecision, 9002);
{$ENDIF}
end
{$IFDEF 0}
// ...or if we have been late and are less than one frame early
else if ((Late + Duration > 0) and
(FWaitAvg <= 20000) then
begin
PlayASAP := True;
{$IFDEF PERF}
MSR_INTEGER(m_idDecision, 9003);
{$ENDIF}
end
{$ENDIF}
;
// We will NOT play it at once if we are grossly early. On very slow frame
// rate movies - e.g. clock.avi - it is not a good idea to leap ahead just
// because we got starved (for instance by the net) and dropped one frame
// some time or other. If we are more than 900mSec early, then wait.
if (Late < -9000000) then
PlayASAP := False;
if PlayASAP then
begin
FNormal := 0;
{$IFDEF PERF}
MSR_INTEGER(FDecision, 0);
{$ENDIF}
// When we are here, we are in slow-machine mode. trLate may well
// oscillate between negative and positive when the supplier is
// dropping frames to keep sync. We should not let that mislead
// us into thinking that we have as much as zero spare time!
// We just update with a zero wait.
FWaitAvg := (FWaitAvg * (AVGPERIOD - 1)) div AVGPERIOD;
// Assume that we draw it immediately. Update inter-frame stats
FFrameAvg := (Frame + FFrameAvg * (AVGPERIOD - 1)) div AVGPERIOD;
{$IFNDEF PERF}
// If this is NOT a perf build, then report what we know so far
// without looking at the clock any more. This assumes that we
// actually wait for exactly the time we hope to. It also reports
// how close we get to the manipulated time stamps that we now have
// rather than the ones we originally started with. It will
// therefore be a little optimistic. However it's fast.
PreparePerformanceData(TrueLate, Frame);
{$ENDIF}
FLastDraw := RealStream;
if (FEarliness > Late) then
FEarliness := Late; // if we are actually early, this is neg
Result := S_OK; // Draw it now
end
else
begin
Inc(FNormal);
// Set the average frame rate to EXACTLY the ideal rate.
// If we are exiting slow-machine mode then we will have caught up
// and be running ahead, so as we slide back to exact timing we will
// have a longer than usual gap at this point. If we record this
// real gap then we'll think that we're running slow and go back
// into slow-machine mode and vever get it straight.
FFrameAvg := Duration;
{$IFDEF PERF}
MSR_INTEGER(FDecision, 1);
{$ENDIF}
// Play it early by m_trEarliness and by m_trTarget
E := FEarliness;
if (E < -FFrameAvg) then
E := -FFrameAvg;
Inc(StartTime, E); // N.B. earliness is negative
Delay := -TrueLate;
if (Delay <= 0) then
Result := S_OK
else
Result := S_FALSE; // OK = draw now, FALSE = wait
FWaitAvg := WaitAvg;
// Predict when it will actually be drawn and update frame stats
if (Result = S_FALSE) then // We are going to wait
begin
{$IFNDEF PERF}
Frame := TimeDiff(StartTime - FLastDraw);
{$ENDIF}
FLastDraw := StartTime;
end
else
// trFrame is already = trRealStream-m_trLastDraw;
FLastDraw := RealStream;
{$IFNDEF PERF}
if (Delay > 0) then
// Report lateness based on when we intend to play it
Accuracy := TimeDiff(StartTime - FRememberStampForPerf)
else
// Report lateness based on playing it *now*.
Accuracy := TrueLate; // trRealStream-RememberStampForPerf;
PreparePerformanceData(Accuracy, Frame);
{$ENDIF}
end;
Exit;
end;
// We are going to drop this frame!
// Of course in DirectDraw mode the guy upstream may draw it anyway.
// This will probably give a large negative wack to the wait avg.
FWaitAvg := WaitAvg;
{$IFDEF PERF}
// Respect registry setting - debug only!
if (FDrawLateFrames) then
begin
Result := S_OK; // draw it when it's ready
// even though it's late.
Exit;
end;
{$ENDIF}
// We are going to drop this frame so draw the next one early
// n.b. if the supplier is doing direct draw then he may draw it anyway
// but he's doing something funny to arrive here in that case.
{$IFDEF PERF}
MSR_INTEGER(FDecision, 2);
{$ENDIF}
FNormal := -1;
Result := E_FAIL; // drop it
end;
// NOTE we're called by both the window thread and the source filter thread
// so we have to be protected by a critical section (locked before called)
// Also, when the window thread gets signalled to render an image, it always
// does so regardless of how late it is. All the degradation is done when we
// are scheduling the next sample to be drawn. Hence when we start an advise
// link to draw a sample, that sample's time will always become the last one
// drawn - unless of course we stop streaming in which case we cancel links
function TBCBaseVideoRenderer.ScheduleSample(MediaSample: IMediaSample):
Boolean;
begin
// We override ShouldDrawSampleNow to add quality management
Result := inherited ScheduleSample(MediaSample);
if not Result then
Inc(FFramesDropped);
// m_cFramesDrawn must NOT be updated here. It has to be updated
// in RecordFrameLateness at the same time as the other statistics.
end;
// Implementation of IQualProp interface needed to support the property page
// This is how the property page gets the data out of the scheduler. We are
// passed into the constructor the owning object in the COM sense, this will
// either be the video renderer or an external IUnknown if we're aggregated.
// We initialise our CUnknown base class with this interface pointer. Then
// all we have to do is to override NonDelegatingQueryInterface to expose
// our IQualProp interface. The AddRef and Release are handled automatically
// by the base class and will be passed on to the appropriate outer object
function TBCBaseVideoRenderer.get_FramesDroppedInRenderer(var FramesDropped:
Integer): HResult;
begin
// milenko start
if not Assigned(@FramesDropped) then
begin
Result := E_POINTER;
Exit;
end;
// milenko end
FInterfaceLock.Lock;
try
FramesDropped := FFramesDropped;
Result := NOERROR;
finally
FInterfaceLock.UnLock;
end;
end;
// Set *pcFramesDrawn to the number of frames drawn since
// streaming started.
function TBCBaseVideoRenderer.get_FramesDrawn(out FramesDrawn: Integer):
HResult;
begin
// milenko start
if not Assigned(@FramesDrawn) then
begin
Result := E_POINTER;
Exit;
end;
// milenko end
FInterfaceLock.Lock;
try
FramesDrawn := FFramesDrawn;
Result := NOERROR;
finally
FInterfaceLock.UnLock;
end;
end;
// Set iAvgFrameRate to the frames per hundred secs since
// streaming started. 0 otherwise.
function TBCBaseVideoRenderer.get_AvgFrameRate(out AvgFrameRate: Integer):
HResult;
var
t: Integer;
begin
// milenko start
if not Assigned(@AvgFrameRate) then
begin
Result := E_POINTER;
Exit;
end;
// milenko end
FInterfaceLock.Lock;
try
if (FIsStreaming) then
// milenko start
// t := Integer(timeGetTime) - FStreamingStart
t := Int64(timeGetTime) - FStreamingStart
// milenko end
else
t := FStreamingStart;
if (t <= 0) then
begin
AvgFrameRate := 0;
Assert(FFramesDrawn = 0);
end
else
// i is frames per hundred seconds
AvgFrameRate := MulDiv(100000, FFramesDrawn, t);
Result := NOERROR;
finally
FInterfaceLock.UnLock;
end;
end;
// Set *piAvg to the average sync offset since streaming started
// in mSec. The sync offset is the time in mSec between when the frame
// should have been drawn and when the frame was actually drawn.
function TBCBaseVideoRenderer.get_AvgSyncOffset(out Avg: Integer): HResult;
begin
// milenko start
if not Assigned(@Avg) then
begin
Result := E_POINTER;
Exit;
end;
// milenko end
FInterfaceLock.Lock;
try
if (nil = FClock) then
begin
Avg := 0;
Result := NOERROR;
Exit;
end;
// Note that we didn't gather the stats on the first frame
// so we use m_cFramesDrawn-1 here
if (FFramesDrawn <= 1) then
Avg := 0
else
Avg := (FTotAcc div (FFramesDrawn - 1));
Result := NOERROR;
finally
FInterfaceLock.UnLock;
end;
end;
// To avoid dragging in the maths library - a cheap
// approximate integer square root.
// We do this by getting a starting guess which is between 1
// and 2 times too large, followed by THREE iterations of
// Newton Raphson. (That will give accuracy to the nearest mSec
// for the range in question - roughly 0..1000)
//
// It would be faster to use a linear interpolation and ONE NR, but
// who cares. If anyone does - the best linear interpolation is
// to approximates sqrt(x) by
// y = x * (sqrt(2)-1) + 1 - 1/sqrt(2) + 1/(8*(sqrt(2)-1))
// 0r y = x*0.41421 + 0.59467
// This minimises the maximal error in the range in question.
// (error is about +0.008883 and then one NR will give error .0000something
// (Of course these are integers, so you can't just multiply by 0.41421
// you'd have to do some sort of MulDiv).
// Anyone wanna check my maths? (This is only for a property display!)
function isqrt(x: Integer): Integer;
var
s: Integer;
begin
s := 1;
// Make s an initial guess for sqrt(x)
if (x > $40000000) then
s := $8000 // prevent any conceivable closed loop
else
begin
while (s * s < x) do // loop cannot possible go more than 31 times
s := 2 * s; // normally it goes about 6 times
// Three NR iterations.
if (x = 0) then
s := 0 // Wouldn't it be tragic to divide by zero whenever our
// accuracy was perfect!
else
begin
s := (s * s + x) div (2 * s);
if (s >= 0) then
s := (s * s + x) div (2 * s);
if (s >= 0) then
s := (s * s + x) div (2 * s);
end;
end;
Result := s;
end;
//
// Do estimates for standard deviations for per-frame
// statistics
//
function TBCBaseVideoRenderer.GetStdDev(Samples: Integer; out Res: Integer;
SumSq, Tot: Int64): HResult;
var
x: Int64;
begin
// milenko start
if not Assigned(@Res) then
begin
Result := E_POINTER;
Exit;
end;
// milenko end
FInterfaceLock.Lock;
try
if (nil = FClock) then
begin
Res := 0;
Result := NOERROR;
Exit;
end;
// If S is the Sum of the Squares of observations and
// T the Total (i.e. sum) of the observations and there were
// N observations, then an estimate of the standard deviation is
// sqrt( (S - T**2/N) / (N-1) )
if (Samples <= 1) then
Res := 0
else
begin
// First frames have invalid stamps, so we get no stats for them
// So we need 2 frames to get 1 datum, so N is cFramesDrawn-1
// so we use m_cFramesDrawn-1 here
// ??? llMilDiv ???
// milenko start (removed the 2 outputdebugstring messages...i added them and
// they are not needed anymore)
x := SumSq - llMulDiv(Tot, Tot, Samples, 0);
x := x div (Samples - 1);
// milenko end
Assert(x >= 0);
Res := isqrt(Longint(x));
end;
Result := NOERROR;
finally
FInterfaceLock.UnLock;
end;
end;
// Set *piDev to the standard deviation in mSec of the sync offset
// of each frame since streaming started.
function TBCBaseVideoRenderer.get_DevSyncOffset(out Dev: Integer): HResult;
begin
// First frames have invalid stamps, so we get no stats for them
// So we need 2 frames to get 1 datum, so N is cFramesDrawn-1
Result := GetStdDev(FFramesDrawn - 1, Dev, FSumSqAcc, FTotAcc);
end;
// Set *piJitter to the standard deviation in mSec of the inter-frame time
// of frames since streaming started.
function TBCBaseVideoRenderer.get_Jitter(out Jitter: Integer): HResult;
begin
// First frames have invalid stamps, so we get no stats for them
// So second frame gives invalid inter-frame time
// So we need 3 frames to get 1 datum, so N is cFramesDrawn-2
Result := GetStdDev(FFramesDrawn - 2, Jitter, FSumSqFrameTime, FSumFrameTime);
end;
// Overidden to return our IQualProp interface
function TBCBaseVideoRenderer.NonDelegatingQueryInterface(const IID: TGUID;
out Obj): HResult;
begin
// We return IQualProp and delegate everything else
if IsEqualGUID(IID, IID_IQualProp) then
if GetInterface(IID_IQualProp, Obj) then
Result := S_OK
else
Result := E_FAIL
else if IsEqualGUID(IID, IID_IQualityControl) then
if GetInterface(IID_IQualityControl, Obj) then
Result := S_OK
else
Result := E_FAIL
else
Result := inherited NonDelegatingQueryInterface(IID, Obj);
end;
// Override JoinFilterGraph so that, just before leaving
// the graph we can send an EC_WINDOW_DESTROYED event
function TBCBaseVideoRenderer.JoinFilterGraph(Graph: IFilterGraph;
Name: PWideChar): HResult;
var
Filter: IBaseFilter;
begin
// Since we send EC_ACTIVATE, we also need to ensure
// we send EC_WINDOW_DESTROYED or the resource manager may be
// holding us as a focus object
if (Graph = nil) and Assigned(FGraph) then
begin
// We were in a graph and now we're not
// Do this properly in case we are aggregated
QueryInterface(IID_IBaseFilter, Filter);
NotifyEvent(EC_WINDOW_DESTROYED, Integer(Filter), 0);
Filter := nil;
end;
Result := inherited JoinFilterGraph(Graph, Name);
end;
// milenko start (added TBCPullPin)
constructor TBCPullPin.Create;
begin
inherited Create;
FReader := nil;
FAlloc := nil;
FState := TM_Exit;
end;
destructor TBCPullPin.Destroy;
begin
Disconnect;
end;
procedure TBCPullPin.Process;
var
Discontinuity: Boolean;
Actual: TAllocatorProperties;
hr: HRESULT;
Start, Stop, Current, AlignStop: TReferenceTime;
Request: DWORD;
Sample: IMediaSample;
StopThis: Int64;
begin
// is there anything to do?
if (FStop <= FStart) then
begin
EndOfStream;
Exit;
end;
Discontinuity := True;
// if there is more than one sample at the allocator,
// then try to queue 2 at once in order to overlap.
// -- get buffer count and required alignment
FAlloc.GetProperties(Actual);
// align the start position downwards
Start := AlignDown(FStart div UNITS, Actual.cbAlign) * UNITS;
Current := Start;
Stop := FStop;
if (Stop > FDuration) then Stop := FDuration;
// align the stop position - may be past stop, but that
// doesn't matter
AlignStop := AlignUp(Stop div UNITS, Actual.cbAlign) * UNITS;
if not FSync then
begin
// Break out of the loop either if we get to the end or we're asked
// to do something else
while (Current < AlignStop) do
begin
// Break out without calling EndOfStream if we're asked to
// do something different
if CheckRequest(@Request) then Exit;
// queue a first sample
if (Actual.cBuffers > 1) then
begin
hr := QueueSample(Current, AlignStop, True);
Discontinuity := False;
if FAILED(hr) then Exit;
end;
// loop queueing second and waiting for first..
while (Current < AlignStop) do
begin
hr := QueueSample(Current, AlignStop, Discontinuity);
Discontinuity := False;
if FAILED(hr) then Exit;
hr := CollectAndDeliver(Start, Stop);
if (S_OK <> hr) then
begin
// stop if error, or if downstream filter said
// to stop.
Exit;
end;
end;
if (Actual.cBuffers > 1) then
begin
hr := CollectAndDeliver(Start, Stop);
if FAILED(hr) then Exit;
end;
end;
end else
begin
// sync version of above loop
while (Current < AlignStop) do
begin
// Break out without calling EndOfStream if we're asked to
// do something different
if CheckRequest(@Request) then Exit;
hr := FAlloc.GetBuffer(Sample, nil, nil, 0);
if FAILED(hr) then
begin
OnError(hr);
Exit;
end;
StopThis := Current + (Sample.GetSize * UNITS);
if (StopThis > AlignStop) then StopThis := AlignStop;
Sample.SetTime(@Current, @StopThis);
Current := StopThis;
if Discontinuity then
begin
Sample.SetDiscontinuity(True);
Discontinuity := False;
end;
hr := FReader.SyncReadAligned(Sample);
if FAILED(hr) then
begin
Sample := nil;
OnError(hr);
Exit;
end;
hr := DeliverSample(Sample, Start, Stop);
if (hr <> S_OK) then
begin
if FAILED(hr) then OnError(hr);
Exit;
end;
end;
end;
EndOfStream;
end;
procedure TBCPullPin.CleanupCancelled;
var
Sample: IMediaSample;
Unused: DWORD;
begin
while True do
begin
FReader.WaitForNext(
0, // no wait
Sample,
Unused);
if Assigned(Sample) then Sample := nil
else Exit;
end;
end;
function TBCPullPin.PauseThread: HRESULT;
begin
FAccessLock.Lock;
try
if not ThreadExists then
begin
Result := E_UNEXPECTED;
Exit;
end;
// need to flush to ensure the thread is not blocked
// in WaitForNext
Result := FReader.BeginFlush;
if FAILED(Result) then Exit;
FState := TM_Pause;
Result := CallWorker(Cardinal(TM_Pause));
FReader.EndFlush;
finally
FAccessLock.UnLock;
end;
end;
function TBCPullPin.StartThread: HRESULT;
begin
FAccessLock.Lock;
try
if not Assigned(FAlloc) or not Assigned(FReader) then
begin
Result := E_UNEXPECTED;
Exit;
end;
if not ThreadExists then
begin
// commit allocator
Result := FAlloc.Commit;
if FAILED(Result) then Exit;
// start thread
if not Create_ then
begin
Result := E_FAIL;
Exit;
end;
end;
FState := TM_Start;
Result := HRESULT(CallWorker(DWORD(FState)));
finally
FAccessLock.UnLock;
end;
end;
function TBCPullPin.StopThread: HRESULT;
begin
FAccessLock.Lock;
try
if not ThreadExists then
begin
Result := S_FALSE;
Exit;
end;
// need to flush to ensure the thread is not blocked
// in WaitForNext
Result := FReader.BeginFlush;
if FAILED(Result) then Exit;
FState := TM_Exit;
Result := CallWorker(Cardinal(TM_Exit));
FReader.EndFlush;
// wait for thread to completely exit
Close;
// decommit allocator
if Assigned(FAlloc) then FAlloc.Decommit;
Result := S_OK;
finally
FAccessLock.UnLock;
end;
end;
function TBCPullPin.QueueSample(var tCurrent: TReferenceTime; tAlignStop: TReferenceTime; bDiscontinuity: Boolean): HRESULT;
var
Sample: IMediaSample;
StopThis: Int64;
begin
Result := FAlloc.GetBuffer(Sample, nil, nil, 0);
if FAILED(Result) then Exit;
StopThis := tCurrent + (Sample.GetSize * UNITS);
if (StopThis > tAlignStop) then StopThis := tAlignStop;
Sample.SetTime(@tCurrent, @StopThis);
tCurrent := StopThis;
Sample.SetDiscontinuity(bDiscontinuity);
Result := FReader.Request(Sample,0);
if FAILED(Result) then
begin
Sample := nil;
CleanupCancelled;
OnError(Result);
end;
end;
function TBCPullPin.CollectAndDeliver(tStart,tStop: TReferenceTime): HRESULT;
var
Sample: IMediaSample;
Unused: DWORD;
begin
Result := FReader.WaitForNext(INFINITE,Sample,Unused);
if FAILED(Result) then
begin
if Assigned(Sample) then Sample := nil;
end else
begin
Result := DeliverSample(Sample, tStart, tStop);
end;
if FAILED(Result) then
begin
CleanupCancelled;
OnError(Result);
end;
end;
function TBCPullPin.DeliverSample(pSample: IMediaSample; tStart,tStop: TReferenceTime): HRESULT;
var
t1, t2: TReferenceTime;
begin
// fix up sample if past actual stop (for sector alignment)
pSample.GetTime(t1, t2);
if (t2 > tStop) then t2 := tStop;
// adjust times to be relative to (aligned) start time
dec(t1,tStart);
dec(t2,tStart);
pSample.SetTime(@t1, @t2);
Result := Receive(pSample);
pSample := nil;
end;
function TBCPullPin.ThreadProc: DWord;
var
cmd: DWORD;
begin
Result := 1; // ???
while True do
begin
cmd := GetRequest;
case TThreadMsg(cmd) of
TM_Exit:
begin
Reply(S_OK);
Result := 0;
Exit;
end;
TM_Pause:
begin
// we are paused already
Reply(S_OK);
break;
end;
TM_Start:
begin
Reply(S_OK);
Process;
break;
end;
end;
// at this point, there should be no outstanding requests on the
// upstream filter.
// We should force begin/endflush to ensure that this is true.
// !!!Note that we may currently be inside a BeginFlush/EndFlush pair
// on another thread, but the premature EndFlush will do no harm now
// that we are idle.
FReader.BeginFlush;
CleanupCancelled;
FReader.EndFlush;
end;
end;
// returns S_OK if successfully connected to an IAsyncReader interface
// from this object
// Optional allocator should be proposed as a preferred allocator if
// necessary
function TBCPullPin.Connect(pUnk: IUnknown; pAlloc: IMemAllocator; bSync: Boolean): HRESULT;
var
Total, Avail: Int64;
begin
FAccessLock.Lock;
try
if Assigned(FReader) then
begin
Result := VFW_E_ALREADY_CONNECTED;
Exit;
end;
Result := pUnk.QueryInterface(IID_IAsyncReader, FReader);
if FAILED(Result) then Exit;
Result := DecideAllocator(pAlloc, nil);
if FAILED(Result) then
begin
Disconnect;
Exit;
end;
Result := FReader.Length(Total, Avail);
if FAILED(Result) then
begin
Disconnect;
Exit;
end;
// convert from file position to reference time
FDuration := Total * UNITS;
FStop := FDuration;
FStart := 0;
FSync := bSync;
Result := S_OK;
finally
FAccessLock.UnLock;
end;
end;
// disconnect any connection made in Connect
function TBCPullPin.Disconnect: HRESULT;
begin
FAccessLock.Lock;
try
StopThread;
if Assigned(FReader) then FReader := nil;
if Assigned(FAlloc) then FAlloc := nil;
Result := S_OK;
finally
FAccessLock.UnLock;
end;
end;
// agree an allocator using RequestAllocator - optional
// props param specifies your requirements (non-zero fields).
// returns an error code if fail to match requirements.
// optional IMemAllocator interface is offered as a preferred allocator
// but no error occurs if it can't be met.
function TBCPullPin.DecideAllocator(pAlloc: IMemAllocator; pProps: PAllocatorProperties): HRESULT;
var
pRequest: PAllocatorProperties;
Request: TAllocatorProperties;
begin
if (pProps = nil) then
begin
Request.cBuffers := 3;
Request.cbBuffer := 64*1024;
Request.cbAlign := 0;
Request.cbPrefix := 0;
pRequest := @Request;
end else
begin
pRequest := pProps;
end;
Result := FReader.RequestAllocator(pAlloc,pRequest,FAlloc);
end;
function TBCPullPin.Seek(tStart, tStop: TReferenceTime): HRESULT;
var
AtStart: TThreadMsg;
begin
FAccessLock.Lock;
try
AtStart := FState;
if (AtStart = TM_Start) then
begin
BeginFlush;
PauseThread;
EndFlush;
end;
FStart := tStart;
FStop := tStop;
Result := S_OK;
if (AtStart = TM_Start) then Result := StartThread;
finally
FAccessLock.UnLock;
end;
end;
function TBCPullPin.Duration(out ptDuration: TReferenceTime): HRESULT;
begin
ptDuration := FDuration;
Result := S_OK;
end;
// start pulling data
function TBCPullPin.Active: HRESULT;
begin
ASSERT(not ThreadExists);
Result := StartThread;
end;
// stop pulling data
function TBCPullPin.Inactive: HRESULT;
begin
StopThread;
Result := S_OK;
end;
function TBCPullPin.AlignDown(ll: Int64; lAlign: LongInt): Int64;
begin
Result := ll and not (lAlign-1);
end;
function TBCPullPin.AlignUp(ll: Int64; lAlign: LongInt): Int64;
begin
Result := (ll + (lAlign -1)) and not (lAlign -1);
end;
function TBCPullPin.GetReader: IAsyncReader;
begin
Result := FReader;
end;
// milenko end
// milenko start reftime implementation
procedure TBCRefTime.Create_;
begin
FTime := 0;
end;
procedure TBCRefTime.Create_(msecs: Longint);
begin
FTime := MILLISECONDS_TO_100NS_UNITS(msecs);
end;
function TBCRefTime.SetTime(var rt: TBCRefTime): TBCRefTime;
begin
FTime := rt.FTime;
Result := Self;
end;
function TBCRefTime.SetTime(var ll: LONGLONG): TBCRefTime;
begin
FTime := ll;
end;
function TBCRefTime.AddTime(var rt: TBCRefTime): TBCRefTime;
begin
TReferenceTime(Self) := TReferenceTime(Self) + TReferenceTime(rt);
Result := Self;
end;
function TBCRefTime.SubstractTime(var rt: TBCRefTime): TBCRefTime;
begin
TReferenceTime(Self) := TReferenceTime(Self) - TReferenceTime(rt);
Result := Self;
end;
function TBCRefTime.Millisecs: Longint;
begin
Result := fTime div (UNITS div MILLISECONDS);
end;
function TBCRefTime.GetUnits: LONGLONG;
begin
Result := fTime;
end;
// milenko end
// milenko start schedule implementation
constructor TBCAdvisePacket.Create;
begin
inherited Create;
end;
constructor TBCAdvisePacket.Create(Next: TBCAdvisePacket; Time: LONGLONG);
begin
inherited Create;
FNext := Next;
FEventTime := Time;
end;
procedure TBCAdvisePacket.InsertAfter(Packet: TBCAdvisePacket);
begin
Packet.FNext := FNext;
FNext := Packet;
end;
function TBCAdvisePacket.IsZ: Boolean;
begin
Result := FNext = nil;
end;
function TBCAdvisePacket.RemoveNext: TBCAdvisePacket;
var
Next,
NewNext : TBCAdvisePacket;
begin
Next := FNext;
NewNext := Next.FNext;
FNext := NewNext;
Result := Next;
end;
procedure TBCAdvisePacket.DeleteNext;
begin
RemoveNext.Free;
end;
function TBCAdvisePacket.Next: TBCAdvisePacket;
begin
Result := FNext;
if Result.IsZ then Result := nil;
end;
function TBCAdvisePacket.Cookie: DWORD;
begin
Result := FAdviseCookie;
end;
constructor TBCAMSchedule.Create(Event: THandle);
begin
inherited Create('TBCAMSchedule');
FZ := TBCAdvisePacket.Create(nil,MAX_TIME);
FHead := TBCAdvisePacket.Create(FZ,0);
FNextCookie := 0;
FAdviseCount := 0;
FAdviseCache := nil;
FCacheCount := 0;
FEvent := Event;
FSerialize := TBCCritSec.Create;
FZ.FAdviseCookie := 0;
FHead.FAdviseCookie := FZ.FAdviseCookie;
end;
destructor TBCAMSchedule.Destroy;
var
p, p_next : TBCAdvisePacket;
begin
FSerialize.Lock;
try
// Delete cache
p := FAdviseCache;
while (p <> nil) do
begin
p_next := p.FNext;
FreeAndNil(p);
p := p_next;
end;
ASSERT(FAdviseCount = 0);
// Better to be safe than sorry
if (FAdviseCount > 0) then
begin
DumpLinkedList;
while not FHead.FNext.IsZ do
begin
FHead.DeleteNext;
dec(FAdviseCount);
end;
end;
// If, in the debug version, we assert twice, it means, not only
// did we have left over advises, but we have also let m_dwAdviseCount
// get out of sync. with the number of advises actually on the list.
ASSERT(FAdviseCount = 0);
finally
FSerialize.Unlock;
end;
FreeAndNil(FSerialize);
inherited Destroy;
end;
function TBCAMSchedule.GetAdviseCount: DWORD;
begin
// No need to lock, m_dwAdviseCount is 32bits & declared volatile
// DCODER: No volatile in Delphi -> needs a lock ?
FSerialize.Lock;
try
Result := FAdviseCount;
finally
FSerialize.UnLock;
end;
end;
function TBCAMSchedule.GetNextAdviseTime: TReferenceTime;
begin
FSerialize.Lock; // Need to stop the linked list from changing
try
Result := FHead.FNext.FEventTime;
finally
FSerialize.UnLock;
end;
end;
function TBCAMSchedule.AddAdvisePacket(const time1, time2: TReferenceTime;
h: THandle; periodic: Boolean): DWORD;
var
p : TBCAdvisePacket;
begin
// Since we use MAX_TIME as a sentry, we can't afford to
// schedule a notification at MAX_TIME
ASSERT(time1 < MAX_TIME);
FSerialize.Lock;
try
if Assigned(FAdviseCache) then
begin
p := FAdviseCache;
FAdviseCache := p.FNext;
dec(FCacheCount);
end else
begin
p := TBCAdvisePacket.Create;
end;
if Assigned(p) then
begin
p.FEventTime := time1;
p.FPeriod := time2;
p.FNotify := h;
p.FPeriodic := periodic;
Result := AddAdvisePacket(p);
end else
begin
Result := 0;
end;
finally
FSerialize.UnLock;
end;
end;
function TBCAMSchedule.Unadvise(AdviseCookie: DWORD): HRESULT;
var
p_prev, p_n : TBCAdvisePacket;
begin
Result := S_FALSE;
p_prev := FHead;
FSerialize.Lock;
try
p_n := p_prev.Next;
while Assigned(p_n) do // The Next() method returns NULL when it hits z
begin
if (p_n.FAdviseCookie = AdviseCookie) then
begin
Delete(p_prev.RemoveNext);
dec(FAdviseCount);
Result := S_OK;
// Having found one cookie that matches, there should be no more
{$IFDEF DEBUG}
p_n := p_prev.Next;
while Assigned(p_n) do
begin
ASSERT(p_n.FAdviseCookie <> AdviseCookie);
p_prev := p_n;
p_n := p_prev.Next;
end;
{$ENDIF}
break;
end;
p_prev := p_n;
p_n := p_prev.Next;
end;
finally
FSerialize.UnLock;
end;
end;
function TBCAMSchedule.Advise(const Time_: TReferenceTime): TReferenceTime;
var
NextTime : TReferenceTime;
Advise : TBCAdvisePacket;
begin
{$IFDEF DEBUG}
DbgLog(
Self, 'TBCAMSchedule.Advise( ' +
inttostr((Time_ div (UNITS div MILLISECONDS))) + ' ms '
);
{$ENDIF}
FSerialize.Lock;
try
{$IFDEF DEBUG}
DumpLinkedList;
{$ENDIF}
// Note - DON'T cache the difference, it might overflow
Advise := FHead.FNext;
NextTime := Advise.FEventTime;
while ((Time_ >= NextTime) and not Advise.IsZ) do
begin
// DCODER: assert raised here
ASSERT(Advise.FAdviseCookie > 0); // If this is zero, its the head or the tail!!
ASSERT(Advise.FNotify <> INVALID_HANDLE_VALUE);
if (Advise.FPeriodic = True) then
begin
ReleaseSemaphore(Advise.FNotify,1,nil);
Advise.FEventTime := Advise.FEventTime + Advise.FPeriod;
ShuntHead;
end else
begin
ASSERT(Advise.FPeriodic = False);
SetEvent(Advise.FNotify);
dec(FAdviseCount);
Delete(FHead.RemoveNext);
end;
Advise := FHead.FNext;
NextTime := Advise.FEventTime;
end;
finally
FSerialize.UnLock;
end;
{$IFDEF DEBUG}
DbgLog(
Self, 'TBCAMSchedule.Advise(Next time stamp: ' +
inttostr((NextTime div (UNITS div MILLISECONDS))) +
' ms, for advise ' + inttostr(Advise.FAdviseCookie)
);
{$ENDIF}
Result := NextTime;
end;
function TBCAMSchedule.GetEvent: THandle;
begin
Result := FEvent;
end;
procedure TBCAMSchedule.DumpLinkedList;
{$IFDEF DEBUG}
var
i : integer;
p : TBCAdvisePacket;
{$ENDIF}
begin
{$IFDEF DEBUG}
FSerialize.Lock;
try
DbgLog(Self,'TBCAMSchedule.DumpLinkedList');
i := 0;
p := FHead;
while True do
begin
if p = nil then break;
DbgLog(
Self, 'Advise List # ' + inttostr(i) + ', Cookie ' +
inttostr(p.FAdviseCookie) + ', RefTime ' +
inttostr(p.FEventTime div (UNITS div MILLISECONDS))
);
inc(i);
p := p.Next;
end;
finally
FSerialize.Unlock;
end;
{$ENDIF}
end;
function TBCAMSchedule.AddAdvisePacket(Packet: TBCAdvisePacket): DWORD;
var
p_prev, p_n : TBCAdvisePacket;
begin
ASSERT((Packet.FEventTime >= 0) and (Packet.FEventTime < MAX_TIME));
{$IFDEF DEBUG}
ASSERT(FSerialize.CritCheckIn);
{$ENDIF}
p_prev := FHead;
inc(FNextCookie);
Packet.FAdviseCookie := FNextCookie;
Result := Packet.FAdviseCookie;
// This relies on the fact that z is a sentry with a maximal m_rtEventTime
while True do
begin
p_n := p_prev.FNext;
if (p_n.FEventTime >= Packet.FEventTime) then break;
p_prev := p_n;
end;
p_prev.InsertAfter(Packet);
inc(FAdviseCount);
{$IFDEF DEBUG}
DbgLog(
Self, 'Added advise ' + inttostr(Packet.FAdviseCookie) + ', for thread ' +
inttostr(GetCurrentThreadId) + ', scheduled at ' +
inttostr(Packet.FEventTime div (UNITS div MILLISECONDS))
);
{$ENDIF}
// If packet added at the head, then clock needs to re-evaluate wait time.
if (p_prev = FHead) then SetEvent(FEvent);
end;
procedure TBCAMSchedule.ShuntHead;
var
p_prev, p_n : TBCAdvisePacket;
Packet : TBCAdvisePacket;
begin
p_prev := FHead;
p_n := nil;
FSerialize.Lock;
try
Packet := FHead.FNext;
// This will catch both an empty list,
// and if somehow a MAX_TIME time gets into the list
// (which would also break this method).
ASSERT(Packet.FEventTime < MAX_TIME);
// This relies on the fact that z is a sentry with a maximal m_rtEventTime
while True do
begin
p_n := p_prev.FNext;
if (p_n.FEventTime >= Packet.FEventTime) then break;
p_prev := p_n;
end;
// If p_prev == pPacket then we're already in the right place
if (p_prev <> Packet) then
begin
FHead.FNext := Packet.FNext;
p_prev.FNext := Packet;
p_prev.FNext.FNext := p_n;
end;
{$IFDEF DEBUG}
DbgLog(
Self, 'Periodic advise ' + inttostr(Packet.FAdviseCookie) + ', shunted to ' +
inttostr(Packet.FEventTime div (UNITS div MILLISECONDS))
);
{$ENDIF}
finally
FSerialize.Unlock;
end;
end;
procedure TBCAMSchedule.Delete(Packet: TBCAdvisePacket);
const
CacheMax = 5; // Don't bother caching more than five
begin
if (FCacheCount >= CacheMax) then FreeAndNil(Packet)
else
begin
FSerialize.Lock;
try
Packet.FNext := FAdviseCache;
FAdviseCache := Packet;
inc(FCacheCount);
finally
FSerialize.Unlock;
end;
end;
end;
// milenko end
// milenko start refclock implementation
function AdviseThreadFunction(p: Pointer): DWORD; stdcall;
begin
Result := TBCBaseReferenceClock(p).AdviseThread;
end;
constructor TBCBaseReferenceClock.Create(Name: String; Unk: IUnknown; out hr: HRESULT;
Sched: TBCAMSchedule);
var
tc : TIMECAPS;
ThreadID : DWORD;
begin
inherited Create(Name,Unk);
FLastGotTime := 0;
FTimerResolution := 0;
FAbort := False;
if not Assigned(Sched)
then FSchedule := TBCAMSchedule.Create(CreateEvent(nil,False,False,nil))
else FSchedule := Sched;
ASSERT(fSchedule <> nil);
if not Assigned(FSchedule) then
begin
hr := E_OUTOFMEMORY;
end else
begin
FLock := TBCCritSec.Create;
// Set up the highest resolution timer we can manage
if (timeGetDevCaps(@tc, sizeof(tc)) = TIMERR_NOERROR)
then FTimerResolution := tc.wPeriodMin
else FTimerResolution := 1;
timeBeginPeriod(FTimerResolution);
// Initialise our system times - the derived clock should set the right values
FPrevSystemTime := timeGetTime;
FPrivateTime := (UNITS div MILLISECONDS) * FPrevSystemTime;
{$IFDEF PERF}
FGetSystemTime := MSR_REGISTER('TBCBaseReferenceClock.GetTime');
{$ENDIF}
if not Assigned(Sched) then
begin
FThread := CreateThread(nil, // Security attributes
0, // Initial stack size
@AdviseThreadFunction, // Thread start address
Self, // Thread parameter
0, // Creation flags
ThreadID); // Thread identifier
if (FThread > 0) then
begin
SetThreadPriority(FThread, THREAD_PRIORITY_TIME_CRITICAL);
end else
begin
hr := E_FAIL;
CloseHandle(FSchedule.GetEvent);
FreeAndNil(FSchedule);
end;
end;
end;
end;
destructor TBCBaseReferenceClock.Destroy;
begin
if (FTimerResolution > 0) then
begin
timeEndPeriod(FTimerResolution);
FTimerResolution := 0;
end;
FSchedule.DumpLinkedList;
if (FThread > 0) then
begin
FAbort := True;
TriggerThread;
WaitForSingleObject(FThread, INFINITE);
CloseHandle(FSchedule.GetEvent);
FreeAndNil(FSchedule);
end;
if Assigned(FLock) then FreeAndNil(FLock);
inherited Destroy;
end;
function TBCBaseReferenceClock.AdviseThread: HRESULT;
var
dwWait : DWORD;
rtNow : TReferenceTime;
llWait : LONGLONG;
begin
dwWait := INFINITE;
// The first thing we do is wait until something interesting happens
// (meaning a first advise or shutdown). This prevents us calling
// GetPrivateTime immediately which is goodness as that is a virtual
// routine and the derived class may not yet be constructed. (This
// thread is created in the base class constructor.)
while not FAbort do
begin
// Wait for an interesting event to happen
{$IFDEF DEBUG}
DbgLog(Self,'AdviseThread Delay: ' + inttostr(dwWait) + ' ms');
{$ENDIF}
WaitForSingleObject(FSchedule.GetEvent, dwWait);
if FAbort then break;
// There are several reasons why we need to work from the internal
// time, mainly to do with what happens when time goes backwards.
// Mainly, it stop us looping madly if an event is just about to
// expire when the clock goes backward (i.e. GetTime stop for a
// while).
rtNow := GetPrivateTime;
{$IFDEF DEBUG}
DbgLog(
Self,'AdviseThread Woke at = ' + inttostr(RefTimeToMiliSec(rtNow)) + ' ms'
);
{$ENDIF}
// We must add in a millisecond, since this is the resolution of our
// WaitForSingleObject timer. Failure to do so will cause us to loop
// franticly for (approx) 1 a millisecond.
FNextAdvise := FSchedule.Advise(10000 + rtNow);
llWait := FNextAdvise - rtNow;
ASSERT(llWait > 0);
llWait := RefTimeToMiliSec(llWait);
// DON'T replace this with a max!! (The type's of these things is VERY important)
if (llWait > REFERENCE_TIME(HIGH(DWORD))) then dwWait := HIGH(DWORD)
else dwWait := DWORD(llWait)
end;
Result := NOERROR;
end;
function TBCBaseReferenceClock.NonDelegatingQueryInterface(const IID: TGUID;
out Obj): HResult; stdcall;
begin
if (IsEqualGUID(IID,IID_IReferenceClock)) then
begin
if GetInterface(IID,Obj) then Result := S_OK
else Result := E_NOINTERFACE;
end
else
Result := inherited NonDelegatingQueryInterface(IID, Obj);
end;
function TBCBaseReferenceClock.GetTime(out Time: int64): HResult; stdcall;
var
Now_ : TReferenceTime;
begin
if Assigned(@Time) then
begin
FLock.Lock;
try
Now_ := GetPrivateTime;
if (Now_ > FLastGotTime) then
begin
FLastGotTime := Now_;
Result := S_OK;
end else
begin
Result := S_FALSE;
end;
Time := FLastGotTime;
finally
FLock.UnLock;
end;
{$IFDEF PERF}
MSR_INTEGER(FGetSystemTime, Time div (UNITS div MILLISECONDS));
{$ENDIF}
end else Result := E_POINTER;
end;
function TBCBaseReferenceClock.AdviseTime(BaseTime, StreamTime: int64;
Event: THandle; out AdviseCookie: DWORD): HResult; stdcall;
var
RefTime : TReferenceTime;
begin
if @AdviseCookie = nil then
begin
Result := E_POINTER;
Exit;
end;
AdviseCookie := 0;
// Check that the event is not already set
ASSERT(WAIT_TIMEOUT = WaitForSingleObject(Event,0));
RefTime := BaseTime + StreamTime;
if ((RefTime <= 0) or (RefTime = MAX_TIME)) then
begin
Result := E_INVALIDARG;
end else
begin
AdviseCookie := FSchedule.AddAdvisePacket(RefTime, 0, Event, False);
if AdviseCookie > 0 then Result := NOERROR
else Result := E_OUTOFMEMORY;
end;
end;
function TBCBaseReferenceClock.AdvisePeriodic(const StartTime, PeriodTime: int64;
Semaphore: THandle; out AdviseCookie: DWORD): HResult; stdcall;
begin
if @AdviseCookie = nil then
begin
Result := E_POINTER;
Exit;
end;
AdviseCookie := 0;
if ((StartTime > 0) and (PeriodTime > 0) and (StartTime <> MAX_TIME)) then
begin
AdviseCookie := FSchedule.AddAdvisePacket(StartTime,PeriodTime,Semaphore,True);
if AdviseCookie > 0 then Result := NOERROR
else Result := E_OUTOFMEMORY;
end
else Result := E_INVALIDARG;
end;
function TBCBaseReferenceClock.Unadvise(AdviseCookie: DWORD): HResult; stdcall;
begin
Result := FSchedule.Unadvise(AdviseCookie);
end;
function TBCBaseReferenceClock.GetPrivateTime: TReferenceTime;
var
Time_ : DWORD;
begin
FLock.Lock;
try
(* If the clock has wrapped then the current time will be less than
* the last time we were notified so add on the extra milliseconds
*
* The time period is long enough so that the likelihood of
* successive calls spanning the clock cycle is not considered.
*)
Time_ := timeGetTime;
FPrivateTime := FPrivateTime + Int32x32To64(UNITS div MILLISECONDS, DWORD(Time_ - FPrevSystemTime));
FPrevSystemTime := Time_;
finally
FLock.UnLock;
end;
Result := FPrivateTime;
end;
function TBCBaseReferenceClock.SetTimeDelta(const TimeDelta: TReferenceTime): HRESULT; stdcall;
{$IFDEF DEBUG}
var
llDelta : LONGLONG;
usDelta : Longint;
delta : DWORD;
Severity : integer;
{$ENDIF}
begin
{$IFDEF DEBUG}
// Just break if passed an improper time delta value
if TimeDelta > 0 then llDelta := TimeDelta
else llDelta := -TimeDelta;
if (llDelta > UNITS * 1000) then
begin
DbgLog(Self,'Bad Time Delta');
// DebugBreak;
end;
// We're going to calculate a "severity" for the time change. Max -1
// min 8. We'll then use this as the debug logging level for a
// debug log message.
usDelta := Longint(TimeDelta div 10); // Delta in micro-secs
delta := abs(usDelta); // varying delta
// Severity == 8 - ceil(log<base 8>(abs( micro-secs delta)))
Severity := 8;
while (delta > 0) do
begin
delta := delta shr 3; // div 8
dec(Severity);
end;
// Sev == 0 => > 2 second delta!
DbgLog(
Self, 'Sev ' + inttostr(Severity) + ': CSystemClock::SetTimeDelta(' +
inttostr(usDelta) + ' us) ' + inttostr(RefTimeToMiliSec(FPrivateTime)) +
' -> ' + inttostr(RefTimeToMiliSec(TimeDelta + FPrivateTime)) + ' ms'
);
{$ENDIF}
FLock.Lock;
try
FPrivateTime := FPrivateTime + TimeDelta;
// If time goes forwards, and we have advises, then we need to
// trigger the thread so that it can re-evaluate its wait time.
// Since we don't want the cost of the thread switches if the change
// is really small, only do it if clock goes forward by more than
// 0.5 millisecond. If the time goes backwards, the thread will
// wake up "early" (relativly speaking) and will re-evaluate at
// that time.
if ((TimeDelta > 5000) and (FSchedule.GetAdviseCount > 0)) then TriggerThread;
finally
FLock.UnLock;
end;
Result := NOERROR;
end;
function TBCBaseReferenceClock.GetSchedule : TBCAMSchedule;
begin
Result := FSchedule;
end;
procedure TBCBaseReferenceClock.TriggerThread;
begin
{$IFDEF DEBUG}
DbgLog(Self,'TriggerThread : ' + inttostr(FSchedule.GetEvent));
{$ENDIF}
SetEvent(FSchedule.GetEvent);
end;
// milenko end
// milenko start sysclock implementation
constructor TBCSystemClock.Create(Name: WideString; Unk : IUnknown; out hr : HRESULT);
begin
inherited Create(Name,Unk,hr);
end;
function TBCSystemClock.NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult;
begin
if IsEqualGUID(IID,IID_IPersist) then
begin
if GetInterface(IID,Obj) then Result := S_OK
else Result := E_NOINTERFACE;
end else
if IsEqualGUID(IID,IID_IAMClockAdjust) then
begin
if GetInterface(IID,Obj) then Result := S_OK
else Result := E_NOINTERFACE;
end
else Result := inherited NonDelegatingQueryInterface(IID,Obj);
end;
function TBCSystemClock.GetClassID(out classID: TCLSID): HResult; stdcall;
begin
if not Assigned(@ClassID) then
begin
Result := E_POINTER;
Exit;
end;
classID := CLSID_SystemClock;
Result := NOERROR;
end;
function TBCSystemClock.SetClockDelta(rtDelta: TReferenceTime): HResult; stdcall;
begin
Result := SetTimeDelta(rtDelta);
end;
// milenko end
initialization
{$IFDEF DEBUG}
{$IFDEF VER130}
AssertErrorProc := @DbgAssert;
{$ELSE}
AssertErrorProc := DbgAssert;
{$ENDIF}
{$IFNDEF MESSAGE}
AssignFile(DebugFile, ParamStr(0) + '.log');
if FileExists(ParamStr(0) + '.log') then
Append(DebugFile) else
Rewrite(DebugFile);
{$ENDIF}
{$ENDIF}
finalization
begin
if TemplatesVar <> nil then TemplatesVar.Free;
TemplatesVar := nil;
{$IFDEF DEBUG}
{$IFNDEF MESSAGE}
Writeln(DebugFile, format('FactoryCount: %d, ObjectCount: %d.',[FactoryCount, ObjectCount]));
CloseFile(DebugFile);
{$ELSE}
OutputDebugString(PChar(format('FactoryCount: %d, ObjectCount: %d.',[FactoryCount, ObjectCount])));
{$ENDIF}
{$ENDIF}
// milenko start (only needed with PERF)
{$IFDEF PERF}
SetLength(Incidents, 0);
SetLength(IncidentsLog, 0);
{$ENDIF}
// milenko end
end;
end.