Delphi控件源码

开发平台：

Delphi

BaseClass.pas：源码内容

Pointer(FAllocator) := Pointer(Allocator);
end;
{ TBCTransInPlaceFilter }
function TBCTransInPlaceFilter.CheckTransform(mtIn,
mtOut: PAMMediaType): HRESULT;
begin
result := S_OK;
end;
// dir is the direction of our pin.
// pReceivePin is the pin we are connecting to.
function TBCTransInPlaceFilter.CompleteConnect(dir: TPinDirection;
ReceivePin: IPin): HRESULT;
var
pmt: PAMMediaType;
begin
ASSERT(FInput <> nil);
ASSERT(FOutput <> nil);
// if we are not part of a graph, then don't indirect the pointer
// this probably prevents use of the filter without a filtergraph
if(FGraph = nil) then
begin
result := VFW_E_NOT_IN_GRAPH;
exit;
end;
// Always reconnect the input to account for buffering changes
//
// Because we don't get to suggest a type on ReceiveConnection
// we need another way of making sure the right type gets used.
//
// One way would be to have our EnumMediaTypes return our output
// connection type first but more deterministic and simple is to
// call ReconnectEx passing the type we want to reconnect with
// via the base class ReconeectPin method.
if(dir = PINDIR_OUTPUT) then
begin
if FInput.IsConnected then
begin
result := ReconnectPin(FInput, FOutput.AMMediaType);
exit;
end;
result := NOERROR;
exit;
end;
ASSERT(dir = PINDIR_INPUT);
// Reconnect output if necessary
if FOutput.IsConnected then
begin
pmt := FInput.CurrentMediaType.MediaType;
if (not TBCMediaType(pmt).Equal(FOutput.CurrentMediaType.MediaType)) then
begin
result := ReconnectPin(FOutput, FInput.CurrentMediaType.MediaType);
exit;
end;
end;
result := NOERROR;
end;
function TBCTransInPlaceFilter.Copy(Source: IMediaSample): IMediaSample;
var
Start, Stop: TReferenceTime;
Time: boolean;
pStartTime, pEndTime: PReferenceTime;
TimeStart, TimeEnd: Int64;
Flags: DWORD;
Sample2: IMediaSample2;
props: PAMSample2Properties;
MediaType: PAMMediaType;
DataLength: LongInt;
SourceBuffer, DestBuffer: PByte;
SourceSize, DestSize: LongInt;
hr: hresult;
begin
Time := (Source.GetTime(Start, Stop) = S_OK);
// this may block for an indeterminate amount of time
if Time then
begin
pStartTime := @Start;
pEndTime := @Stop;
end
else
begin
pStartTime := nil;
pEndTime := nil;
end;
if FSampleSkipped then Flags := AM_GBF_PREVFRAMESKIPPED else Flags := 0;
hr := OutputPin.PeekAllocator.GetBuffer(result, pStartTime, pEndTime, Flags);
if FAILED(hr) then exit;
ASSERT(result <> nil);
if(SUCCEEDED(result.QueryInterface(IID_IMediaSample2, Sample2))) then
begin
props := FInput.SampleProps;
hr := Sample2.SetProperties(SizeOf(TAMSample2Properties) - (4*2), props^);
Sample2 := nil;
if FAILED(hr) then
begin
result := nil;
exit;
end;
end
else
begin
if Time then result.SetTime(@Start, @Stop);
if (Source.IsSyncPoint = S_OK) then result.SetSyncPoint(True);
if ((Source.IsDiscontinuity = S_OK) or FSampleSkipped) then result.SetDiscontinuity(True);
if (Source.IsPreroll = S_OK) then result.SetPreroll(True);
// Copy the media type
if (Source.GetMediaType(MediaType) = S_OK) then
begin
result.SetMediaType(MediaType^);
DeleteMediaType(MediaType);
end;
end;
FSampleSkipped := FALSE;
// Copy the sample media times
if (Source.GetMediaTime(TimeStart, TimeEnd) = NOERROR) then
result.SetMediaTime(@TimeStart,@TimeEnd);
// Copy the actual data length and the actual data.
DataLength := Source.GetActualDataLength;
result.SetActualDataLength(DataLength);
// Copy the sample data
SourceSize := Source.GetSize;
DestSize := result.GetSize;
// milenko start get rid of compiler warnings
if (DestSize < SourceSize) then
begin
end;
// milenko end
ASSERT(DestSize >= SourceSize, format('DestSize (%d) < SourceSize (%d)',[DestSize, SourceSize]));
ASSERT(DestSize >= DataLength);
Source.GetPointer(SourceBuffer);
result.GetPointer(DestBuffer);
ASSERT((DestSize = 0) or (SourceBuffer <> nil) and (DestBuffer <> nil));
CopyMemory(DestBuffer, SourceBuffer, DataLength);
end;
constructor TBCTransInPlaceFilter.Create(ObjectName: string;
unk: IUnKnown; clsid: TGUID; out hr: HRESULT; ModifiesData: boolean);
begin
inherited create(ObjectName, Unk, clsid);
FModifiesData := ModifiesData;
end;
constructor TBCTransInPlaceFilter.CreateFromFactory(Factory: TBCClassFactory;
const Controller: IUnknown);
begin
inherited create(FacTory.FName, Controller, FacTory.FClassID);
FModifiesData := True;
end;
// Tell the output pin's allocator what size buffers we require.
// *pAlloc will be the allocator our output pin is using.
function TBCTransInPlaceFilter.DecideBufferSize(Alloc: IMemAllocator;
propInputRequest: PAllocatorProperties): HRESULT;
var Request, Actual: TAllocatorProperties;
begin
// If we are connected upstream, get his views
if FInput.IsConnected then
begin
// Get the input pin allocator, and get its size and count.
// we don't care about his alignment and prefix.
result := InputPin.FAllocator.GetProperties(Request);
//Request.cbBuffer := 230400;
if FAILED(result) then exit; // Input connected but with a secretive allocator - enough!
end
else
begin
// We're reduced to blind guessing. Let's guess one byte and if
// this isn't enough then when the other pin does get connected
// we can revise it.
ZeroMemory(@Request, sizeof(Request));
Request.cBuffers := 1;
Request.cbBuffer := 1;
end;
{$IFDEF DEBUG}
DbgLog(self, 'Setting Allocator Requirements');
DbgLog(self, format('Count %d, Size %d',[Request.cBuffers, Request.cbBuffer]));
{$ENDIF}
// Pass the allocator requirements to our output side
// but do a little sanity checking first or we'll just hit
// asserts in the allocator.
propInputRequest.cBuffers := Request.cBuffers;
propInputRequest.cbBuffer := Request.cbBuffer;
if (propInputRequest.cBuffers <= 0) then propInputRequest.cBuffers := 1;
if (propInputRequest.cbBuffer <= 0) then propInputRequest.cbBuffer := 1;
result := Alloc.SetProperties(propInputRequest^, Actual);
if FAILED(result) then exit;
{$IFDEF DEBUG}
DbgLog(self, 'Obtained Allocator Requirements');
DbgLog(self, format('Count %d, Size %d, Alignment %d', [Actual.cBuffers, Actual.cbBuffer, Actual.cbAlign]));
{$ENDIF}
// Make sure we got the right alignment and at least the minimum required
if ((Request.cBuffers > Actual.cBuffers)
or (Request.cbBuffer > Actual.cbBuffer)
or (Request.cbAlign > Actual.cbAlign)) then
result := E_FAIL
else
result := NOERROR;
end;
function TBCTransInPlaceFilter.GetMediaType(Position: integer;
out MediaType: PAMMediaType): HRESULT;
begin
{$IFDEF DEBUG}
DbgLog(self, 'TBCTransInPlaceFilter.GetMediaType should never be called');
{$ENDIF}
result := E_UNEXPECTED;
end;
// return a non-addrefed CBasePin * for the user to addref if he holds onto it
// for longer than his pointer to us. We create the pins dynamically when they
// are asked for rather than in the constructor. This is because we want to
// give the derived class an oppportunity to return different pin objects
// As soon as any pin is needed we create both (this is different from the
// usual transform filter) because enumerators, allocators etc are passed
// through from one pin to another and it becomes very painful if the other
// pin isn't there. If we fail to create either pin we ensure we fail both.
function TBCTransInPlaceFilter.GetPin(n: integer): TBCBasePin;
var hr: HRESULT;
begin
hr := S_OK;
// Create an input pin if not already done
if(FInput = nil) then
begin
FInput := TBCTransInPlaceInputPin.Create('TransInPlace input pin',
self, // Owner filter
hr, // Result code
'Input'); // Pin name
// Constructor for CTransInPlaceInputPin can't fail
ASSERT(SUCCEEDED(hr));
end;
// Create an output pin if not already done
if((FInput <> nil) and (FOutput = nil)) then
begin
FOutput := TBCTransInPlaceOutputPin.Create('TransInPlace output pin',
self, // Owner filter
hr, // Result code
'Output'); // Pin name
// a failed return code should delete the object
ASSERT(SUCCEEDED(hr));
if(FOutput = nil) then
begin
FInput.Free;
FInput := nil;
end;
end;
// Return the appropriate pin
ASSERT(n in [0,1]);
case n of
0: result := FInput;
1: result := FOutput;
else
result := nil;
end;
end;
function TBCTransInPlaceFilter.InputPin: TBCTransInPlaceInputPin;
begin
result := TBCTransInPlaceInputPin(FInput);
end;
function TBCTransInPlaceFilter.OutputPin: TBCTransInPlaceOutputPin;
begin
result := TBCTransInPlaceOutputPin(FOutput);
end;
function TBCTransInPlaceFilter.Receive(Sample: IMediaSample): HRESULT;
var Props: PAMSample2Properties;
begin
// Check for other streams and pass them on */
Props := FInput.SampleProps;
if (Props.dwStreamId <> AM_STREAM_MEDIA) then
begin
result := FOutput.Deliver(Sample);
exit;
end;
if UsingDifferentAllocators then
begin
// We have to copy the data.
Sample := Copy(Sample);
if (Sample = nil) then
begin
result := E_UNEXPECTED;
exit;
end;
end;
// have the derived class transform the data
result := Transform(Sample);
if FAILED(result) then
begin
{$IFDEF DEBUG}
DbgLog(self, 'Error from TransInPlace');
{$ENDIF}
if UsingDifferentAllocators then Sample := nil;
exit;
end;
// the Transform() function can return S_FALSE to indicate that the
// sample should not be delivered; we only deliver the sample if it's
// really S_OK (same as NOERROR, of course.)
if (result = NOERROR) then
result := FOutput.Deliver(Sample)
else
begin
// But it would be an error to return this private workaround
// to the caller ...
if (result = S_FALSE) then
begin
// S_FALSE returned from Transform is a PRIVATE agreement
// We should return NOERROR from Receive() in this cause because
// returning S_FALSE from Receive() means that this is the end
// of the stream and no more data should be sent.
FSampleSkipped := True;
if (not FQualityChanged) then
begin
NotifyEvent(EC_QUALITY_CHANGE,0,0);
FQualityChanged := True;
end;
result := NOERROR;
end;
end;
// release the output buffer. If the connected pin still needs it,
// it will have addrefed it itself.
if UsingDifferentAllocators then Sample := nil;
end;
function TBCTransInPlaceFilter.TypesMatch: boolean;
var
pmt: PAMMediaType;
begin
pmt := InputPin.CurrentMediaType.MediaType;
result := TBCMediaType(pmt).Equal(OutputPin.CurrentMediaType.MediaType);
end;
function TBCTransInPlaceFilter.UsingDifferentAllocators: boolean;
begin
result := Pointer(InputPin.FAllocator) <> Pointer(OutputPin.FAllocator);
end;
{ TBCBasePropertyPage }
function TBCBasePropertyPage.Activate(hwndParent: HWnd; const rc: TRect;
bModal: BOOL): HResult;
begin
// Return failure if SetObject has not been called.
if (FObjectSet = FALSE) or (hwndParent = 0) then
begin
result := E_UNEXPECTED;
exit;
end;
// FForm := TCustomFormClass(FFormClass).Create(nil);
if (FForm = nil) then
begin
result := E_OUTOFMEMORY;
exit;
end;
FForm.ParentWindow := hwndParent;
if assigned(FForm.OnActivate) then FForm.OnActivate(FForm);
Move(rc);
result := Show(SW_SHOWNORMAL);
end;
function TBCBasePropertyPage.Apply: HResult;
begin
// In ActiveMovie 1.0 we used to check whether we had been activated or
// not. This is too constrictive. Apply should be allowed as long as
// SetObject was called to set an object. So we will no longer check to
// see if we have been activated (ie., m_hWnd != NULL), but instead
// make sure that m_bObjectSet is True (ie., SetObject has been called).
if (FObjectSet = FALSE) or (FPageSite = nil) then
begin
result := E_UNEXPECTED;
exit;
end;
if (FDirty = FALSE) then
begin
result := NOERROR;
exit;
end;
// Commit derived class changes
result := FForm.OnApplyChanges;
if SUCCEEDED(result) then FDirty := FALSE;
end;
function TBCBasePropertyPage.Deactivate: HResult;
var Style: DWORD;
begin
if (FForm = nil) then
begin
result := E_UNEXPECTED;
exit;
end;
// Remove WS_EX_CONTROLPARENT before DestroyWindow call
Style := GetWindowLong(FForm.Handle, GWL_EXSTYLE);
Style := Style and (not WS_EX_CONTROLPARENT);
// Set m_hwnd to be NULL temporarily so the message handler
// for WM_STYLECHANGING doesn't add the WS_EX_CONTROLPARENT
// style back in
SetWindowLong(FForm.Handle, GWL_EXSTYLE, Style);
if assigned(FForm.OnDeactivate) then FForm.OnDeactivate(FForm);
// Destroy the dialog window
//FForm.Free;
//FForm := nil;
result := NOERROR;
end;
function TBCBasePropertyPage.GetPageInfo(out pageInfo: TPropPageInfo): HResult;
begin
pageInfo.cb := sizeof(TPropPageInfo);
AMGetWideString(FForm.Caption, pageInfo.pszTitle);
PageInfo.pszDocString := nil;
PageInfo.pszHelpFile := nil;
PageInfo.dwHelpContext:= 0;
PageInfo.size.cx := FForm.width;
PageInfo.size.cy := FForm.Height;
Result := NoError;
end;
function TBCBasePropertyPage.Help(pszHelpDir: POleStr): HResult;
begin
result := E_NOTIMPL;
end;
function TBCBasePropertyPage.IsPageDirty: HResult;
begin
if FDirty then result := S_OK else result := S_FALSE;
end;
function TBCBasePropertyPage.Move(const rect: TRect): HResult;
begin
if (FForm = nil) then
begin
result := E_UNEXPECTED;
exit;
end;
MoveWindow(FForm.Handle, // Property page handle
Rect.left, // x coordinate
Rect.top, // y coordinate
Rect.Right - Rect.Left, // Overall window width
Rect.Bottom - Rect.Top, // And likewise height
True); // Should we repaint it
result := NOERROR;
end;
function TBCBasePropertyPage.SetObjects(cObjects: Integer;
pUnkList: PUnknownList): HResult;
begin
if (cObjects = 1) then
begin
if (pUnkList = nil) then
begin
result := E_POINTER;
exit;
end;
// Set a flag to say that we have set the Object
FObjectSet := True ;
result := FForm.OnConnect(pUnkList^[0]);
exit;
end
else
if (cObjects = 0) then
begin
// Set a flag to say that we have not set the Object for the page
FObjectSet := FALSE;
result := FForm.OnDisconnect;
exit;
end;
{$IFDEF DEBUG}
DbgLog(self, 'No support for more than one object');
{$ENDIF}
result := E_UNEXPECTED;
end;
function TBCBasePropertyPage.SetPageSite(
const pageSite: IPropertyPageSite): HResult;
begin
if (pageSite <> nil) then
begin
if (FPageSite <> nil) then
begin
result := E_UNEXPECTED;
exit;
end;
FPageSite := pageSite;
end
else
begin
if (FPageSite = nil) then
begin
result := E_UNEXPECTED;
exit;
end;
FPageSite := nil;
end;
result := NOERROR;
end;
function TBCBasePropertyPage.Show(nCmdShow: Integer): HResult;
begin
if (FForm = nil) then
begin
result := E_UNEXPECTED;
exit;
end;
if ((nCmdShow <> SW_SHOW) and (nCmdShow <> SW_SHOWNORMAL) and (nCmdShow <> SW_HIDE)) then
begin
result := E_INVALIDARG;
exit;
end;
if nCmdShow in [SW_SHOW,SW_SHOWNORMAL] then FForm.Show else FForm.Hide;
InvalidateRect(FForm.Handle, nil, True);
result := NOERROR;
end;
function TBCBasePropertyPage.TranslateAccelerator(msg: PMsg): HResult;
begin
result := E_NOTIMPL;
end;
constructor TBCBasePropertyPage.Create(Name: String; Unk: IUnKnown; Form: TFormPropertyPage);
begin
inherited Create(Name, Unk);
FForm := Form;
FForm.BorderStyle := bsNone;
FPageSite := nil;
FObjectSet := false;
FDirty := false;
end;
destructor TBCBasePropertyPage.Destroy;
begin
if FForm <> nil then
begin
FForm.Free;
FForm := nil;
end;
inherited;
end;
constructor TFormPropertyPage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
WindowProc := MyWndProc;
end;
procedure TFormPropertyPage.MyWndProc(var aMsg: TMessage);
var
lpss : PStyleStruct;
begin
// we would like the TAB key to move around the tab stops in our property
// page, but for some reason OleCreatePropertyFrame clears the CONTROLPARENT
// style behind our back, so we need to switch it back on now behind its
// back. Otherwise the tab key will be useless in every page.
// DCoder: removing CONTROLPARENT is also the reason for non responding
// PropertyPages when using ShowMessage and TComboBox.
if (aMsg.Msg = WM_STYLECHANGING) and (aMsg.WParam = GWL_EXSTYLE) then
begin
lpss := PStyleStruct(aMsg.LParam);
lpss.styleNew := lpss.styleNew or WS_EX_CONTROLPARENT;
aMsg.Result := 0;
Exit;
end;
WndProc(aMsg);
end;
function TFormPropertyPage.OnApplyChanges: HRESULT;
begin
result := NOERROR;
end;
function TFormPropertyPage.OnConnect(Unknown: IUnKnown): HRESULT;
begin
result := NOERROR;
end;
function TFormPropertyPage.OnDisconnect: HRESULT;
begin
result := NOERROR;
end;
procedure TBCBasePropertyPage.SetPageDirty;
begin
FDirty := True;
if Assigned(FPageSite) then FPageSite.OnStatusChange(PROPPAGESTATUS_DIRTY);
end;
{ TBCBaseDispatch }
function TBCBaseDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
var ti: ITypeInfo;
begin
// although the IDispatch riid is dead, we use this to pass from
// the interface implementation class to us the iid we are talking about.
result := GetTypeInfo(iid, 0, LocaleID, ti);
if SUCCEEDED(result) then
result := ti.GetIDsOfNames(Names, NameCount, DispIDs);
end;
function TBCBaseDispatch.GetTypeInfo(const iid: TGUID; info: Cardinal; lcid: LCID;
out tinfo): HRESULT; stdcall;
var
tlib : ITypeLib;
begin
// we only support one type element
if (info <> 0) then
begin
result := TYPE_E_ELEMENTNOTFOUND;
exit;
end;
// always look for neutral
if (FTI = nil) then
begin
result := LoadRegTypeLib(LIBID_QuartzTypeLib, 1, 0, lcid, tlib);
if FAILED(result) then
begin
result := LoadTypeLib('control.tlb', tlib);
if FAILED(result) then exit;
end;
result := tlib.GetTypeInfoOfGuid(iid, Fti);
tlib := nil;
if FAILED(result) then exit;
end;
ITypeInfo(tinfo) := Fti;
result := S_OK;
end;
function TBCBaseDispatch.GetTypeInfoCount(out Count: Integer): HResult;
begin
count := 1;
result := S_OK;
end;
{ TBCMediaControl }
constructor TBCMediaControl.Create(name: string; unk: IUnknown);
begin
FBaseDisp := TBCBaseDispatch.Create;
end;
destructor TBCMediaControl.Destroy;
begin
FBaseDisp.Free;
inherited;
end;
function TBCMediaControl.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
result := FBasedisp.GetIDsOfNames(IID_IMediaControl, Names, NameCount, LocaleID, DispIDs);
end;
function TBCMediaControl.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
result := Fbasedisp.GetTypeInfo(IID_IMediaControl, index, LocaleID, TypeInfo);
end;
function TBCMediaControl.GetTypeInfoCount(out Count: Integer): HResult;
begin
result := FBaseDisp.GetTypeInfoCount(Count);
end;
function TBCMediaControl.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
var ti: ITypeInfo;
begin
// this parameter is a dead leftover from an earlier interface
if not IsEqualGUID(GUID_NULL, IID) then
begin
result := DISP_E_UNKNOWNINTERFACE;
exit;
end;
result := GetTypeInfo(0, LocaleID, ti);
if FAILED(result) then exit;
result := ti.Invoke(Pointer(Integer(Self)), DISPID, Flags, TDispParams(Params),
VarResult, ExcepInfo, ArgErr);
end;
{ TBCMediaEvent }
constructor TBCMediaEvent.Create(Name: string; Unk: IUnknown);
begin
inherited Create(name, Unk);
FBasedisp := TBCBaseDispatch.Create;
end;
destructor TBCMediaEvent.destroy;
begin
FBasedisp.Free;
inherited;
end;
function TBCMediaEvent.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
result := FBasedisp.GetIDsOfNames(IID_IMediaEvent, Names, NameCount, LocaleID, DispIDs);
end;
function TBCMediaEvent.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
result := Fbasedisp.GetTypeInfo(IID_IMediaEvent, index, LocaleID, TypeInfo);
end;
function TBCMediaEvent.GetTypeInfoCount(out Count: Integer): HResult;
begin
result := FBaseDisp.GetTypeInfoCount(Count);
end;
function TBCMediaEvent.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
var ti: ITypeInfo;
begin
// this parameter is a dead leftover from an earlier interface
if not IsEqualGUID(GUID_NULL, IID) then
begin
result := DISP_E_UNKNOWNINTERFACE;
exit;
end;
result := GetTypeInfo(0, LocaleID, ti);
if FAILED(result) then exit;
result := ti.Invoke(Pointer(Integer(Self)), DISPID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
end;
{ TBCMediaPosition }
constructor TBCMediaPosition.Create(Name: String; Unk: IUnknown);
begin
inherited Create(Name, Unk);
FBaseDisp := TBCBaseDispatch.Create;
end;
constructor TBCMediaPosition.Create(Name: String; Unk: IUnknown;
out hr: HRESULT);
begin
inherited Create(Name, Unk);
FBaseDisp := TBCBaseDispatch.Create;
end;
destructor TBCMediaPosition.Destroy;
begin
FBaseDisp.Free;
inherited;
end;
function TBCMediaPosition.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
result := FBasedisp.GetIDsOfNames(IID_IMediaPosition, Names, NameCount, LocaleID, DispIDs);
end;
function TBCMediaPosition.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
result := Fbasedisp.GetTypeInfo(IID_IMediaPosition, index, LocaleID, TypeInfo);
end;
function TBCMediaPosition.GetTypeInfoCount(out Count: Integer): HResult;
begin
result := Fbasedisp.GetTypeInfoCount(Count);
end;
function TBCMediaPosition.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
var ti: ITypeInfo;
begin
// this parameter is a dead leftover from an earlier interface
if not IsEqualGUID(GUID_NULL, IID) then
begin
result := DISP_E_UNKNOWNINTERFACE;
exit;
end;
result := GetTypeInfo(0, LocaleID, ti);
if FAILED(result) then exit;
result := ti.Invoke(Pointer(Integer(Self)), DISPID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
end;
{ TBCPosPassThru }
function TBCPosPassThru.CanSeekBackward(
out pCanSeekBackward: Integer): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.CanSeekBackward(pCanSeekBackward);
end;
function TBCPosPassThru.CanSeekForward(
out pCanSeekForward: Integer): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.CanSeekForward(pCanSeekForward);
end;
function TBCPosPassThru.CheckCapabilities(
var pCapabilities: DWORD): HRESULT;
var
MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.CheckCapabilities(pCapabilities);
end;
function TBCPosPassThru.ConvertTimeFormat(out pTarget: int64;
pTargetFormat: PGUID; Source: int64; pSourceFormat: PGUID): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.ConvertTimeFormat(pTarget, pTargetFormat, Source, pSourceFormat);
end;
constructor TBCPosPassThru.Create(name: String; Unk: IUnknown;
out hr: HRESULT; Pin: IPin);
begin
assert(Pin <> nil);
inherited Create(Name,Unk);
FPin := Pin;
end;
function TBCPosPassThru.ForceRefresh: HRESULT;
begin
result := S_OK;
end;
function TBCPosPassThru.get_CurrentPosition(
out pllTime: TRefTime): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.get_CurrentPosition(pllTime);
end;
function TBCPosPassThru.get_Duration(out plength: TRefTime): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.get_Duration(plength);
end;
function TBCPosPassThru.get_PrerollTime(out pllTime: TRefTime): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.get_PrerollTime(pllTime);
end;
function TBCPosPassThru.get_Rate(out pdRate: double): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.get_Rate(pdRate);
end;
function TBCPosPassThru.get_StopTime(out pllTime: TRefTime): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.get_StopTime(pllTime);
end;
function TBCPosPassThru.GetAvailable(out pEarliest,
pLatest: int64): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.GetAvailable(pEarliest, pLatest);
end;
function TBCPosPassThru.GetCapabilities(out pCapabilities: DWORD): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.GetCapabilities(pCapabilities);
end;
function TBCPosPassThru.GetCurrentPosition(out pCurrent: int64): HRESULT;
var
MS: IMediaSeeking;
Stop: int64;
begin
result := GetMediaTime(pCurrent, Stop);
if SUCCEEDED(result) then
result := NOERROR
else
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.GetCurrentPosition(pCurrent)
end;
end;
function TBCPosPassThru.GetDuration(out pDuration: int64): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.GetDuration(pDuration);
end;
function TBCPosPassThru.GetMediaTime(out StartTime,
EndTime: Int64): HRESULT;
begin
result := E_FAIL;
end;
// Return the IMediaPosition interface from our peer
function TBCPosPassThru.GetPeer(out MP: IMediaPosition): HRESULT;
var
Connected: IPin;
begin
result := FPin.ConnectedTo(Connected);
if FAILED(result) then
begin
result := E_NOTIMPL;
exit;
end;
result := Connected.QueryInterface(IID_IMediaPosition, MP);
Connected := nil;
if FAILED(result) then
begin
result := E_NOTIMPL;
exit;
end;
result := S_OK;
end;
function TBCPosPassThru.GetPeerSeeking(out MS: IMediaSeeking): HRESULT;
var
Connected: IPin;
begin
MS := nil;
result := FPin.ConnectedTo(Connected);
if FAILED(result) then
begin
result := E_NOTIMPL;
exit;
end;
result := Connected.QueryInterface(IID_IMediaSeeking, MS);
Connected := nil;
if FAILED(result) then
begin
result := E_NOTIMPL;
exit;
end;
result := S_OK;
end;
function TBCPosPassThru.GetPositions(out pCurrent, pStop: int64): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.GetPositions(pCurrent, pStop);
end;
function TBCPosPassThru.GetPreroll(out pllPreroll: int64): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.GetPreroll(pllPreroll);
end;
function TBCPosPassThru.GetRate(out pdRate: double): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.GetRate(pdRate);
end;
function TBCPosPassThru.GetStopPosition(out pStop: int64): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.GetStopPosition(pStop);
end;
function TBCPosPassThru.GetTimeFormat(out pFormat: TGUID): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.GetTimeFormat(pFormat);
end;
function TBCPosPassThru.IsFormatSupported(const pFormat: TGUID): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.IsFormatSupported(pFormat);
end;
function TBCPosPassThru.IsUsingTimeFormat(const pFormat: TGUID): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.IsUsingTimeFormat(pFormat);
end;
function TBCPosPassThru.put_CurrentPosition(llTime: TRefTime): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.put_CurrentPosition(llTime);
end;
function TBCPosPassThru.put_PrerollTime(llTime: TRefTime): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.put_PrerollTime(llTime);
end;
function TBCPosPassThru.put_Rate(dRate: double): HResult;
var MP: IMediaPosition;
begin
if (dRate = 0.0) then
begin
result := E_INVALIDARG;
exit;
end;
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.put_Rate(dRate);
end;
function TBCPosPassThru.put_StopTime(llTime: TRefTime): HResult;
var MP: IMediaPosition;
begin
result := GetPeer(MP);
if FAILED(result) then exit;
result := MP.put_StopTime(llTime);
end;
function TBCPosPassThru.QueryPreferredFormat(out pFormat: TGUID): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.QueryPreferredFormat(pFormat);
end;
function TBCPosPassThru.SetPositions(var pCurrent: int64;
dwCurrentFlags: DWORD; var pStop: int64; dwStopFlags: DWORD): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.SetPositions(pCurrent, dwCurrentFlags, pStop, dwStopFlags);
end;
function TBCPosPassThru.SetRate(dRate: double): HRESULT;
var MS: IMediaSeeking;
begin
if (dRate = 0.0) then
begin
result := E_INVALIDARG;
exit;
end;
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.SetRate(dRate);
end;
function TBCPosPassThru.SetTimeFormat(const pFormat: TGUID): HRESULT;
var MS: IMediaSeeking;
begin
result := GetPeerSeeking(MS);
if FAILED(result) then exit;
result := MS.SetTimeFormat(pFormat);
end;
{ TBCRendererPosPassThru }
// Media times (eg current frame, field, sample etc) are passed through the
// filtergraph in media samples. When a renderer gets a sample with media
// times in it, it will call one of the RegisterMediaTime methods we expose
// (one takes an IMediaSample, the other takes the media times direct). We
// store the media times internally and return them in GetCurrentPosition.
constructor TBCRendererPosPassThru.Create(name: String; Unk: IUnknown;
out hr: HRESULT; Pin: IPin);
begin
inherited Create(Name,Unk,hr,Pin);
FStartMedia:= 0;
FEndMedia := 0;
FReset := True;
FPositionLock := TBCCritSec.Create;
end;
destructor TBCRendererPosPassThru.destroy;
begin
FPositionLock.Free;
inherited;
end;
// Intended to be called by the owing filter during EOS processing so
// that the media times can be adjusted to the stop time. This ensures
// that the GetCurrentPosition will actully get to the stop position.
function TBCRendererPosPassThru.EOS: HRESULT;
var Stop: int64;
begin
if FReset then result := E_FAIL
else
begin
result := GetStopPosition(Stop);
if SUCCEEDED(result) then
begin
FPositionLock.Lock;
try
FStartMedia := Stop;
FEndMedia := Stop;
finally
FPositionLock.UnLock;
end;
end;
end;
end;
function TBCRendererPosPassThru.GetMediaTime(out StartTime,
EndTime: int64): HRESULT;
begin
FPositionLock.Lock;
try
if FReset then
begin
result := E_FAIL;
exit;
end;
// We don't have to return the end time
result := ConvertTimeFormat(StartTime, nil, FStartMedia, @TIME_FORMAT_MEDIA_TIME);
if SUCCEEDED(result) then
result := ConvertTimeFormat(EndTime, nil, FEndMedia, @TIME_FORMAT_MEDIA_TIME);
finally
FPositionLock.UnLock;
end;
end;
// Sets the media times the object should report
function TBCRendererPosPassThru.RegisterMediaTime(
MediaSample: IMediaSample): HRESULT;
var StartMedia, EndMedia: TReferenceTime;
begin
ASSERT(assigned(MediaSample));
FPositionLock.Lock;
try
// Get the media times from the sample
result := MediaSample.GetTime(StartMedia, EndMedia);
if FAILED(result) then
begin
ASSERT(result = VFW_E_SAMPLE_TIME_NOT_SET);
exit;
end;
FStartMedia := StartMedia;
FEndMedia := EndMedia;
FReset := FALSE;
result := NOERROR;
finally
FPositionLock.Unlock;
end;
end;
// Sets the media times the object should report
function TBCRendererPosPassThru.RegisterMediaTime(StartTime,
EndTime: int64): HRESULT;
begin
FPositionLock.Lock;
try
FStartMedia := StartTime;
FEndMedia := EndTime;
FReset := FALSE;
result := NOERROR;
finally
FPositionLock.UnLock;
end;
end;
// Resets the media times we hold
function TBCRendererPosPassThru.ResetMediaTime: HRESULT;
begin
FPositionLock.Lock;
try
FStartMedia := 0;
FEndMedia := 0;
FReset := True;
result := NOERROR;
finally
FPositionLock.UnLock;
end;
end;
{ TBCAMEvent }
function TBCAMEvent.Check: boolean;
begin
result := Wait(0);
end;
constructor TBCAMEvent.Create(ManualReset: boolean);
begin
FEvent := CreateEvent(nil, ManualReset, FALSE, nil);
end;
destructor TBCAMEvent.destroy;
begin
if FEvent <> 0 then
Assert(CloseHandle(FEvent));
inherited;
end;
procedure TBCAMEvent.Reset;
begin
ResetEvent(FEvent);
end;
procedure TBCAMEvent.SetEv;
begin
SetEvent(FEvent);
end;
function TBCAMEvent.Wait(Timeout: Cardinal): boolean;
begin
result := (WaitForSingleObject(FEvent, Timeout) = WAIT_OBJECT_0);
end;
{ TBCRenderedInputPin }
function TBCRenderedInputPin.Active: HRESULT;
begin
FAtEndOfStream := FALSE;
FCompleteNotified := FALSE;
result := inherited Active;
end;
constructor TBCRenderedInputPin.Create(ObjectName: string;
Filter: TBCBaseFilter; Lock: TBCCritSec; out hr: HRESULT;
Name: WideString);
begin
inherited Create(ObjectName, Filter, Lock, hr, Name);
FAtEndOfStream := FALSE;
FCompleteNotified := FALSE;
end;
procedure TBCRenderedInputPin.DoCompleteHandling;
begin
ASSERT(FAtEndOfStream);
if (not FCompleteNotified) then
begin
FCompleteNotified := True;
FFilter.NotifyEvent(EC_COMPLETE, S_OK, Integer(FFilter));
end;
end;
function TBCRenderedInputPin.EndFlush: HRESULT;
begin
FLock.Lock;
try
// Clean up renderer state
FAtEndOfStream := FALSE;
FCompleteNotified := FALSE;
result := inherited EndFlush;
finally
FLock.UnLock;
end;
end;
function TBCRenderedInputPin.EndOfStream: HRESULT;
var
fs: TFilterState;
begin
result := CheckStreaming;
// Do EC_COMPLETE handling for rendered pins
if ((result = S_OK) and (not FAtEndOfStream)) then
begin
FAtEndOfStream := True;
ASSERT(SUCCEEDED(FFilter.GetState(0, fs)));
if (fs = State_Running) then
DoCompleteHandling;
end;
end;
function TBCRenderedInputPin.Run(Start: TReferenceTime): HRESULT;
begin
FCompleteNotified := FALSE;
if FAtEndOfStream then DoCompleteHandling;
result := S_OK;
end;
{ TBCAMMsgEvent }
function TBCAMMsgEvent.WaitMsg(Timeout: DWord): boolean;
var
// wait for the event to be signalled, or for the
// timeout (in MS) to expire. allow SENT messages
// to be processed while we wait
Wait, StartTime: DWord;
// set the waiting period.
WaitTime: Dword;
Msg: TMsg;
Elapsed: DWord;
begin
WaitTime := Timeout;
// the timeout will eventually run down as we iterate
// processing messages. grab the start time so that
// we can calculate elapsed times.
if (WaitTime <> INFINITE) then
StartTime := timeGetTime else
StartTime := 0; // don't generate compiler hint
repeat
Wait := MsgWaitForMultipleObjects(1, FEvent, FALSE, WaitTime, QS_SENDMESSAGE);
if (Wait = WAIT_OBJECT_0 + 1) then
begin
PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE);
// If we have an explicit length of time to wait calculate
// the next wake up point - which might be now.
// If dwTimeout is INFINITE, it stays INFINITE
if (WaitTime <> INFINITE) then
begin
Elapsed := timeGetTime - StartTime;
if (Elapsed >= Timeout) then
WaitTime := 0 else // wake up with WAIT_TIMEOUT
WaitTime := Timeout - Elapsed;
end;
end
until (Wait <> WAIT_OBJECT_0 + 1);
// return True if we woke on the event handle,
// FALSE if we timed out.
result := (Wait = WAIT_OBJECT_0);
end;
{ TBCAMThread }
function TBCAMThread.CallWorker(Param: DWORD): DWORD;
begin
// lock access to the worker thread for scope of this object
FAccessLock.Lock;
try
if not ThreadExists then
begin
Result := DWORD(E_FAIL);
Exit;
end;
// set the parameter
FParam := Param;
// signal the worker thread
FEventSend.SetEv;
// wait for the completion to be signalled
FEventComplete.Wait;
// done - this is the thread's return value
Result := FReturnVal;
finally
FAccessLock.unlock;
end;
end;
function TBCAMThread.CheckRequest(Param: PDWORD): boolean;
begin
if not FEventSend.Check then
begin
Result := FALSE;
Exit;
end else
begin
if (Param <> nil) then
Param^ := FParam;
Result := True;
end;
end;
procedure TBCAMThread.Close;
var
Thread: THandle;
begin
Thread := InterlockedExchange(Integer(FThread), 0);
if BOOL(Thread) then
begin
WaitForSingleObject(Thread, INFINITE);
CloseHandle(Thread);
end;
end;
class function TBCAMThread.CoInitializeHelper: HRESULT;
var
hr: HRESULT;
hOle: LongWord;
CoInitializeEx: function(pvReserved: Pointer; coInit: Longint): HResult; stdcall;
begin
// call CoInitializeEx and tell OLE not to create a window (this
// thread probably won't dispatch messages and will hang on
// broadcast msgs o/w).
//
// If CoInitEx is not available, threads that don't call CoCreate
// aren't affected. Threads that do will have to handle the
// failure. Perhaps we should fall back to CoInitialize and risk
// hanging?
//
// older versions of ole32.dll don't have CoInitializeEx
hr := E_FAIL;
hOle := GetModuleHandle(PChar('ole32.dll'));
if (hOle <> 0) then
begin
CoInitializeEx := GetProcAddress(hOle, 'CoInitializeEx');
if (@CoInitializeEx <> nil) then
hr := CoInitializeEx(nil, COINIT_DISABLE_OLE1DDE);
end else
begin
{$IFDEF DEBUG}
// caller must load ole32.dll
DbgLog('couldn''t locate ole32.dll');
{$ENDIF}
end;
result := hr;
end;
constructor TBCAMThread.Create;
begin
// must be manual-reset for CheckRequest()
FAccessLock := TBCCritSec.Create;
FWorkerLock := TBCCritSec.Create;
FEventSend := TBCAMEvent.Create(True);
FEventComplete := TBCAMEvent.Create;
FThread := 0;
FThreadProc := nil;
end;
function TBCAMThread.Create_: boolean;
var
threadid: DWORD;
begin
FAccessLock.Lock;
try
if ThreadExists then
begin
Result := False;
Exit;
end;
FThread := CreateThread(nil, 0, @TBCAMThread.InitialThreadProc,
Self, 0, threadid);
if not BOOL(FThread) then
Result := FALSE else
Result := True;
finally
FAccessLock.Unlock;
end;
end;
destructor TBCAMThread.Destroy;
begin
Close;
FAccessLock.Free;
FWorkerLock.Free;
FEventSend.Free;
FEventComplete.Free;
inherited;
end;
function TBCAMThread.GetRequest: DWORD;
begin
FEventSend.Wait;
Result := FParam;
end;
function TBCAMThread.GetRequestHandle: THANDLE;
begin
Result := FEventSend.FEvent
end;
function TBCAMThread.GetRequestParam: DWORD;
begin
Result := FParam;
end;
function TBCAMThread.InitialThreadProc(p: Pointer): DWORD;
var
hrCoInit: HRESULT;
begin
hrCoInit := TBCAMThread.CoInitializeHelper;
{$IFDEF DEBUG}
if(FAILED(hrCoInit)) then
DbgLog('CoInitializeEx failed.');
{$ENDIF}
Result := ThreadProc;
if(SUCCEEDED(hrCoInit)) then
CoUninitialize;
end;
procedure TBCAMThread.Reply(v: DWORD);
begin
FReturnVal := v;
// The request is now complete so CheckRequest should fail from
// now on
//
// This event should be reset BEFORE we signal the client or
// the client may Set it before we reset it and we'll then
// reset it (!)
FEventSend.Reset;
// Tell the client we're finished
FEventComplete.SetEv;
end;
function TBCAMThread.ThreadExists: boolean;
begin
Result := FThread <> 0;
end;
function TBCAMThread.ThreadProc: DWord;
begin
if @FThreadProc <> nil then
Result := FThreadProc else
Result := 0
end;
{ TBCNode }
{$ifdef DEBUG}
constructor TBCNode.Create;
begin
inherited Create('List node');
end;
{$ENDIF}
{ TBCNodeCache }
procedure TBCNodeCache.AddToCache(Node: TBCNode);
begin
if (FUsed < FCacheSize) then
begin
Node.Next := FHead;
FHead := Node;
inc(FUsed);
end else
Node.Free;
end;
constructor TBCNodeCache.Create(CacheSize: Integer);
begin
FCacheSize := CacheSize;
FHead := nil;
FUsed := 0;
end;
destructor TBCNodeCache.Destroy;
var Node, Current: TBCNode;
begin
Node := FHead;
while (Node <> nil) do
begin
Current := Node;
Node := Node.Next;
Current.Free;
end;
inherited;
end;
function TBCNodeCache.RemoveFromCache: TBCNode;
var Node: TBCNode;
begin
Node := FHead;
if (Node <> nil) then
begin
FHead := Node.Next;
Dec(FUsed);
ASSERT(FUsed >= 0);
end else
ASSERT(FUsed = 0);
Result := Node;
end;
{ TBCBaseList }
function TBCBaseList.AddAfter(p: Position; List: TBCBaseList): BOOL;
var pos: Position;
begin
pos := list.GetHeadPositionI;
while(pos <> nil) do
begin
// p follows along the elements being added
p := AddAfterI(p, List.GetI(pos));
if (p = nil) then
begin
Result := FALSE;
Exit;
end;
pos := list.Next(pos);
end;
Result := True;
end;
(* Add the object after position p
p is still valid after the operation.
AddAfter(NULL,x) adds x to the start - same as AddHead
Return the position of the new object, NULL if it failed
*)
function TBCBaseList.AddAfterI(pos: Position; Obj: Pointer): Position;
var After, Node, Before: TBCNode;
begin
if (pos = nil) then
Result := AddHeadI(Obj) else
begin
(* As someone else might be furkling with the list -
Lock the critical section before continuing
*)
After := pos;
ASSERT(After <> nil);
if (After = FLast) then
Result := AddTailI(Obj) else
begin
// set pnode to point to a new node, preferably from the cache
Node := FCache.RemoveFromCache;
if (Node = nil) then
Node := TBCNode.Create;
// Check we have a valid object
if (Node = nil) then
Result := nil else
begin
(* Initialise all the CNode object
just in case it came from the cache
*)
Node.Data := Obj;
(* It is to be added to the middle of the list - there is a before
and after node. Chain it after pAfter, before pBefore.
*)
Before := After.Next;
ASSERT(Before <> nil);
// chain it in (set four pointers)
Node.Prev := After;
Node.Next := Before;
Before.Prev := Node;
After.Next := Node;
inc(FCount);
Result := Node;
end;
end;
end;
end;
function TBCBaseList.AddBefore(p: Position; List: TBCBaseList): BOOL;
var pos: Position;
begin
pos := List.GetTailPositionI;
while (pos <> nil) do
begin
// p follows along the elements being added
p := AddBeforeI(p, List.GetI(pos));
if (p = nil) then
begin
Result := FALSE;
Exit;
end;
pos := list.Prev(pos);
end;
Result := True;
end;
(* Mirror images:
Add the element or list after position p.
p is still valid after the operation.
AddBefore(NULL,x) adds x to the end - same as AddTail
*)
function TBCBaseList.AddBeforeI(pos: Position; Obj: Pointer): Position;
var
Before, Node, After: TBCNode;
begin
if (pos = nil) then
Result := AddTailI(Obj) else
begin
// set pnode to point to a new node, preferably from the cache
Before := pos;
ASSERT(Before <> nil);
if (Before = FFirst) then
Result := AddHeadI(Obj) else
begin
Node := FCache.RemoveFromCache;
if (Node = nil) then
Node := TBCNode.Create;
// Check we have a valid object */
if (Node = nil) then
Result := nil else
begin
(* Initialise all the CNode object
just in case it came from the cache
*)
Node.Data := Obj;
(* It is to be added to the middle of the list - there is a before
and after node. Chain it after pAfter, before pBefore.
*)
After := Before.Prev;
ASSERT(After <> nil);
// chain it in (set four pointers)
Node.Prev := After;
Node.Next := Before;
Before.Prev := Node;
After.Next := Node;
inc(FCount);
Result := Node;
end;
end;
end;
end;
(* Add all the elements in *pList to the head of this list.
Return True if it all worked, FALSE if it didn't.
If it fails some elements may have been added.
*)
function TBCBaseList.AddHead(List: TBCBaseList): BOOL;
var
pos: Position;
begin
(* lock the object before starting then enumerate
each entry in the source list and add them one by one to
our list (while still holding the object lock)
Lock the other list too.
To avoid reversing the list, traverse it backwards.
*)
pos := list.GetTailPositionI;
while (pos <> nil) do
begin
if (nil = AddHeadI(List.GetI(pos))) then
begin
Result := FALSE;
Exit;
end;
pos := list.Prev(pos)
end;
Result := True;
end;
(* Add this object to the head end of our list
Return the new head position.
*)
function TBCBaseList.AddHeadI(Obj: Pointer): Position;
var Node: TBCNode;
begin
(* If there is a node objects in the cache then use
that otherwise we will have to create a new one *)
Node := FCache.RemoveFromCache;
if (Node = nil) then
Node := TBCNode.Create;
// Check we have a valid object
if (Node = nil) then
begin
Result := nil;
Exit;
end;
(* Initialise all the CNode object
just in case it came from the cache
*)
Node.Data := Obj;
// chain it in (set four pointers)
Node.Prev := nil;
Node.Next := FFirst;
if (FFirst = nil) then
FLast := Node;
FFirst.Prev := Node;
FFirst := Node;
inc(FCount);
Result := Node;
end;
(* Add all the elements in *pList to the tail of this list.
Return True if it all worked, FALSE if it didn't.
If it fails some elements may have been added.
*)
function TBCBaseList.AddTail(List: TBCBaseList): boolean;
var pos: Position;
begin
(* lock the object before starting then enumerate
each entry in the source list and add them one by one to
our list (while still holding the object lock)
Lock the other list too.
*)
Result := false;
pos := List.GetHeadPositionI;
while (pos <> nil) do
if (nil = AddTailI(List.GetNextI(pos))) then
Exit;
Result := True;
end;
(* Add this object to the tail end of our list
Return the new tail position.
*)
function TBCBaseList.AddTailI(Obj: Pointer): Position;
var
Node: TBCNode;
begin
// Lock the critical section before continuing
// ASSERT(pObject); // NULL pointers in the list are allowed.
(* If there is a node objects in the cache then use
that otherwise we will have to create a new one *)
Node := FCache.RemoveFromCache;
if (Node = nil) then
Node := TBCNode.Create;
// Check we have a valid object
if Node = nil then // HG: out of memory ???
begin
Result := nil;
Exit;
end;
(* Initialise all the CNode object
just in case it came from the cache
*)
Node.Data := Obj;
Node.Next := nil;
Node.Prev := FLast;
if (FLast = nil) then
FFirst := Node;
FLast.Next := Node;
(* Set the new last node pointer and also increment the number
of list entries, the critical section is unlocked when we
exit the function
*)
FLast := Node;
inc(FCount);
Result := Node;
end;
(* Constructor calls a separate initialisation function that
creates a node cache, optionally creates a lock object
and optionally creates a signaling object.
By default we create a locking object, a DEFAULTCACHE sized
cache but no event object so the list cannot be used in calls
to WaitForSingleObject
*)
constructor TBCBaseList.Create(Name: string; Items: Integer = DEFAULTCACHE);
begin
{$ifdef DEBUG}
inherited Create(Name);
{$endif}
FFirst := nil;
FLast := nil;
FCount := 0;
FCache := TBCNodeCache.Create(Items);
end;
(* The destructor enumerates all the node objects in the list and
in the cache deleting each in turn. We do not do any processing
on the objects that the list holds (i.e. points to) so if they
represent interfaces for example the creator of the list should
ensure that each of them is released before deleting us
*)
destructor TBCBaseList.Destroy;
begin
RemoveAll;
FCache.Free;
inherited;
end;
(* Return the first position in the list which holds the given pointer.
Return NULL if it's not found.
*)
function TBCBaseList.FindI(Obj: Pointer): Position;
begin
Result := GetHeadPositionI;
while (Result <> nil) do
begin
if (GetI(Result) = Obj) then Exit;
Result := Next(Result);
end;
end;
(* Get the number of objects in the list,
Get the lock before accessing the count.
Locking may not be entirely necessary but it has the side effect
of making sure that all operations are complete before we get it.
So for example if a list is being added to this list then that
will have completed in full before we continue rather than seeing
an intermediate albeit valid state
*)
function TBCBaseList.GetCountI: Integer;
begin
Result := FCount;
end;
(* Return a position enumerator for the entire list.
A position enumerator is a pointer to a node object cast to a
transparent type so all we do is return the head/tail node
pointer in the list.
WARNING because the position is a pointer to a node there is
an implicit assumption for users a the list class that after
deleting an object from the list that any other position
enumerators that you have may be invalid (since the node
may be gone).
*)
function TBCBaseList.GetHeadPositionI: Position;
begin
result := Position(FFirst);
end;
(* Return the object at p.
Asking for the object at NULL ASSERTs then returns NULL
The object is NOT locked. The list is not being changed
in any way. If another thread is busy deleting the object
then locking would only result in a change from one bad
behaviour to another.
*)
function TBCBaseList.GetI(p: Position): Pointer;
begin
if (p = nil) then
Result := nil else
Result := TBCNode(p).Data;
end;
(* Return the object at rp, update rp to the next object from
the list or NULL if you have moved over the last object.
You may still call this function once we return NULL but
we will continue to return a NULL position value
*)
function TBCBaseList.GetNextI(var rp: Position): Pointer;
var
pn: TBCNode;
begin
// have we reached the end of the list
if (rp = nil) then
Result := nil else
begin
// Lock the object before continuing
// Copy the original position then step on
pn := rp;
ASSERT(pn <> nil);
rp := Position(pn.Next);
// Get the object at the original position from the list
Result := pn.Data;
end;
end;
function TBCBaseList.GetTailPositionI: Position;
begin
Result := Position(FLast);
end;
(* Mirror image of MoveToTail:
Split self before position p in self.
Retain in self the head portion of the original self
Add the tail portion to the start (i.e. head) of *pList
Return True if it all worked, FALSE if it didn't.
e.g.
foo->MoveToHead(foo->GetTailPosition(), bar);
moves one element from the tail of foo to the head of bar
foo->MoveToHead(NULL, bar);
is a no-op
foo->MoveToHead(foo->GetHeadPosition, bar);
concatenates foo onto the start of bar and empties foo.
*)
function TBCBaseList.MoveToHead(pos: Position; List: TBCBaseList): boolean;
var
p: TBCNode;
m: Integer;
begin
// See the comments on the algorithm in MoveToTail
if (pos = nil) then
Result := True else // no-op. Eliminates special cases later.
begin
// Make cMove the number of nodes to move
p := pos;
m := 0; // number of nodes to move
while(p <> nil) do
begin
p := p.Next;
inc(m);
end;
// Join the two chains together
if (List.FFirst <> nil) then
List.FFirst.Prev := FLast;
if (FLast <> nil) then
FLast.Next := List.FFirst;
// set first and last pointers
p := pos;
if (List.FLast = nil) then
List.FLast := FLast;
FLast := p.Prev;
if (FLast = nil) then
FFirst := nil;
List.FFirst := p;
// Break the chain after p to create the new pieces
if (FLast <> nil) then
FLast.Next := nil;
p.Prev := nil;
// Adjust the counts
dec(FCount, m);
inc(List.FCount, m);
Result := True;
end;
end;
(* Split self after position p in self
Retain as self the tail portion of the original self
Add the head portion to the tail end of *pList
Return True if it all worked, FALSE if it didn't.
e.g.
foo->MoveToTail(foo->GetHeadPosition(), bar);
moves one element from the head of foo to the tail of bar
foo->MoveToTail(NULL, bar);
is a no-op
foo->MoveToTail(foo->GetTailPosition, bar);
concatenates foo onto the end of bar and empties foo.
A better, except excessively long name might be
MoveElementsFromHeadThroughPositionToOtherTail
*)
function TBCBaseList.MoveToTail(pos: Position; List: TBCBaseList): boolean;
var
p: TBCNode;
m: Integer;
begin
(* Algorithm:
Note that the elements (including their order) in the concatenation
of *pList to the head of self is invariant.
1. Count elements to be moved
2. Join *pList onto the head of this to make one long chain
3. Set first/Last pointers in self and *pList
4. Break the chain at the new place
5. Adjust counts
6. Set/Reset any events
*)
if (pos = nil) then
Result := True else // no-op. Eliminates special cases later.
begin
// Make m the number of nodes to move
p := pos;
m := 0; // number of nodes to move
while(p <> nil) do
begin
p := p.Prev;
inc(m);
end;
// Join the two chains together
if (List.FLast <> nil) then
List.FLast.Next := FFirst;
if (FFirst <> nil) then
FFirst.Prev := List.FLast;
// set first and last pointers
p := pos;
if (List.FFirst = nil) then
List.FFirst := FFirst;
FFirst := p.Next;
if (FFirst = nil) then
FLast := nil;
List.FLast := p;
// Break the chain after p to create the new pieces
if (FFirst <> nil) then
FFirst.Prev := nil;
p.Next := nil;
// Adjust the counts
dec(FCount, m);
inc(List.FCount, m);
Result := True;
end;
end;
function TBCBaseList.Next(pos: Position): Position;
begin
if (pos = nil) then
Result := Position(FFirst) else
Result := Position(TBCNode(pos).Next);
end;
function TBCBaseList.Prev(pos: Position): Position;
begin
if (pos = nil) then
Result := Position(FLast) else
Result := Position(TBCNode(pos).Prev);
end;
(* Remove all the nodes from the list but don't do anything
with the objects that each node looks after (this is the
responsibility of the creator).
Aa a last act we reset the signalling event
(if available) to indicate to clients that the list
does not have any entries in it.
*)
procedure TBCBaseList.RemoveAll;
var pn, op: TBCNode;
begin
(* Free up all the CNode objects NOTE we don't bother putting the
deleted nodes into the cache as this method is only really called
in serious times of change such as when we are being deleted at
which point the cache will be deleted anyway *)
pn := FFirst;
while (pn <> nil) do
begin
op := pn;
pn := pn.Next;
op.Free;
end;
(* Reset the object count and the list pointers *)
FCount := 0;
FFirst := nil;
FLast := nil;
end;
(* Remove the first node in the list (deletes the pointer to its object
from the list, does not free the object itself).
Return the pointer to its object or NULL if empty
*)
function TBCBaseList.RemoveHeadI: Pointer;
begin
(* All we do is get the head position and ask for that to be deleted.
We could special case this since some of the code path checking
in Remove() is redundant as we know there is no previous
node for example but it seems to gain little over the
added complexity
*)
Result := RemoveI(FFirst);
end;
(* Remove the pointer to the object in this position from the list.
Deal with all the chain pointers
Return a pointer to the object removed from the list.
The node object that is freed as a result
of this operation is added to the node cache where
it can be used again.
Remove(NULL) is a harmless no-op - but probably is a wart.
*)
function TBCBaseList.RemoveI(pos: Position): Pointer;
var
Current, Node: TBCNode;
begin
(* Lock the critical section before continuing *)
if (pos = nil) then
Result := nil else
begin
Current := pos;
ASSERT(Current <> nil);
// Update the previous node
Node := Current.Prev;
if (Node = nil) then
FFirst := Current.Next else
Node.Next := Current.Next;
// Update the following node
Node := Current.Next;
if (Node = nil) then
FLast := Current.Prev else
Node.Prev := Current.Prev;
// Get the object this node was looking after */
Result := Current.Data;
// ASSERT(pObject != NULL); // NULL pointers in the list are allowed.
(* Try and add the node object to the cache -
a NULL return code from the cache means we ran out of room.
The cache size is fixed by a constructor argument when the
list is created and defaults to DEFAULTCACHE.
This means that the cache will have room for this many
node objects. So if you have a list of media samples
and you know there will never be more than five active at
any given time of them for example then override the default
constructor
*)
FCache.AddToCache(Current);
// If the list is empty then reset the list event
Dec(FCount);
ASSERT(FCount >= 0);
end;
end;
(* Remove the last node in the list (deletes the pointer to its object
from the list, does not free the object itself).
Return the pointer to its object or NULL if empty
*)
function TBCBaseList.RemoveTailI: Pointer;
begin
(* All we do is get the tail position and ask for that to be deleted.
We could special case this since some of the code path checking
in Remove() is redundant as we know there is no previous
node for example but it seems to gain little over the
added complexity
*)
Result := RemoveI(FLast);
end;
(* Reverse the order of the [pointers to] objects in slef *)
procedure TBCBaseList.Reverse;
var p, q: TBCNode;
begin
(* algorithm:
The obvious booby trap is that you flip pointers around and lose
addressability to the node that you are going to process next.
The easy way to avoid this is do do one chain at a time.
Run along the forward chain,
For each node, set the reverse pointer to the one ahead of us.
The reverse chain is now a copy of the old forward chain, including
the NULL termination.
Run along the reverse chain (i.e. old forward chain again)
For each node set the forward pointer of the node ahead to point back
to the one we're standing on.
The first node needs special treatment,
it's new forward pointer is NULL.
Finally set the First/Last pointers
*)
// Yes we COULD use a traverse, but it would look funny!
p := FFirst;
while (p <> nil) do
begin
q := p.Next;
p.Next := p.Prev;
p.Prev := q;
p := q;
end;
p := FFirst;
FFirst := FLast;
FLast := p;
end;
{ TBCSource }
function TBCSource.AddPin(Stream: TBCSourceStream): HRESULT;
begin
FStateLock.Lock;
try
inc(FPins);
ReallocMem(FStreams, FPins * SizeOf(TBCSourceStream));
TStreamArray(FStreams)[FPins-1] := Stream;
Result := S_OK;
finally
FStateLock.UnLock;
end;
end;
// milenko start (delphi 5 doesn't IInterface - changed IInterface to IUnknown)
constructor TBCSource.Create(const Name: string; unk: IUnknown;
// milenko end
const clsid: TGUID; out hr: HRESULT);
begin
FStateLock := TBCCritSec.Create;
// nev: changed 02/17/04
inherited Create(Name, unk, FStateLock, clsid, hr);
FPins := 0;
FStreams := nil;
end;
// milenko start (delphi 5 doesn't IInterface - changed IInterface to IUnknown)
constructor TBCSource.Create(const Name: string; unk: IUnknown;
// milenko end
const clsid: TGUID);
begin
FStateLock := TBCCritSec.Create;
inherited Create(Name, unk, FStateLock, clsid);
FPins := 0;
FStreams := nil;
end;
destructor TBCSource.Destroy;
begin
// Free our pins and pin array
while (FPins <> 0) do
// deleting the pins causes them to be removed from the array...
TStreamArray(FStreams)[FPins - 1].Free;
if Assigned(FStreams) then FreeMem(FStreams);
ASSERT(FPins = 0);
inherited;
end;
// Set Pin to the IPin that has the id Id.
// or to nil if the Id cannot be matched.
function TBCSource.FindPin(Id: PWideChar; out Pin: IPin): HRESULT;
var
i : integer;
Code : integer;
begin
// The -1 undoes the +1 in QueryId and ensures that totally invalid
// strings (for which WstrToInt delivers 0) give a deliver a NULL pin.
// DCoder (1. Nov 2003)
// StrToInt throws EConvertError Exceptions if
// a Filter calls FindPin with a String instead of a Number in ID.
// To be sure, capture the Error Handling by using Val and call
// the inherited function if Val fails.
Val(Id,i,Code);
if Code = 0 then
begin
i := i - 1;
Pin := GetPin(i);
if (Pin <> nil) then
Result := NOERROR else
Result := VFW_E_NOT_FOUND;
end else Result := inherited FindPin(Id,Pin);
end;
// return the number of the pin with this IPin or -1 if none
function TBCSource.FindPinNumber(Pin: IPin): Integer;
begin
for Result := 0 to FPins - 1 do
if (IPin(TStreamArray(FStreams)[Result]) = Pin) then
Exit;
Result := -1;
end;
// Return a non-addref'd pointer to pin n
// needed by CBaseFilter
function TBCSource.GetPin(n: Integer): TBCBasePin;
begin
FStateLock.Lock;
try
// n must be in the range 0..m_iPins-1
// if m_iPins>n && n>=0 it follows that m_iPins>0
// which is what used to be checked (i.e. checking that we have a pin)
if ((n >= 0) and (n < FPins)) then
begin
ASSERT(TStreamArray(FStreams)[n] <> nil);
Result := TStreamArray(FStreams)[n];
end else
Result := nil;
finally
FStateLock.UnLock;
end;
end;
// Returns the number of pins this filter has
function TBCSource.GetPinCount: Integer;
begin
FStateLock.Lock;
try
Result := FPins;
finally
FStateLock.UnLock;
end;
end;
function TBCSource.RemovePin(Stream: TBCSourceStream): HRESULT;
var i, j: Integer;
begin
for i := 0 to FPins - 1 do
begin
if (TStreamArray(FStreams)[i] = Stream) then
begin
if (FPins = 1) then
begin
FreeMem(FStreams);
FStreams := nil;
end else
begin
// no need to reallocate
j := i + 1;
while (j < FPins) do
begin
TStreamArray(FStreams)[j-1] := TStreamArray(FStreams)[j];
inc(j);
end;
end;
dec(FPins);
Result := S_OK;
Exit;
end;
end;
Result := S_FALSE;
end;
{ TBCSourceStream }
// The pin is active - start up the worker thread
function TBCSourceStream.Active: HRESULT;
begin
FFilter.FStateLock.Lock;
try
if (FFilter.IsActive) then
begin
Result := S_FALSE; // succeeded, but did not allocate resources (they already exist...)
Exit;
end;
// do nothing if not connected - its ok not to connect to
// all pins of a source filter
if not IsConnected then
begin
Result := NOERROR;
Exit;
end;
Result := inherited Active;
if FAILED(Result) then
Exit;
ASSERT(not FThread.ThreadExists);
// start the thread
if not FThread.Create_ then
begin
Result := E_FAIL;
Exit;
end;
// Tell thread to initialize. If OnThreadCreate Fails, so does this.
Result := Init;
if FAILED(Result) then
Exit;
Result := Pause;
finally
FFilter.FStateLock.UnLock;
end;
end;
// Do we support this type? Provides the default support for 1 type.
function TBCSourceStream.CheckMediaType(MediaType: PAMMediaType): HRESULT;
var mt: TAMMediaType;
pmt: PAMMediaType;
begin
FFilter.FStateLock.Lock;
try
pmt := @mt;
GetMediaType(pmt);
if TBCMediaType(pmt).Equal(MediaType) then
Result := NOERROR else
Result := E_FAIL;
finally
FFilter.FStateLock.UnLock;
end;
end;
function TBCSourceStream.CheckRequest(var com: TThreadCommand): boolean;
begin
Result := FThread.CheckRequest(@Com);
end;
// increments the number of pins present on the filter
constructor TBCSourceStream.Create(const ObjectName: string;
out hr: HRESULT; Filter: TBCSource; const Name: WideString);
begin
FThread := TBCAMThread.Create;
FThread.FThreadProc := ThreadProc;
inherited Create(ObjectName, Filter, Filter.FStateLock, hr, Name);
FFilter := Filter;
hr := FFilter.AddPin(Self);
end;
// Decrements the number of pins on this filter
destructor TBCSourceStream.Destroy;
begin
FFilter.RemovePin(Self);
inherited;
FThread.Free;
end;
// Grabs a buffer and calls the users processing function.
// Overridable, so that different delivery styles can be catered for.
function TBCSourceStream.DoBufferProcessingLoop: HRESULT;
var
com: TThreadCommand;
Sample: IMediaSample;
begin
OnThreadStartPlay;
repeat
begin
while not CheckRequest(com) do
begin
Result := GetDeliveryBuffer(Sample, nil, nil, 0);
if FAILED(result) then
begin
Sleep(1);
continue; // go round again. Perhaps the error will go away
// or the allocator is decommited & we will be asked to
// exit soon.
end;
// Virtual function user will override.
Result := FillBuffer(Sample);
if (Result = S_OK) then
begin
Result := Deliver(Sample);
Sample := nil;
// downstream filter returns S_FALSE if it wants us to
// stop or an error if it's reporting an error.
if (Result <> S_OK) then
begin
{$IFDEF DEBUG}
DbgLog(format('Deliver() returned %08x; stopping', [Result]));
{$ENDIF}
Result := S_OK;
Exit;
end;
end else
if (Result = S_FALSE) then
begin
// derived class wants us to stop pushing data
Sample := nil;
DeliverEndOfStream;
Result := S_OK;
Exit;
end else
begin
// derived class encountered an error
Sample := nil;
{$IFDEF DEBUG}
DbgLog(format('Error %08lX from FillBuffer!!!', [Result]));
{$ENDIF}
DeliverEndOfStream;
FFilter.NotifyEvent(EC_ERRORABORT, Result, 0);
Exit;
end;
// all paths release the sample
end;
// For all commands sent to us there must be a Reply call!
if ((com = CMD_RUN) or (com = CMD_PAUSE)) then
FThread.Reply(NOERROR) else
if (com <> CMD_STOP) then
begin
Fthread.Reply(DWORD(E_UNEXPECTED));
{$IFDEF DEBUG}
DbgLog('Unexpected command!!!');
{$ENDIF}
end
end until (com = CMD_STOP);
Result := S_FALSE;
end;
function TBCSourceStream.Exit_: HRESULT;
begin
Result := FThread.CallWorker(Ord(CMD_EXIT));
end;
function TBCSourceStream.GetMediaType(MediaType: PAMMediaType): HRESULT;
begin
Result := E_UNEXPECTED;
end;
function TBCSourceStream.GetMediaType(Position: integer;
out MediaType: PAMMediaType): HRESULT;
begin
// By default we support only one type
// Position indexes are 0-n
FFilter.FStateLock.Lock;
try
if (Position = 0) then
Result := GetMediaType(MediaType)
else
if (Position > 0) then
Result := VFW_S_NO_MORE_ITEMS else
Result := E_INVALIDARG;
finally
FFilter.FStateLock.UnLock;
end;
end;
function TBCSourceStream.GetRequest: TThreadCommand;
begin
Result := TThreadCommand(FThread.GetRequest);
end;
// Pin is inactive - shut down the worker thread
// Waits for the worker to exit before returning.
function TBCSourceStream.Inactive: HRESULT;
begin
FFilter.FStateLock.Lock;
try
// do nothing if not connected - its ok not to connect to
// all pins of a source filter
if not IsConnected then
begin
Result := NOERROR;
Exit;
end;
// !!! need to do this before trying to stop the thread, because
// we may be stuck waiting for our own allocator!!!
Result := inherited Inactive; // call this first to Decommit the allocator
if FAILED(Result) then
Exit;
if FThread.ThreadExists then
begin
Result := Stop;
if FAILED(Result) then
Exit;
Result := Exit_;
if FAILED(Result) then
Exit;
FThread.Close; // Wait for the thread to exit, then tidy up.
end;
Result := NOERROR;
finally
FFilter.FStateLock.UnLock;
end;
end;
function TBCSourceStream.Init: HRESULT;
begin
Result := FThread.CallWorker(Ord(CMD_INIT));
end;
function TBCSourceStream.OnThreadCreate: HRESULT;
begin
Result := NOERROR;
end;
function TBCSourceStream.OnThreadDestroy: HRESULT;
begin
Result := NOERROR;
end;
function TBCSourceStream.OnThreadStartPlay: HRESULT;
begin
Result := NOERROR;
end;
function TBCSourceStream.Pause: HRESULT;
begin
Result := FThread.CallWorker(Ord(CMD_PAUSE));
end;
// Set Id to point to a CoTaskMemAlloc'd
function TBCSourceStream.QueryId(out id: PWideChar): HRESULT;
var
i: Integer;
begin
// We give the pins id's which are 1,2,...
// FindPinNumber returns -1 for an invalid pin
i := 1 + FFilter.FindPinNumber(Self);
if (i < 1) then
Result := VFW_E_NOT_FOUND else
Result := AMGetWideString(IntToStr(i), id);
end;
function TBCSourceStream.Run: HRESULT;
begin
Result := FThread.CallWorker(Ord(CMD_RUN));
end;
function TBCSourceStream.Stop: HRESULT;
begin
Result := FThread.CallWorker(Ord(CMD_STOP));
end;
// When this returns the thread exits
// Return codes > 0 indicate an error occured
function TBCSourceStream.ThreadProc: DWORD;
var
com, cmd: TThreadCommand;
begin
repeat
com := GetRequest;
if (com <> CMD_INIT) then
begin
{$IFDEF DEBUG}
DbgLog(self, 'Thread expected init command');
{$ENDIF}
FThread.Reply(DWORD(E_UNEXPECTED));
end;
until (com = CMD_INIT);
{$IFDEF DEBUG}
DbgLog(self, 'Worker thread initializing');
{$ENDIF}
Result := OnThreadCreate; // perform set up tasks
if FAILED(Result) then
begin
{$IFDEF DEBUG}
DbgLog(Self, 'OnThreadCreate failed. Aborting thread.');
{$ENDIF}
OnThreadDestroy();
FThread.Reply(Result); // send failed return code from OnThreadCreate
Result := 1;
Exit;
end;
// Initialisation suceeded
FThread.Reply(NOERROR);
repeat
cmd := GetRequest;
// nev: changed 02/17/04
// "repeat..until false" ensures, that if cmd = CMD_RUN
// the next executing block will be CMD_PAUSE handler block.
// This corresponds to the original C "switch" functionality
repeat
case cmd of
CMD_EXIT, CMD_STOP:
begin
FThread.Reply(NOERROR);
Break;
end;
CMD_RUN:
begin
{$IFDEF DEBUG}
DbgLog(Self, 'CMD_RUN received before a CMD_PAUSE???');
{$ENDIF}
// !!! fall through???
cmd := CMD_PAUSE;
end;
CMD_PAUSE:
begin
FThread.Reply(NOERROR);
DoBufferProcessingLoop;
Break;
end;
else
{$IFDEF DEBUG}
DbgLog(self, format('Unknown command %d received!', [Integer(cmd)]));
{$ENDIF}
FThread.Reply(DWORD(E_NOTIMPL));
Break;
end;
until False;
until (cmd = CMD_EXIT);
Result := OnThreadDestroy; // tidy up.
if FAILED(Result) then
begin
{$IFDEF DEBUG}
DbgLog(self, 'OnThreadDestroy failed. Exiting thread.');
{$ENDIF}
Result := 1;
Exit;
end;
{$IFDEF DEBUG}
DbgLog(Self, 'worker thread exiting');
{$ENDIF}
Result := 0;
end;
function TimeKillSynchronousFlagAvailable: Boolean;
var
osverinfo: TOSVERSIONINFO;
begin
osverinfo.dwOSVersionInfoSize := sizeof(osverinfo);
if GetVersionEx(osverinfo) then
// Windows XP's major version is 5 and its' minor version is 1.
// timeSetEvent() started supporting the TIME_KILL_SYNCHRONOUS flag
// in Windows XP.
Result := (osverinfo.dwMajorVersion > 5) or
((osverinfo.dwMajorVersion = 5) and (osverinfo.dwMinorVersion >= 1))
else
Result := False;
end;
function CompatibleTimeSetEvent(Delay, Resolution: UINT;
TimeProc: TFNTimeCallBack; User: DWORD; Event: UINT): MMResult;
// milenko start (replaced with global variables)
//const
//{$IFOPT J-}
//{$DEFINE ResetJ}
//{$J+}
//{$ENDIF}
// IsCheckedVersion: Bool = False;
// IsTimeKillSynchronousFlagAvailable: Bool = False;
//{$IFDEF ResetJ}
//{$J-}
//{$UNDEF ResetJ}
//{$ENDIF}
const
TIME_KILL_SYNCHRONOUS = $100;
// Milenko end
var
Event_: UINT;
begin
Event_ := Event;
// ??? TIME_KILL_SYNCHRONOUS flag is defined in MMSystem for XP:
// need to check that D7 unit for proper compilation flag
// Milenko start (no need for "ifdef xp" in delphi)
// {$IFDEF XP}
if not IsCheckedVersion then
begin
IsTimeKillSynchronousFlagAvailable := TimeKillSynchronousFlagAvailable;
IsCheckedVersion := true;
end;
if IsTimeKillSynchronousFlagAvailable then
Event_ := Event_ or TIME_KILL_SYNCHRONOUS;
// {$ENDIF}
// Milenko end
Result := timeSetEvent(Delay, Resolution, TimeProc, User, Event_);
end;
// ??? See Measure.h for Msr_??? definition
// milenko start (only needed with PERF)
{$IFDEF PERF}
type
TIncidentRec = packed record
Name: String[255];
end;
TIncidentLog = packed record
Id: Integer;
Time: TReferenceTime;
Data: Integer;
Note: String[10];
end;
var
Incidents: array of TIncidentRec;
IncidentsLog: array of TIncidentLog;
{$ENDIF}
// milenko end
function MSR_REGISTER(s: String): Integer;
// milenko start (only needed with PERF)
{$IFDEF PERF}
var
k: Integer;
{$ENDIF}
// milenko end
begin
// milenko start (only needed with PERF)
{$IFDEF PERF}
k := Length(Incidents) + 1;
SetLength(Incidents, k);
Incidents[k-1].Name := Copy(s, 0, 255);
Result := k-1;
{$ELSE}
Result := 0;
{$ENDIF}
// milenko end
end;
procedure MSR_START(Id_: Integer);
{$IFDEF PERF}
var
k: Integer;
{$ENDIF}
begin
{$IFDEF PERF}
Assert((Id_>=0) and (Id_<Length(Incidents)));
k := Length(IncidentsLog) + 1;
SetLength(IncidentsLog, k);
with IncidentsLog[k-1] do
begin
Id := Id_;
Time := timeGetTime;
Data := 0;
Note := Copy('START', 0, 10);
end;
{$ENDIF}
end;
procedure MSR_STOP(Id_: Integer);
{$IFDEF PERF}
var
k: Integer;
{$ENDIF}
begin
{$IFDEF PERF}
Assert((Id_>=0) and (Id_<Length(Incidents)));
k := Length(IncidentsLog) + 1;
SetLength(IncidentsLog, k);
with IncidentsLog[k-1] do
begin
Id := Id_;
Time := timeGetTime;
Data := 0;
Note := Copy('STOP', 0, 10);
end;
{$ENDIF}
end;
procedure MSR_INTEGER(Id_, i: Integer);
{$IFDEF PERF}
var
k: Integer;
{$ENDIF}
begin
{$IFDEF PERF}
Assert((Id_>=0) and (Id_<Length(Incidents)));
k := Length(IncidentsLog) + 1;
SetLength(IncidentsLog, k);
with IncidentsLog[k-1] do
begin
Id := Id_;
Time := timeGetTime;
Data := i;
Note := Copy('START', 0, 10);
end;
{$ENDIF}
end;
// #define DO_MOVING_AVG(avg,obs) (avg = (1024*obs + (AVGPERIOD-1)*avg)/AVGPERIOD)
procedure DO_MOVING_AVG(var avg, obs: Integer);
begin
avg := (1024 * obs + (AVGPERIOD - 1) * avg) div AVGPERIOD;
end;
// Helper function for clamping time differences
function TimeDiff(rt: TReferenceTime): Integer;
begin
if (rt < -(50 * UNITS)) then
Result := -(50 * UNITS)
else
if (rt > 50 * UNITS) then
Result := 50 * UNITS
else
Result := Integer(rt);
end;
// Implements the CBaseRenderer class
constructor TBCBaseRenderer.Create(RendererClass: TGUID; Name: PChar;
Unk: IUnknown; hr: HResult);
begin
FInterfaceLock := TBCCritSec.Create;
FRendererLock := TBCCritSec.Create;
FObjectCreationLock := TBCCritSec.Create;
inherited Create(Name, Unk, FInterfaceLock, RendererClass);
FCompleteEvent := TBCAMEvent.Create(True);
FRenderEvent := TBCAMEvent.Create(True);
FAbort := False;
FPosition := nil;
FThreadSignal := TBCAMEvent.Create(True);
FIsStreaming := False;
FIsEOS := False;
FIsEOSDelivered := False;
FMediaSample := nil;
FAdvisedCookie := 0;
FQSink := nil;
FInputPin := nil;
FRepaintStatus := True;
FSignalTime := 0;
FInReceive := False;
FEndOfStreamTimer := 0;
Ready;
{$IFDEF PERF}
FBaseStamp := MSR_REGISTER('BaseRenderer: sample time stamp');
FBaseRenderTime := MSR_REGISTER('BaseRenderer: draw time(msec)');
FBaseAccuracy := MSR_REGISTER('BaseRenderer: Accuracy(msec)');
{$ENDIF}
end;
// Delete the dynamically allocated IMediaPosition and IMediaSeeking helper
// object. The object is created when somebody queries us. These are standard
// control interfaces for seeking and setting start/stop positions and rates.
// We will probably also have made an input pin based on CRendererInputPin
// that has to be deleted, it's created when an enumerator calls our GetPin
destructor TBCBaseRenderer.Destroy;
begin
Assert(not FIsStreaming);
Assert(FEndOfStreamTimer = 0);
StopStreaming;
ClearPendingSample;
// Delete any IMediaPosition implementation
if Assigned(FPosition) then
FreeAndNil(FPosition);
// Delete any input pin created
if Assigned(FInputPin) then
FreeAndNil(FInputPin);
// Release any Quality sink
Assert(FQSink = nil);
// Release critical sections objects
// ??? will be deleted by the parent class destroy FreeAndNil(FInterfaceLock);
FreeAndNil(FRendererLock);
FreeAndNil(FObjectCreationLock);
FreeAndNil(FCompleteEvent);
FreeAndNil(FRenderEvent);
FreeAndNil(FThreadSignal);
inherited Destroy;
end;
// This returns the IMediaPosition and IMediaSeeking interfaces
function TBCBaseRenderer.GetMediaPositionInterface(IID: TGUID;
out Obj): HResult;
var
hr: HResult;
begin
FObjectCreationLock.Lock;
try
if Assigned(FPosition) then
begin
// Milenko start
// Result := FPosition.QueryInterface(IID, Obj);
Result := FPosition.NonDelegatingQueryInterface(IID, Obj);
// Milenko end
Exit;
end;
hr := NOERROR;
// Create implementation of this dynamically since sometimes we may
// never try and do a seek. The helper object implements a position
// control interface (IMediaPosition) which in fact simply takes the
// calls normally from the filter graph and passes them upstream
//hr := CreatePosPassThru(GetOwner, False, GetPin(0), FPosition);
FPosition := TBCRendererPosPassThru.Create('Renderer TBCPosPassThru',
Inherited GetOwner, hr, GetPin(0));
if (FPosition = nil) then
begin
Result := E_OUTOFMEMORY;
Exit;
end;
if (Failed(hr)) then
begin
FreeAndNil(FPosition);
Result := E_NOINTERFACE;
Exit;
end;
// milenko start (needed or the class will destroy itself. Disadvantage=Destructor is not called)
// Solution is to keep FPosition alive without adding a Reference Count to it. But how???
FPosition._AddRef;
// milenko end
Result := GetMediaPositionInterface(IID, Obj);
finally
FObjectCreationLock.UnLock;
end;
end;
// milenko start (workaround for destructor issue with FPosition)
function TBCBaseRenderer.JoinFilterGraph(pGraph: IFilterGraph;
pName: PWideChar): HRESULT;
begin
if (pGraph = nil) and (FPosition <> nil) then
begin
FPosition._Release;
Pointer(FPosition) := nil;
end;
Result := inherited JoinFilterGraph(pGraph,pName);
end;
// milenko end
// Overriden to say what interfaces we support and where
function TBCBaseRenderer.NonDelegatingQueryInterface(const IID: TGUID;
out Obj): HResult;
begin
// Milenko start (removed unnessacery code)
// Do we have this interface
if IsEqualGUID(IID, IID_IMediaPosition) or IsEqualGUID(IID, IID_IMediaSeeking)
then Result := GetMediaPositionInterface(IID,Obj)
else Result := inherited NonDelegatingQueryInterface(IID, Obj);
// Milenko end
end;
// This is called whenever we change states, we have a manual reset event that
// is signalled whenever we don't won't the source filter thread to wait in us
// (such as in a stopped state) and likewise is not signalled whenever it can
// wait (during paused and running) this function sets or resets the thread
// event. The event is used to stop source filter threads waiting in Receive
function TBCBaseRenderer.SourceThreadCanWait(CanWait: Boolean): HResult;
begin
if CanWait then
FThreadSignal.Reset
else
FThreadSignal.SetEv;
Result := NOERROR;
end;
{$IFDEF DEBUG}
// Dump the current renderer state to the debug terminal. The hardest part of
// the renderer is the window where we unlock everything to wait for a clock
// to signal it is time to draw or for the application to cancel everything
// by stopping the filter. If we get things wrong we can leave the thread in
// WaitForRenderTime with no way for it to ever get out and we will deadlock
procedure TBCBaseRenderer.DisplayRendererState;
var
bSignalled, bFlushing: Boolean;
CurrentTime, StartTime, EndTime, Offset, Wait: TReferenceTime;
function RT_in_Millisecs(rt: TReferenceTime): Int64;
begin
Result := rt div 10000;
end;
begin
DbgLog(Self, 'Timed out in WaitForRenderTime');
// No way should this be signalled at this point
bSignalled := FThreadSignal.Check;
DbgLog(Self, Format('Signal sanity check %d', [Byte(bSignalled)]));
// Now output the current renderer state variables
DbgLog(Self, Format('Filter state %d', [Ord(FState)]));
DbgLog(Self, Format('Abort flag %d', [Byte(FAbort)]));
DbgLog(Self, Format('Streaming flag %d', [Byte(FIsStreaming)]));
DbgLog(Self, Format('Clock advise link %d', [FAdvisedCookie]));
// DbgLog(Self, Format('Current media sample %x', [FMediaSample]));
DbgLog(Self, Format('EOS signalled %d', [Byte(FIsEOS)]));
DbgLog(Self, Format('EOS delivered %d', [Byte(FIsEOSDelivered)]));
DbgLog(Self, Format('Repaint status %d', [Byte(FRepaintStatus)]));
// Output the delayed end of stream timer information
DbgLog(Self, Format('End of stream timer %x', [FEndOfStreamTimer]));
// ??? convert reftime to str
// DbgLog((LOG_TIMING, 1, TEXT("Deliver time %s"),CDisp((LONGLONG)FSignalTime)));
DbgLog(Self, Format('Deliver time %d', [FSignalTime]));
// Should never timeout during a flushing state
bFlushing := FInputPin.IsFlushing;
DbgLog(Self, Format('Flushing sanity check %d', [Byte(bFlushing)]));
// Display the time we were told to start at
// ??? DbgLog((LOG_TIMING, 1, TEXT("Last run time %s"),CDisp((LONGLONG)m_tStart.m_time)));
DbgLog(Self, Format('Last run time %d', [FStart]));
// Have we got a reference clock
if (FClock = nil) then
Exit;
// Get the current time from the wall clock
FClock.GetTime(int64(CurrentTime));
Offset := CurrentTime - FStart;
// Display the current time from the clock
DbgLog(Self, Format('Clock time %d', [CurrentTime]));
DbgLog(Self, Format('Time difference %d ms', [RT_in_Millisecs(Offset)]));
// Do we have a sample ready to render
if (FMediaSample = nil) then
Exit;
FMediaSample.GetTime(StartTime, EndTime);
DbgLog(Self, Format('Next sample stream times (Start %d End %d ms)',
[RT_in_Millisecs(StartTime), RT_in_Millisecs(EndTime)]));
// Calculate how long it is until it is due for rendering
Wait := (FStart + StartTime) - CurrentTime;
DbgLog(Self, Format('Wait required %d ms', [RT_in_Millisecs(Wait)]));
end;
{$ENDIF}
// Wait until the clock sets the timer event or we're otherwise signalled. We
// set an arbitrary timeout for this wait and if it fires then we display the
// current renderer state on the debugger. It will often fire if the filter's
// left paused in an application however it may also fire during stress tests
// if the synchronisation with application seeks and state changes is faulty
const
RENDER_TIMEOUT = 10000;
function TBCBaseRenderer.WaitForRenderTime: HResult;
var
WaitObjects: array[0..1] of THandle;
begin
WaitObjects[0] := FThreadSignal.Handle;
WaitObjects[1] := FRenderEvent.Handle;
DWord(Result) := WAIT_TIMEOUT;
// Wait for either the time to arrive or for us to be stopped
OnWaitStart;
while (Result = WAIT_TIMEOUT) do
begin
Result := WaitForMultipleObjects(2, @WaitObjects, False, RENDER_TIMEOUT);
{$IFDEF DEBUG}
if (Result = WAIT_TIMEOUT) then
DisplayRendererState;
{$ENDIF}
end;
OnWaitEnd;
// We may have been awoken without the timer firing
if (Result = WAIT_OBJECT_0) then
begin
Result := VFW_E_STATE_CHANGED;
Exit;
end;
SignalTimerFired;
Result := NOERROR;
end;
// Poll waiting for Receive to complete. This really matters when
// Receive may set the palette and cause window messages
// The problem is that if we don't really wait for a renderer to
// stop processing we can deadlock waiting for a transform which
// is calling the renderer's Receive() method because the transform's
// Stop method doesn't know to process window messages to unblock
// the renderer's Receive processing
procedure TBCBaseRenderer.WaitForReceiveToComplete;
var
msg: TMsg;
begin
repeat
if Not FInReceive then
Break;
// Receive all interthread sendmessages
PeekMessage(msg, 0, WM_NULL, WM_NULL, PM_NOREMOVE);
Sleep(1);
until False;
// If the wakebit for QS_POSTMESSAGE is set, the PeekMessage call
// above just cleared the changebit which will cause some messaging
// calls to block (waitMessage, MsgWaitFor...) now.
// Post a dummy message to set the QS_POSTMESSAGE bit again
if (HIWORD(GetQueueStatus(QS_POSTMESSAGE)) and QS_POSTMESSAGE) <> 0 then
// Send dummy message
PostThreadMessage(GetCurrentThreadId, WM_NULL, 0, 0);
end;
// A filter can have four discrete states, namely Stopped, Running, Paused,
// Intermediate. We are in an intermediate state if we are currently trying
// to pause but haven't yet got the first sample (or if we have been flushed
// in paused state and therefore still have to wait for a sample to arrive)
// This class contains an event called FCompleteEvent which is signalled when
// the current state is completed and is not signalled when we are waiting to
// complete the last state transition. As mentioned above the only time we
// use this at the moment is when we wait for a media sample in paused state
// If while we are waiting we receive an end of stream notification from the
// source filter then we know no data is imminent so we can reset the event
// This means that when we transition to paused the source filter must call
// end of stream on us or send us an image otherwise we'll hang indefinately
// Simple internal way of getting the real state
// !!! make property here
function TBCBaseRenderer.GetRealState: TFilterState;
begin
Result := FState;
end;
// Waits for the HANDLE hObject. While waiting messages sent
// to windows on our thread by SendMessage will be processed.
// Using this function to do waits and mutual exclusion
// avoids some deadlocks in objects with windows.
// Return codes are the same as for WaitForSingleObject
function WaitDispatchingMessages(Object_: THandle; Wait: DWord;
Wnd: HWnd = 0; Msg: Cardinal = 0; Event: THandle = 0): DWord;
// milenko start (replaced with global variables)
//const
//{$IFOPT J-}
//{$DEFINE ResetJ}
//{$J+}
//{$ENDIF}
// MsgId: Cardinal = 0;
//{$IFDEF ResetJ}
//{$J-}
//{$UNDEF ResetJ}
//{$ENDIF}
// milenko end
var
Peeked: Boolean;
Res, Start, ThreadPriority: DWord;
Objects: array[0..1] of THandle;
Count, TimeOut, WakeMask, Now_, Diff: DWord;
Msg_: TMsg;
begin
Peeked := False;
MsgId := 0;
Start := 0;
ThreadPriority := THREAD_PRIORITY_NORMAL;
Objects[0] := Object_;
Objects[1] := Event;
if (Wait <> INFINITE) and (Wait <> 0) then
Start := GetTickCount;
repeat
if (Event <> 0) then
Count := 2
else
Count := 1;
// Minimize the chance of actually dispatching any messages
// by seeing if we can lock immediately.
Res := WaitForMultipleObjects(Count, @Objects, False, 0);
if (Res < WAIT_OBJECT_0 + Count) then
Break;
TimeOut := Wait;
if (TimeOut > 10) then
TimeOut := 10;
if (Wnd = 0) then
WakeMask := QS_SENDMESSAGE
else
WakeMask := QS_SENDMESSAGE + QS_POSTMESSAGE;
Res := MsgWaitForMultipleObjects(Count, Objects, False,
TimeOut, WakeMask);
if (Res = WAIT_OBJECT_0 + Count) or
((Res = WAIT_TIMEOUT) and (TimeOut <> Wait)) then
begin
if (Wnd <> 0) then
while PeekMessage(Msg_, Wnd, Msg, Msg, PM_REMOVE) do
DispatchMessage(Msg_);
// Do this anyway - the previous peek doesn't flush out the
// messages
PeekMessage(Msg_, 0, 0, 0, PM_NOREMOVE);
if (Wait <> INFINITE) and (Wait <> 0) then
begin
Now_ := GetTickCount();
// Working with differences handles wrap-around
Diff := Now_ - Start;
if (Diff > Wait) then
Wait := 0
else
Dec(Wait, Diff);
Start := Now_;
end;
if not (Peeked) then
begin
// Raise our priority to prevent our message queue
// building up
ThreadPriority := GetThreadPriority(GetCurrentThread);
if (ThreadPriority < THREAD_PRIORITY_HIGHEST) then
begin
// ??? raising priority requires one more routine....
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_HIGHEST);
end;
Peeked := True;
end;
end
else
Break;
until False;
if (Peeked) then
begin
// ??? setting priority requires one more routine....
SetThreadPriority(GetCurrentThread, ThreadPriority);
// milenko start (important!)
// if (HIWORD(GetQueueStatus(QS_POSTMESSAGE)) and QS_POSTMESSAGE) = 0 then
if (HIWORD(GetQueueStatus(QS_POSTMESSAGE)) and QS_POSTMESSAGE) > 0 then
// milenko end
begin
if (MsgId = 0) then
MsgId := RegisterWindowMessage('AMUnblock')
else
// Remove old ones
while (PeekMessage(Msg_, (Wnd) - 1, MsgId, MsgId, PM_REMOVE)) do
// milenko start (this is a loop without any further function.
// it does not call PostThreadMEssage while looping!)
begin
end;
// milenko end
PostThreadMessage(GetCurrentThreadId, MsgId, 0, 0);
end;
end;
Result := Res;
end;
// The renderer doesn't complete the full transition to paused states until
// it has got one media sample to render. If you ask it for its state while
// it's waiting it will return the state along with VFW_S_STATE_INTERMEDIATE
function TBCBaseRenderer.GetState(MSecs: DWord; out State: TFilterState):
HResult;
begin
if (WaitDispatchingMessages(FCompleteEvent.Handle, MSecs) = WAIT_TIMEOUT) then
Result := VFW_S_STATE_INTERMEDIATE
else
Result := NOERROR;
State := FState;
end;
// If we're pausing and we have no samples we don't complete the transition
// to State_Paused and we return S_FALSE. However if the FAborting flag has
// been set then all samples are rejected so there is no point waiting for
// one. If we do have a sample then return NOERROR. We will only ever return
// VFW_S_STATE_INTERMEDIATE from GetState after being paused with no sample
// (calling GetState after either being stopped or Run will NOT return this)
function TBCBaseRenderer.CompleteStateChange(OldState: TFilterState): HResult;
begin
// Allow us to be paused when disconnected
if not (FInputPin.IsConnected) or
// Have we run off the end of stream
IsEndOfStream or
// Make sure we get fresh data after being stopped
(HaveCurrentSample and (OldState <> State_Stopped)) then
begin
Ready;
Result := S_OK;
Exit;
end;
NotReady;
Result := S_False;
end;
procedure TBCBaseRenderer.SetAbortSignal(Abort_: Boolean);
begin
FAbort := Abort_;
end;
procedure TBCBaseRenderer.OnReceiveFirstSample(MediaSample: IMediaSample);
begin
end;
procedure TBCBaseRenderer.Ready;
begin
FCompleteEvent.SetEv
end;
procedure TBCBaseRenderer.NotReady;
begin
FCompleteEvent.Reset
end;
function TBCBaseRenderer.CheckReady: Boolean;
begin
Result := FCompleteEvent.Check
end;
// When we stop the filter the things we do are:-
// Decommit the allocator being used in the connection
// Release the source filter if it's waiting in Receive
// Cancel any advise link we set up with the clock
// Any end of stream signalled is now obsolete so reset
// Allow us to be stopped when we are not connected
function TBCBaseRenderer.Stop: HResult;
begin
FInterfaceLock.Lock;
try
// Make sure there really is a state change
if (FState = State_Stopped) then
begin
Result := NOERROR;
Exit;
end;
// Is our input pin connected
if not (FInputPin.IsConnected) then
begin
{$IFDEF DEBUG}
DbgLog(Self, 'Input pin is not connected');
{$ENDIF}
FState := State_Stopped;
Result := NOERROR;
Exit;
end;
inherited Stop;
// If we are going into a stopped state then we must decommit whatever
// allocator we are using it so that any source filter waiting in the
// GetBuffer can be released and unlock themselves for a state change
if Assigned(FInputPin.FAllocator) then
FInputPin.FAllocator.Decommit;
// Cancel any scheduled rendering
SetRepaintStatus(True);
StopStreaming;
SourceThreadCanWait(False);
ResetEndOfStream;
CancelNotification;
// There should be no outstanding clock advise
Assert(CancelNotification = S_FALSE);
Assert(WAIT_TIMEOUT = WaitForSingleObject(FRenderEvent.Handle, 0));
Assert(FEndOfStreamTimer = 0);
Ready;
WaitForReceiveToComplete;
FAbort := False;
Result := NOERROR;
finally
FInterfaceLock.UnLock;
end;
end;
// When we pause the filter the things we do are:-
// Commit the allocator being used in the connection
// Allow a source filter thread to wait in Receive
// Cancel any clock advise link (we may be running)
// Possibly complete the state change if we have data
// Allow us to be paused when we are not connected
function TBCBaseRenderer.Pause: HResult;
var
OldState: TFilterState;
hr: HResult;
begin
FInterfaceLock.Lock;
try
OldState := FState;
Assert(not FInputPin.IsFlushing);
// Make sure there really is a state change
if (FState = State_Paused) then
begin
Result := CompleteStateChange(State_Paused);
Exit;
end;
// Has our input pin been connected
if Not FInputPin.IsConnected then
begin
{$IFDEF DEBUG}
DbgLog(Self, 'Input pin is not connected');
{$ENDIF}
FState := State_Paused;
Result := CompleteStateChange(State_Paused);
Exit;
end;
// Pause the base filter class
hr := inherited Pause;
if Failed(hr) then
begin
{$IFDEF DEBUG}
DbgLog(Self, 'Pause failed');
{$ENDIF}
Result := hr;
Exit;
end;
// Enable EC_REPAINT events again
SetRepaintStatus(True);
StopStreaming;
SourceThreadCanWait(True);
CancelNotification;
ResetEndOfStreamTimer;
// If we are going into a paused state then we must commit whatever
// allocator we are using it so that any source filter can call the
// GetBuffer and expect to get a buffer without returning an error
if Assigned(FInputPin.FAllocator) then
FInputPin.FAllocator.Commit;
// There should be no outstanding advise
Assert(CancelNotification = S_FALSE);
Assert(WAIT_TIMEOUT = WaitForSingleObject(FRenderEvent.Handle, 0));
Assert(FEndOfStreamTimer = 0);
Assert(not FInputPin.IsFlushing);
// When we come out of a stopped state we must clear any image we were
// holding onto for frame refreshing. Since renderers see state changes
// first we can reset ourselves ready to accept the source thread data
// Paused or running after being stopped causes the current position to
// be reset so we're not interested in passing end of stream signals
if (OldState = State_Stopped) then
begin
FAbort := False;
ClearPendingSample;
end;
Result := CompleteStateChange(OldState);
finally
FInterfaceLock.Unlock;
end;
end;
// When we run the filter the things we do are:-
// Commit the allocator being used in the connection
// Allow a source filter thread to wait in Receive
// Signal the render event just to get us going
// Start the base class by calling StartStreaming
// Allow us to be run when we are not connected
// Signal EC_COMPLETE if we are not connected
function TBCBaseRenderer.Run(StartTime: TReferenceTime): HResult;
var
OldState: TFilterState;
hr: HResult;
// milenko start
Filter: IBaseFilter;
// milenko end
begin
FInterfaceLock.Lock;
try
OldState := FState;
// Make sure there really is a state change
if (FState = State_Running) then
begin
Result := NOERROR;
Exit;
end;
// Send EC_COMPLETE if we're not connected
if not FInputPin.IsConnected then
begin
// milenko start (Delphi 5 compatibility)
QueryInterface(IID_IBaseFilter,Filter);
NotifyEvent(EC_COMPLETE, S_OK, Integer(Filter));
Filter := nil;
// milenko end
FState := State_Running;
Result := NOERROR;
Exit;
end;
Ready;
// Pause the base filter class
hr := inherited Run(StartTime);
if Failed(hr) then
begin
{$IFDEF DEBUG}
DbgLog(Self, 'Run failed');
{$ENDIF}
Result := hr;
Exit;
end;
// Allow the source thread to wait
Assert(not FInputPin.IsFlushing);
SourceThreadCanWait(True);
SetRepaintStatus(False);
// There should be no outstanding advise
Assert(CancelNotification = S_FALSE);
Assert(WAIT_TIMEOUT = WaitForSingleObject(FRenderEvent.Handle, 0));
Assert(FEndOfStreamTimer = 0);
Assert(not FInputPin.IsFlushing);
// If we are going into a running state then we must commit whatever
// allocator we are using it so that any source filter can call the
// GetBuffer and expect to get a buffer without returning an error
if Assigned(FInputPin.FAllocator) then
FInputPin.FAllocator.Commit;
// When we come out of a stopped state we must clear any image we were
// holding onto for frame refreshing. Since renderers see state changes
// first we can reset ourselves ready to accept the source thread data
// Paused or running after being stopped causes the current position to
// be reset so we're not interested in passing end of stream signals
if (OldState = State_Stopped) then
begin
FAbort := False;
ClearPendingSample;
end;
Result := StartStreaming;
finally
FInterfaceLock.Unlock;
end;
end;
// Return the number of input pins we support
function TBCBaseRenderer.GetPinCount: Integer;
begin
Result := 1;
end;
// We only support one input pin and it is numbered zero
function TBCBaseRenderer.GetPin(n: integer): TBCBasePin;
var
hr: HResult;
begin