(********************************************************************* * DSPack 2.3.3 * * DirectShow BaseClass * * * * home page : http://www.progdigy.com * * email : hgourvest@progdigy.com * * * * date : 21-02-2003 * * * * The contents of this file are used with permission, subject to * * the Mozilla Public License Version 1.1 (the "License"); you may * * not use this file except in compliance with the License. You may * * obtain a copy of the License at * * http://www.mozilla.org/MPL/MPL-1.1.html * * * * Software distributed under the License is distributed on an * * "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or * * implied. See the License for the specific language governing * * rights and limitations under the License. * * * * Contributor(s) * * Andriy Nevhasymyy * * Milenko Mitrovic * * Michael Andersen * * Martin Offenwanger * * * *********************************************************************) {.$DEFINE DEBUG} // Debug Log {.$DEFINE TRACE} // Trace Criteral Section (DEBUG must be ON) {.$DEFINE MESSAGE} // Use OutputDebugString instead of a File (DEBUG must be ON) {.$DEFINE PERF} // Show Performace Counter {.$DEFINE VTRANSPERF} // Show additional TBCVideoTransformFilter Performace Counter (PERF must be ON) {$MINENUMSIZE 4} {$ALIGN ON} unit BaseClass; {$IFDEF VER150} {$WARN UNSAFE_CODE OFF} {$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CAST OFF} {$ENDIF} interface uses Windows, SysUtils, Classes, Math, ActiveX, Forms, Messages, Controls, DirectShow9, dialogs, ComObj, mmsystem, DSUtil; const OATRUE = -1; OAFALSE = 0; DEFAULTCACHE = 10; // Default node object cache size type TBCCritSec = class private FCritSec : TRTLCriticalSection; {$IFDEF DEBUG} FcurrentOwner: Longword; FlockCount : Longword; {$ENDIF} public constructor Create; destructor Destroy; override; procedure Lock; procedure UnLock; function CritCheckIn: boolean; function CritCheckOut: boolean; end; TBCBaseObject = class(TObJect) private FName: string; public constructor Create(Name: string); destructor Destroy; override; class function NewInstance: TObject; override; procedure FreeInstance; override; class function ObjectsActive: integer; end; TBCClassFactory = Class; TBCUnknown = class(TBCBaseObject, IUnKnown) private FRefCount: integer; FOwner : Pointer; protected function IUnknown.QueryInterface = NonDelegatingQueryInterface; function IUnknown._AddRef = NonDelegatingAddRef; function IUnknown._Release = NonDelegatingRelease; function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; public function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; constructor Create(name: string; Unk: IUnknown); constructor CreateFromFactory(Factory: TBCClassFactory; const Controller: IUnknown); virtual; function NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; function NonDelegatingAddRef: Integer; virtual; stdcall; function NonDelegatingRelease: Integer; virtual; stdcall; function GetOwner: IUnKnown; end; TBCUnknownClass = Class of TBCUnknown; TFormPropertyPage = class; TFormPropertyPageClass = class of TFormPropertyPage; TBCBaseFilter = class; TBCBaseFilterClass = class of TBCBaseFilter; TBCClassFactory = class(TObject, IUnKnown, IClassFactory) private FNext : TBCClassFactory; FComClass : TBCUnknownClass; FPropClass: TFormPropertyPageClass; FName : String; FClassID : TGUID; FCategory : TGUID; FMerit : LongWord; FPinCount : Cardinal; FPins : PRegFilterPins; function RegisterFilter(FilterMapper: IFilterMapper; Register: Boolean): boolean; overload; function RegisterFilter(FilterMapper: IFilterMapper2; Register: Boolean): boolean; overload; procedure UpdateRegistry(Register: Boolean); overload; protected function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult; stdcall; function LockServer(fLock: BOOL): HResult; stdcall; public constructor CreateFilter(ComClass: TBCUnknownClass; Name: string; const ClassID: TGUID; const Category: TGUID; Merit: LongWord; PinCount: Cardinal; Pins: PRegFilterPins); constructor CreatePropertyPage(ComClass: TFormPropertyPageClass; const ClassID: TGUID); property Name: String read FName; property ClassID: TGUID read FClassID; end; TBCFilterTemplate = class private FFactoryList : TBCClassFactory; procedure AddObjectFactory(Factory: TBCClassFactory); public constructor Create; destructor Destroy; override; function RegisterServer(Register: Boolean): boolean; function GetFactoryFromClassID(const CLSID: TGUID): TBCClassFactory; end; TBCMediaType = object MediaType: PAMMediaType; function Equal(mt: TBCMediaType): boolean; overload; function Equal(mt: PAMMediaType): boolean; overload; function MatchesPartial(Partial: PAMMediaType): boolean; function IsPartiallySpecified: boolean; function IsValid: boolean; procedure InitMediaType; function FormatLength: Cardinal; end; TBCBasePin = class; TBCBaseFilter = class(TBCUnknown, IBaseFilter, IAMovieSetup) protected FState : TFilterState; // current state: running, paused FClock : IReferenceClock; // this graph's ref clock FStart : TReferenceTime; // offset from stream time to reference time FCLSID : TGUID; // This filters clsid used for serialization FLock : TBCCritSec; // Object we use for locking FFilterName : WideString; // Full filter name FGraph : IFilterGraph; // Graph we belong to FSink : IMediaEventSink; // Called with notify events FPinVersion: Integer; // Current pin version public constructor Create(Name: string; // Object description Unk : IUnKnown; // IUnknown of delegating object Lock: TBCCritSec; // Object who maintains lock const clsid: TGUID // The clsid to be used to serialize this filter ); overload; constructor Create(Name: string; // Object description Unk : IUnKnown; // IUnknown of delegating object Lock: TBCCritSec; // Object who maintains lock const clsid: TGUID; // The clsid to be used to serialize this filter out hr: HRESULT // General OLE return code ); overload; constructor CreateFromFactory(Factory: TBCClassFactory; const Controller: IUnknown); override; destructor destroy; override; // --- IPersist method --- function GetClassID(out classID: TCLSID): HResult; stdcall; // --- IMediaFilter methods --- // override Stop and Pause so we can activate the pins. // Note that Run will call Pause first if activation needed. // Override these if you want to activate your filter rather than // your pins. function Stop: HRESULT; virtual; stdcall; function Pause: HRESULT; virtual; stdcall; // the start parameter is the difference to be added to the // sample's stream time to get the reference time for // its presentation function Run(tStart: TReferenceTime): HRESULT; virtual; stdcall; function GetState(dwMilliSecsTimeout: DWORD; out State: TFilterState): HRESULT; virtual; stdcall; function SetSyncSource(pClock: IReferenceClock): HRESULT; stdcall; function GetSyncSource(out pClock: IReferenceClock): HRESULT; stdcall; // --- helper methods --- // return the current stream time - ie find out what // stream time should be appearing now function StreamTime(out rtStream: TReferenceTime): HRESULT; virtual; // Is the filter currently active? function IsActive: boolean; // Is this filter stopped (without locking) function IsStopped: boolean; // --- IBaseFilter methods --- // pin enumerator function EnumPins(out ppEnum: IEnumPins): HRESULT; stdcall; // default behaviour of FindPin assumes pin ids are their names function FindPin(Id: PWideChar; out Pin: IPin): HRESULT; virtual; stdcall; function QueryFilterInfo(out pInfo: TFilterInfo): HRESULT; stdcall; // milenko start (added virtual to be able to override it in the renderers) function JoinFilterGraph(pGraph: IFilterGraph; pName: PWideChar): HRESULT; virtual; stdcall; // milenko end // return a Vendor information string. Optional - may return E_NOTIMPL. // memory returned should be freed using CoTaskMemFree // default implementation returns E_NOTIMPL function QueryVendorInfo(out pVendorInfo: PWideChar): HRESULT; stdcall; // --- helper methods --- // send an event notification to the filter graph if we know about it. // returns S_OK if delivered, S_FALSE if the filter graph does not sink // events, or an error otherwise. function NotifyEvent(EventCode, EventParam1, EventParam2: LongInt): HRESULT; // return the filter graph we belong to function GetFilterGraph: IFilterGraph; // Request reconnect // pPin is the pin to reconnect // pmt is the type to reconnect with - can be NULL // Calls ReconnectEx on the filter graph function ReconnectPin(Pin: IPin; pmt: PAMMediaType): HRESULT; // find out the current pin version (used by enumerators) function GetPinVersion: LongInt; virtual; procedure IncrementPinVersion; // you need to supply these to access the pins from the enumerator // and for default Stop and Pause/Run activation. function GetPinCount: integer; virtual; abstract; function GetPin(n: Integer): TBCBasePin; virtual; abstract; // --- IAMovieSetup methods --- {nev: start 04/16/04 added "virtual"} function Register: HRESULT; virtual; stdcall; function Unregister: HRESULT; virtual; stdcall; {nev: end} property State: TFilterState read FState; property GRaph : IFilterGraph read FGRaph; end; { NOTE The implementation of this class calls the CUnknown constructor with a NULL outer unknown pointer. This has the effect of making us a self contained class, ie any QueryInterface, AddRef or Release calls will be routed to the class's NonDelegatingUnknown methods. You will typically find that the classes that do this then override one or more of these virtual functions to provide more specialised behaviour. A good example of this is where a class wants to keep the QueryInterface internal but still wants its lifetime controlled by the external object } TBCBasePin = class(TBCUnknown, IPin, IQualityControl) protected FPinName: WideString; FConnected : IPin; // Pin we have connected to Fdir : TPinDirection; // Direction of this pin FLock : TBCCritSec; // Object we use for locking FRunTimeError : boolean; // Run time error generated FCanReconnectWhenActive: boolean; // OK to reconnect when active FTryMyTypesFirst : boolean; // When connecting enumerate // this pin's types first FFilter : TBCBaseFilter; // Filter we were created by FQSink : IQualityControl; // Target for Quality messages FTypeVersion : LongInt; // Holds current type version Fmt : TAMMediaType; // Media type of connection FStart : TReferenceTime; // time from NewSegment call FStop : TReferenceTime; // time from NewSegment FRate : double; // rate from NewSegment FRef : LongInt; function GetCurrentMediaType: TBCMediaType; function GetAMMediaType: PAMMediaType; protected procedure DisplayPinInfo(ReceivePin: IPin); procedure DisplayTypeInfo(Pin: IPin; pmt: PAMMediaType); // used to agree a media type for a pin connection // given a specific media type, attempt a connection (includes // checking that the type is acceptable to this pin) function AttemptConnection( ReceivePin: IPin; // connect to this pin pmt : PAMMediaType // using this type ): HRESULT; // try all the media types in this enumerator - for each that // we accept, try to connect using ReceiveConnection. function TryMediaTypes( ReceivePin: IPin; // connect to this pin pmt : PAMMediaType; // proposed type from Connect Enum : IEnumMediaTypes // try this enumerator ): HRESULT; // establish a connection with a suitable mediatype. Needs to // propose a media type if the pmt pointer is null or partially // specified - use TryMediaTypes on both our and then the other pin's // enumerator until we find one that works. function AgreeMediaType( ReceivePin: IPin; // connect to this pin pmt : PAMMediaType // proposed type from Connect ): HRESULT; function DisconnectInternal: HRESULT; stdcall; public function NonDelegatingAddRef: Integer; override; stdcall; function NonDelegatingRelease: Integer; override; stdcall; constructor Create( ObjectName: string; // Object description Filter : TBCBaseFilter; // Owning filter who knows about pins Lock : TBCCritSec; // Object who implements the lock out hr : HRESULT; // General OLE return code Name : WideString; // Pin name for us dir : TPinDirection); // Either PINDIR_INPUT or PINDIR_OUTPUT destructor destroy; override; // --- IPin methods --- // take lead role in establishing a connection. Media type pointer // may be null, or may point to partially-specified mediatype // (subtype or format type may be GUID_NULL). function Connect(pReceivePin: IPin; const pmt: PAMMediaType): HRESULT; virtual; stdcall; // (passive) accept a connection from another pin function ReceiveConnection(pConnector: IPin; const pmt: TAMMediaType): HRESULT; virtual; stdcall; function Disconnect: HRESULT; virtual; stdcall; function ConnectedTo(out pPin: IPin): HRESULT; virtual; stdcall; function ConnectionMediaType(out pmt: TAMMediaType): HRESULT; virtual; stdcall; function QueryPinInfo(out pInfo: TPinInfo): HRESULT; virtual; stdcall; function QueryDirection(out pPinDir: TPinDirection): HRESULT; stdcall; function QueryId(out Id: PWideChar): HRESULT; virtual; stdcall; // does the pin support this media type function QueryAccept(const pmt: TAMMediaType): HRESULT; virtual; stdcall; // return an enumerator for this pins preferred media types function EnumMediaTypes(out ppEnum: IEnumMediaTypes): HRESULT; virtual; stdcall; // return an array of IPin* - the pins that this pin internally connects to // All pins put in the array must be AddReffed (but no others) // Errors: "Can't say" - FAIL, not enough slots - return S_FALSE // Default: return E_NOTIMPL // The filter graph will interpret NOT_IMPL as any input pin connects to // all visible output pins and vice versa. // apPin can be NULL if nPin==0 (not otherwise). function QueryInternalConnections(out apPin: IPin; var nPin: ULONG): HRESULT; virtual; stdcall; // Called when no more data will be sent function EndOfStream: HRESULT; virtual; stdcall; function BeginFlush: HRESULT; virtual; stdcall; abstract; function EndFlush: HRESULT; virtual; stdcall; abstract; // Begin/EndFlush still PURE // NewSegment notifies of the start/stop/rate applying to the data // about to be received. Default implementation records data and // returns S_OK. // Override this to pass downstream. function NewSegment(tStart, tStop: TReferenceTime; dRate: double): HRESULT; virtual; stdcall; // --- IQualityControl methods --- function Notify(pSelf: IBaseFilter; q: TQuality): HRESULT; virtual; stdcall; function SetSink(piqc: IQualityControl): HRESULT; virtual; stdcall; // --- helper methods --- // Returns True if the pin is connected. false otherwise. function IsConnected: boolean; // Return the pin this is connected to (if any) property GetConnected: IPin read FConnected; // Check if our filter is currently stopped function IsStopped: boolean; // find out the current type version (used by enumerators) function GetMediaTypeVersion: longint; virtual; procedure IncrementTypeVersion; // switch the pin to active (paused or running) mode // not an error to call this if already active function Active: HRESULT; virtual; // switch the pin to inactive state - may already be inactive function Inactive: HRESULT; virtual; // Notify of Run() from filter function Run(Start: TReferenceTime): HRESULT; virtual; // check if the pin can support this specific proposed type and format function CheckMediaType(mt: PAMMediaType): HRESULT; virtual; abstract; // set the connection to use this format (previously agreed) function SetMediaType(mt: PAMMediaType): HRESULT; virtual; // check that the connection is ok before verifying it // can be overridden eg to check what interfaces will be supported. function CheckConnect(Pin: IPin): HRESULT; virtual; // Set and release resources required for a connection function BreakConnect: HRESULT; virtual; function CompleteConnect(ReceivePin: IPin): HRESULT; virtual; // returns the preferred formats for a pin function GetMediaType(Position: integer; out MediaType: PAMMediaType): HRESULT; virtual; // access to NewSegment values property CurrentStopTime: TReferenceTime read FStop; property CurrentStartTime: TReferenceTime read FStart; property CurrentRate: double read FRate; // Access name property Name: WideString read FPinName; property CanReconnectWhenActive: boolean read FCanReconnectWhenActive write FCanReconnectWhenActive; // Media type property CurrentMediaType: TBCMediaType read GetCurrentMediaType; property AMMediaType: PAMMediaType read GetAMMediaType; end; TBCEnumPins = class(TInterfacedObject, IEnumPins) private FPosition: integer; // Current ordinal position FPinCount: integer; // Number of pins available FFilter: TBCBaseFilter; // The filter who owns us FVersion: LongInt; // Pin version information // These pointers have not been AddRef'ed and // so they should not be dereferenced. They are // merely kept to ID which pins have been enumerated. FPinCache: TList; { If while we are retrieving a pin for example from the filter an error occurs we assume that our internal state is stale with respect to the filter (someone may have deleted all the pins). We can check before starting whether or not the operation is likely to fail by asking the filter what it's current version number is. If the filter has not overriden the GetPinVersion method then this will always match } function AreWeOutOfSync: boolean; (* This method performs the same operations as Reset, except is does not clear the cache of pins already enumerated. *) function Refresh: HRESULT; stdcall; public constructor Create(Filter: TBCBaseFilter; EnumPins: TBCEnumPins); destructor Destroy; override; function Next(cPins: ULONG; // place this many pins... out ppPins: IPin; // ...in this array of IPin* pcFetched: PULONG // actual count passed returned here ): HRESULT; stdcall; function Skip(cPins: ULONG): HRESULT; stdcall; function Reset: HRESULT; stdcall; function Clone(out ppEnum: IEnumPins): HRESULT; stdcall; end; TBCEnumMediaTypes = class(TInterfacedObject, IEnumMediaTypes) private FPosition: Cardinal; // Current ordinal position FPin : TBCBasePin; // The pin who owns us FVersion : LongInt; // Media type version value function AreWeOutOfSync: boolean; public constructor Create(Pin: TBCBasePin; EnumMediaTypes: TBCEnumMediaTypes); destructor Destroy; override; function Next(cMediaTypes: ULONG; out ppMediaTypes: PAMMediaType; pcFetched: PULONG): HRESULT; stdcall; function Skip(cMediaTypes: ULONG): HRESULT; stdcall; function Reset: HRESULT; stdcall; function Clone(out ppEnum: IEnumMediaTypes): HRESULT; stdcall; end; TBCBaseOutputPin = class(TBCBasePin) protected FAllocator: IMemAllocator; // interface on the downstreaminput pin, set up in CheckConnect when we connect. FInputPin : IMemInputPin; public constructor Create(ObjectName: string; Filter: TBCBaseFilter; Lock: TBCCritSec; out hr: HRESULT; const Name: WideString); // override CompleteConnect() so we can negotiate an allocator function CompleteConnect(ReceivePin: IPin): HRESULT; override; // negotiate the allocator and its buffer size/count and other properties // Calls DecideBufferSize to set properties function DecideAllocator(Pin: IMemInputPin; out Alloc: IMemAllocator): HRESULT; virtual; // override this to set the buffer size and count. Return an error // if the size/count is not to your liking. // The allocator properties passed in are those requested by the // input pin - use eg the alignment and prefix members if you have // no preference on these. function DecideBufferSize(Alloc: IMemAllocator; propInputRequest: PAllocatorProperties): HRESULT; virtual; // returns an empty sample buffer from the allocator function GetDeliveryBuffer(out Sample: IMediaSample; StartTime: PReferenceTime; EndTime: PReferenceTime; Flags: Longword): HRESULT; virtual; // deliver a filled-in sample to the connected input pin // note - you need to release it after calling this. The receiving // pin will addref the sample if it needs to hold it beyond the // call. function Deliver(Sample: IMediaSample): HRESULT; virtual; // override this to control the connection function InitAllocator(out Alloc: IMemAllocator): HRESULT; virtual; function CheckConnect(Pin: IPin): HRESULT; override; function BreakConnect: HRESULT; override; // override to call Commit and Decommit function Active: HRESULT; override; function Inactive: HRESULT; override; // we have a default handling of EndOfStream which is to return // an error, since this should be called on input pins only function EndOfStream: HRESULT; override; stdcall; // called from elsewhere in our filter to pass EOS downstream to // our connected input pin function DeliverEndOfStream: HRESULT; virtual; // same for Begin/EndFlush - we handle Begin/EndFlush since it // is an error on an output pin, and we have Deliver methods to // call the methods on the connected pin function BeginFlush: HRESULT; override; stdcall; function EndFlush: HRESULT; override; stdcall; function DeliverBeginFlush: HRESULT; virtual; function DeliverEndFlush: HRESULT; virtual; // deliver NewSegment to connected pin - you will need to // override this if you queue any data in your output pin. function DeliverNewSegment(Start, Stop: TReferenceTime; Rate: double): HRESULT; virtual; end; TBCBaseInputPin = class(TBCBasePin, IMemInputPin) protected FAllocator: IMemAllocator; // Default memory allocator // allocator is read-only, so received samples // cannot be modified (probably only relevant to in-place // transforms FReadOnly: boolean; //private: this should really be private... only the MPEG code // currently looks at it directly and it should use IsFlushing(). // in flushing state (between BeginFlush and EndFlush) // if True, all Receives are returned with S_FALSE FFlushing: boolean; // Sample properties - initalized in Receive FSampleProps: TAMSample2Properties; public constructor Create(ObjectName: string; Filter: TBCBaseFilter; Lock: TBCCritSec; out hr: HRESULT; Name: WideString); destructor Destroy; override; // ----------IMemInputPin-------------- // return the allocator interface that this input pin // would like the output pin to use function GetAllocator(out ppAllocator: IMemAllocator): HRESULT; stdcall; // tell the input pin which allocator the output pin is actually // going to use. function NotifyAllocator(pAllocator: IMemAllocator; bReadOnly: BOOL): HRESULT; stdcall; // this method is optional (can return E_NOTIMPL). // default implementation returns E_NOTIMPL. Override if you have // specific alignment or prefix needs, but could use an upstream // allocator function GetAllocatorRequirements(out pProps: TAllocatorProperties): HRESULT; stdcall; // do something with this media sample function Receive(pSample: IMediaSample): HRESULT; virtual; stdcall; // do something with these media samples function ReceiveMultiple(var pSamples: IMediaSample; nSamples: Longint; out nSamplesProcessed: Longint): HRESULT; stdcall; // See if Receive() blocks function ReceiveCanBlock: HRESULT; stdcall; //-----------Helper------------- // Default handling for BeginFlush - call at the beginning // of your implementation (makes sure that all Receive calls // fail). After calling this, you need to free any queued data // and then call downstream. function BeginFlush: HRESULT; override; stdcall; // default handling for EndFlush - call at end of your implementation // - before calling this, ensure that there is no queued data and no thread // pushing any more without a further receive, then call downstream, // then call this method to clear the m_bFlushing flag and re-enable // receives function EndFlush: HRESULT; override; stdcall; // Release the pin's allocator. function BreakConnect: HRESULT; override; // helper method to check the read-only flag property IsReadOnly: boolean read FReadOnly; // helper method to see if we are flushing property IsFlushing: boolean read FFlushing; // Override this for checking whether it's OK to process samples // Also call this from EndOfStream. function CheckStreaming: HRESULT; virtual; // Pass a Quality notification on to the appropriate sink function PassNotify(const q: TQuality): HRESULT; //================================================================================ // IQualityControl methods (from CBasePin) //================================================================================ function Notify(pSelf: IBaseFilter; q: TQuality): HRESULT; override; stdcall; // no need to override: // STDMETHODIMP SetSink(IQualityControl * piqc); // switch the pin to inactive state - may already be inactive function Inactive: HRESULT; override; // Return sample properties pointer function SampleProps: PAMSample2Properties; end; // milenko start (added TBCDynamicOutputPin conversion) TBLOCK_STATE = (NOT_BLOCKED, PENDING, BLOCKED); TBCDynamicOutputPin = class(TBCBaseOutputPin, IPinFlowControl) public constructor Create(ObjectName: WideString; Filter: TBCBaseFilter; Lock: TBCCritSec; out hr: HRESULT; Name: WideString); destructor Destroy; override; // IUnknown Methods function NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult; override; // IPin Methods function Disconnect: HRESULT; override; stdcall; // IPinFlowControl Methods function Block(dwBlockFlags: DWORD; hEvent: THandle): HResult; stdcall; // Set graph config info procedure SetConfigInfo(GraphConfig: IGraphConfig; StopEvent: THandle); {$IFDEF DEBUG} function Deliver(Sample: IMediaSample): HRESULT; override; function DeliverEndOfStream: HRESULT; override; function DeliverNewSegment(Start, Stop: TReferenceTime; Rate: double): HRESULT; override; {$ENDIF} // DEBUG function DeliverBeginFlush: HRESULT; override; function DeliverEndFlush: HRESULT; override; function Active: HRESULT; override; function Inactive: HRESULT; override; function CompleteConnect(ReceivePin: IPin): HRESULT; override; function StartUsingOutputPin: HRESULT; virtual; procedure StopUsingOutputPin; virtual; function StreamingThreadUsingOutputPin: Boolean; virtual; function ChangeOutputFormat(const pmt: PAMMediaType; tSegmentStart, tSegmentStop: TreferenceTime; dSegmentRate: Double): HRESULT; function ChangeMediaType(const pmt: PAMMEdiaType): HRESULT; function DynamicReconnect(const pmt: PAMMediaType): HRESULT; protected // This lock should be held when the following class members are // being used: m_hNotifyCallerPinBlockedEvent, m_BlockState, // m_dwBlockCallerThreadID and m_dwNumOutstandingOutputPinUsers. FBlockStateLock: TBCCritSec; // This event should be signaled when the output pin is // not blocked. This is a manual reset event. For more // information on events, see the documentation for // CreateEvent() in the Windows SDK. FUnblockOutputPinEvent: THandle; // This event will be signaled when block operation succeedes or // when the user cancels the block operation. The block operation // can be canceled by calling IPinFlowControl2::Block( 0, NULL ) // while the block operation is pending. FNotifyCallerPinBlockedEvent: THandle; // The state of the current block operation. FBlockState: TBLOCK_STATE; // The ID of the thread which last called IPinFlowControl::Block(). // For more information on thread IDs, see the documentation for // GetCurrentThreadID() in the Windows SDK. FBlockCallerThreadID: DWORD; // The number of times StartUsingOutputPin() has been sucessfully // called and a corresponding call to StopUsingOutputPin() has not // been made. When this variable is greater than 0, the streaming // thread is calling IPin::NewSegment(), IPin::EndOfStream(), // IMemInputPin::Receive() or IMemInputPin::ReceiveMultiple(). The // streaming thread could also be calling: DynamicReconnect(), // ChangeMediaType() or ChangeOutputFormat(). The output pin cannot // be blocked while the output pin is being used. FNumOutstandingOutputPinUsers: DWORD; // This event should be set when the IMediaFilter::Stop() is called. // This is a manual reset event. It is also set when the output pin // delivers a flush to the connected input pin. FStopEvent: THandle; FGraphConfig: IGraphConfig; // TRUE if the output pin's allocator's samples are read only. // Otherwise FALSE. For more information, see the documentation // for IMemInputPin::NotifyAllocator(). FPinUsesReadOnlyAllocator: Boolean; function SynchronousBlockOutputPin: HRESULT; function AsynchronousBlockOutputPin(NotifyCallerPinBlockedEvent: THandle): HRESULT; function UnblockOutputPin: HRESULT; procedure BlockOutputPin; procedure ResetBlockState; class function WaitEvent(Event: THandle): HRESULT; private function Initialize: HRESULT; function ChangeMediaTypeHelper(const pmt: PAMMediaType): HRESULT; {$IFDEF DEBUG} procedure AssertValid; {$ENDIF} // DEBUG end; // milenko end TBCTransformOutputPin = class; TBCTransformInputPin = class; TBCTransformFilter = class(TBCBaseFilter) protected FEOSDelivered : boolean; // have we sent EndOfStream FSampleSkipped : boolean; // Did we just skip a frame FQualityChanged: boolean; // Have we degraded? // critical section protecting filter state. FcsFilter: TBCCritSec; // critical section stopping state changes (ie Stop) while we're // processing a sample. // // This critical section is held when processing // events that occur on the receive thread - Receive() and EndOfStream(). // // If you want to hold both m_csReceive and m_csFilter then grab // m_csFilter FIRST - like CTransformFilter::Stop() does. FcsReceive: TBCCritSec; // these hold our input and output pins FInput : TBCTransformInputPin; FOutput: TBCTransformOutputPin; public // map getpin/getpincount for base enum of pins to owner // override this to return more specialised pin objects function GetPinCount: integer; override; function GetPin(n: integer): TBCBasePin; override; function FindPin(Id: PWideChar; out ppPin: IPin): HRESULT; override; stdcall; // override state changes to allow derived transform filter // to control streaming start/stop function Stop: HRESULT; override; stdcall; function Pause: HRESULT; override; stdcall; constructor Create(ObjectName: string; unk: IUnKnown; const clsid: TGUID); constructor CreateFromFactory(Factory: TBCClassFactory; const Controller: IUnknown); override; destructor destroy; override; // ================================================================= // ----- override these bits --------------------------------------- // ================================================================= // These must be supplied in a derived class function Transform(msIn, msout: IMediaSample): HRESULT; virtual; // check if you can support mtIn function CheckInputType(mtIn: PAMMediaType): HRESULT; virtual; abstract; // check if you can support the transform from this input to this output function CheckTransform(mtIn, mtOut: PAMMediaType): HRESULT; virtual; abstract; // this goes in the factory template table to create new instances // static CCOMObject * CreateInstance(LPUNKNOWN, HRESULT *); // call the SetProperties function with appropriate arguments function DecideBufferSize(Allocator: IMemAllocator; prop: PAllocatorProperties): HRESULT; virtual; abstract; // override to suggest OUTPUT pin media types function GetMediaType(Position: integer; out MediaType: PAMMediaType): HRESULT; virtual; abstract; // ================================================================= // ----- Optional Override Methods ----------------------- // ================================================================= // you can also override these if you want to know about streaming function StartStreaming: HRESULT; virtual; function StopStreaming: HRESULT; virtual; // override if you can do anything constructive with quality notifications function AlterQuality(const q: TQuality): HRESULT; virtual; // override this to know when the media type is actually set function SetMediaType(direction: TPinDirection; pmt: PAMMediaType): HRESULT; virtual; // chance to grab extra interfaces on connection function CheckConnect(dir: TPinDirection; Pin: IPin): HRESULT; virtual; function BreakConnect(dir: TPinDirection): HRESULT; virtual; function CompleteConnect(direction: TPinDirection; ReceivePin: IPin): HRESULT; virtual; // chance to customize the transform process function Receive(Sample: IMediaSample): HRESULT; virtual; // Standard setup for output sample function InitializeOutputSample(Sample: IMediaSample; out OutSample: IMediaSample): HRESULT; virtual; // if you override Receive, you may need to override these three too function EndOfStream: HRESULT; virtual; function BeginFlush: HRESULT; virtual; function EndFlush: HRESULT; virtual; function NewSegment(Start, Stop: TReferenceTime; Rate: double): HRESULT; virtual; property Input: TBCTransformInputPin read FInput write FInput; property Output: TBCTransformOutputPin read FOutPut write FOutput; end; TBCTransformInputPin = class(TBCBaseInputPin) private FTransformFilter: TBCTransformFilter; public constructor Create(ObjectName: string; TransformFilter: TBCTransformFilter; out hr: HRESULT; Name: WideString); destructor destroy; override; function QueryId(out id: PWideChar): HRESULT; override; stdcall; // Grab and release extra interfaces if required function CheckConnect(Pin: IPin): HRESULT; override; function BreakConnect: HRESULT; override; function CompleteConnect(ReceivePin: IPin): HRESULT; override; // check that we can support this output type function CheckMediaType(mtIn: PAMMediaType): HRESULT; override; // set the connection media type function SetMediaType(mt: PAMMediaType): HRESULT; override; // --- IMemInputPin ----- // here's the next block of data from the stream. // AddRef it yourself if you need to hold it beyond the end // of this call. function Receive(pSample: IMediaSample): HRESULT; override; stdcall; // provide EndOfStream that passes straight downstream // (there is no queued data) function EndOfStream: HRESULT; override; stdcall; // passes it to CTransformFilter::BeginFlush function BeginFlush: HRESULT; override; stdcall; // passes it to CTransformFilter::EndFlush function EndFlush: HRESULT; override; stdcall; function NewSegment(Start, Stop: TReferenceTime; Rate: double): HRESULT; override; stdcall; // Check if it's OK to process samples function CheckStreaming: HRESULT; override; end; TBCTransformOutputPin = class(TBCBaseOutputPin) protected FTransformFilter: TBCTransformFilter; // implement IMediaPosition by passing upstream FPosition: IUnknown; public constructor Create(ObjectName: string; TransformFilter: TBCTransformFilter; out hr: HRESULT; Name: WideString); destructor destroy; override; // override to expose IMediaPosition function NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult; override; // --- TBCBaseOutputPin ------------ function QueryId(out Id: PWideChar): HRESULT; override; stdcall; // Grab and release extra interfaces if required function CheckConnect(Pin: IPin): HRESULT; override; function BreakConnect: HRESULT; override; function CompleteConnect(ReceivePin: IPin): HRESULT; override; // check that we can support this output type function CheckMediaType(mtOut: PAMMediaType): HRESULT; override; // set the connection media type function SetMediaType(pmt: PAMMediaType): HRESULT; override; // called from CBaseOutputPin during connection to ask for // the count and size of buffers we need. function DecideBufferSize(Alloc: IMemAllocator; Prop: PAllocatorProperties): HRESULT; override; // returns the preferred formats for a pin function GetMediaType(Position: integer; out MediaType: PAMMediaType): HRESULT; override; // inherited from IQualityControl via CBasePin function Notify(Sendr: IBaseFilter; q: TQuality): HRESULT; override; stdcall; end; // milenko start (added TBCVideoTransformFilter conversion) TBCVideoTransformFilter = class(TBCTransformFilter) public constructor Create(Name: WideString; Unk: IUnknown; clsid: TGUID); destructor Destroy; override; function EndFlush: HRESULT; override; // ================================================================= // ----- override these bits --------------------------------------- // ================================================================= // The following methods are in CTransformFilter which is inherited. // They are mentioned here for completeness // // These MUST be supplied in a derived class // // NOTE: // virtual HRESULT Transform(IMediaSample * pIn, IMediaSample *pOut); // virtual HRESULT CheckInputType(const CMediaType* mtIn) PURE; // virtual HRESULT CheckTransform // (const CMediaType* mtIn, const CMediaType* mtOut) PURE; // static CCOMObject * CreateInstance(LPUNKNOWN, HRESULT *); // virtual HRESULT DecideBufferSize // (IMemAllocator * pAllocator, ALLOCATOR_PROPERTIES *pprop) PURE; // virtual HRESULT GetMediaType(int iPosition, CMediaType *pMediaType) PURE; // // These MAY also be overridden // // virtual HRESULT StopStreaming(); // virtual HRESULT SetMediaType(PIN_DIRECTION direction,const CMediaType *pmt); // virtual HRESULT CheckConnect(PIN_DIRECTION dir,IPin *pPin); // virtual HRESULT BreakConnect(PIN_DIRECTION dir); // virtual HRESULT CompleteConnect(PIN_DIRECTION direction,IPin *pReceivePin); // virtual HRESULT EndOfStream(void); // virtual HRESULT BeginFlush(void); // virtual HRESULT EndFlush(void); // virtual HRESULT NewSegment // (REFERENCE_TIME tStart,REFERENCE_TIME tStop,double dRate); {$IFDEF PERF} // If you override this - ensure that you register all these ids // as well as any of your own, procedure RegisterPerfId; virtual; {$ENDIF} protected // =========== QUALITY MANAGEMENT IMPLEMENTATION ======================== // Frames are assumed to come in three types: // Type 1: an AVI key frame or an MPEG I frame. // This frame can be decoded with no history. // Dropping this frame means that no further frame can be decoded // until the next type 1 frame. // Type 1 frames are sync points. // Type 2: an AVI non-key frame or an MPEG P frame. // This frame cannot be decoded unless the previous type 1 frame was // decoded and all type 2 frames since have been decoded. // Dropping this frame means that no further frame can be decoded // until the next type 1 frame. // Type 3: An MPEG B frame. // This frame cannot be decoded unless the previous type 1 or 2 frame // has been decoded AND the subsequent type 1 or 2 frame has also // been decoded. (This requires decoding the frames out of sequence). // Dropping this frame affects no other frames. This implementation // does not allow for these. All non-sync-point frames are treated // as being type 2. // // The spacing of frames of type 1 in a file is not guaranteed. There MUST // be a type 1 frame at (well, near) the start of the file in order to start // decoding at all. After that there could be one every half second or so, // there could be one at the start of each scene (aka "cut", "shot") or // there could be no more at all. // If there is only a single type 1 frame then NO FRAMES CAN BE DROPPED // without losing all the rest of the movie. There is no way to tell whether // this is the case, so we find that we are in the gambling business. // To try to improve the odds, we record the greatest interval between type 1s // that we have seen and we bet on things being no worse than this in the // future. // You can tell if it's a type 1 frame by calling IsSyncPoint(). // there is no architected way to test for a type 3, so you should override // the quality management here if you have B-frames. FKeyFramePeriod: integer; // the largest observed interval between type 1 frames // 1 means every frame is type 1, 2 means every other. FFramesSinceKeyFrame: integer; // Used to count frames since the last type 1. // becomes the new m_nKeyFramePeriod if greater. FSkipping: Boolean; // we are skipping to the next type 1 frame {$IFDEF PERF} FidFrameType: integer; // MSR id Frame type. 1=Key, 2="non-key" FidSkip: integer; // MSR id skipping FidLate: integer; // MSR id lateness FidTimeTillKey: integer; // MSR id for guessed time till next key frame. {$ENDIF} FitrLate: integer; // lateness from last Quality message // (this overflows at 214 secs late). FtDecodeStart: integer; // timeGetTime when decode started. FitrAvgDecode: integer; // Average decode time in reference units. FNoSkip: Boolean; // debug - no skipping. // We send an EC_QUALITY_CHANGE notification to the app if we have to degrade. // We send one when we start degrading, not one for every frame, this means // we track whether we've sent one yet. FQualityChanged: Boolean; // When non-zero, don't pass anything to renderer until next keyframe // If there are few keys, give up and eventually draw something FWaitForKey: integer; function AbortPlayback(hr: HRESULT): HRESULT; // if something bad happens function ShouldSkipFrame(pIn: IMediaSample): Boolean; public function StartStreaming: HRESULT; override; function Receive(Sample: IMediaSample): HRESULT; override; function AlterQuality(const q: TQuality): HRESULT; override; end; // milenko end TBCTransInPlaceOutputPin = class; TBCTransInPlaceInputPin = class; TBCTransInPlaceFilter = class(TBCTransformFilter) public // map getpin/getpincount for base enum of pins to owner // override this to return more specialised pin objects function GetPin(n: integer): TBCBasePin; override; // Set bModifiesData == false if your derived filter does // not modify the data samples (for instance it's just copying // them somewhere else or looking at the timestamps). constructor Create(ObjectName: string; unk: IUnKnown; clsid: TGUID; out hr: HRESULT; ModifiesData: boolean = True); constructor CreateFromFactory(Factory: TBCClassFactory; const Controller: IUnknown); override; // The following are defined to avoid undefined pure virtuals. // Even if they are never called, they will give linkage warnings/errors // We override EnumMediaTypes to bypass the transform class enumerator // which would otherwise call this. function GetMediaType(Position: integer; out MediaType: PAMMediaType): HRESULT; override; // This is called when we actually have to provide out own allocator. function DecideBufferSize(Alloc: IMemAllocator; propInputRequest: PAllocatorProperties): HRESULT; override; // The functions which call this in CTransform are overridden in this // class to call CheckInputType with the assumption that the type // does not change. In Debug builds some calls will be made and // we just ensure that they do not assert. function CheckTransform(mtIn, mtOut: PAMMediaType): HRESULT; override; // ================================================================= // ----- You may want to override this ----------------------------- // ================================================================= function CompleteConnect(dir: TPinDirection; ReceivePin: IPin): HRESULT; override; // chance to customize the transform process function Receive(Sample: IMediaSample): HRESULT; override; // ================================================================= // ----- You MUST override these ----------------------------------- // ================================================================= function Transform(Sample: IMediaSample): HRESULT; reintroduce; virtual; abstract; // this goes in the factory template table to create new instances // static CCOMObject * CreateInstance(LPUNKNOWN, HRESULT *); protected FModifiesData: boolean; // Does this filter change the data? function Copy(Source: IMediaSample): IMediaSample; // these hold our input and output pins function InputPin: TBCTransInPlaceInputPin; function OutputPin: TBCTransInPlaceOutputPin; // Helper to see if the input and output types match function TypesMatch: boolean; // Are the input and output allocators different? function UsingDifferentAllocators: boolean; end; TBCTransInPlaceInputPin = class(TBCTransformInputPin) protected FTIPFilter: TBCTransInPlaceFilter; // our filter FReadOnly : boolean; // incoming stream is read only public constructor Create(ObjectName: string; Filter: TBCTransInPlaceFilter; out hr: HRESULT; Name: WideString); // --- IMemInputPin ----- // Provide an enumerator for media types by getting one from downstream function EnumMediaTypes(out ppEnum: IEnumMediaTypes): HRESULT; override; stdcall; // Say whether media type is acceptable. function CheckMediaType(pmt: PAMMediaType): HRESULT; override; // Return our upstream allocator function GetAllocator(out Allocator: IMemAllocator): HRESULT; stdcall; // get told which allocator the upstream output pin is actually // going to use. function NotifyAllocator(Allocator: IMemAllocator; ReadOnly: BOOL): HRESULT; stdcall; // Allow the filter to see what allocator we have // N.B. This does NOT AddRef function PeekAllocator: IMemAllocator; // Pass this on downstream if it ever gets called. function GetAllocatorRequirements(props: PAllocatorProperties): HRESULT; stdcall; property ReadOnly: Boolean read FReadOnly; end; // ================================================== // Implements the output pin // ================================================== TBCTransInPlaceOutputPin = class(TBCTransformOutputPin) protected // m_pFilter points to our CBaseFilter FTIPFilter: TBCTransInPlaceFilter; public constructor Create(ObjectName: string; Filter: TBCTransInPlaceFilter; out hr: HRESULT; Name: WideString); // --- CBaseOutputPin ------------ // negotiate the allocator and its buffer size/count // Insists on using our own allocator. (Actually the one upstream of us). // We don't override this - instead we just agree the default // then let the upstream filter decide for itself on reconnect // virtual HRESULT DecideAllocator(IMemInputPin * pPin, IMemAllocator ** pAlloc); // Provide a media type enumerator. Get it from upstream. function EnumMediaTypes(out ppEnum: IEnumMediaTypes): HRESULT; override; stdcall; // Say whether media type is acceptable. function CheckMediaType(pmt: PAMMediaType): HRESULT; override; // This just saves the allocator being used on the output pin // Also called by input pin's GetAllocator() procedure SetAllocator(Allocator: IMemAllocator); function ConnectedIMemInputPin: IMemInputPin; // Allow the filter to see what allocator we have // N.B. This does NOT AddRef function PeekAllocator: IMemAllocator; end; TBCBasePropertyPage = class(TBCUnknown, IPropertyPage) private FObjectSet: boolean; // SetObject has been called or not. protected FPageSite: IPropertyPageSite; // Details for our property site FDirty: boolean; // Has anything been changed FForm: TFormPropertyPage; public constructor Create(Name: String; Unk: IUnKnown; Form: TFormPropertyPage); destructor Destroy; override; procedure SetPageDirty; { IPropertyPage } function SetPageSite(const pageSite: IPropertyPageSite): HResult; stdcall; function Activate(hwndParent: HWnd; const rc: TRect; bModal: BOOL): HResult; stdcall; function Deactivate: HResult; stdcall; function GetPageInfo(out pageInfo: TPropPageInfo): HResult; stdcall; function SetObjects(cObjects: Longint; pUnkList: PUnknownList): HResult; stdcall; function Show(nCmdShow: Integer): HResult; stdcall; function Move(const rect: TRect): HResult; stdcall; function IsPageDirty: HResult; stdcall; function Apply: HResult; stdcall; function Help(pszHelpDir: POleStr): HResult; stdcall; function TranslateAccelerator(msg: PMsg): HResult; stdcall; end; TOnConnect = procedure(sender: Tobject; Unknown: IUnknown) of object; TFormPropertyPage = class(TForm, IUnKnown, IPropertyPage) private FPropertyPage: TBCBasePropertyPage; procedure MyWndProc(var aMsg: TMessage); public constructor Create(AOwner: TComponent); override; published function OnConnect(Unknown: IUnknown): HRESULT; virtual; function OnDisconnect: HRESULT; virtual; function OnApplyChanges: HRESULT; virtual; property PropertyPage : TBCBasePropertyPage read FPropertyPage implements IUnKnown, IPropertyPage; end; TBCBaseDispatch = class{IDispatch} protected FTI: ITypeInfo; public // IDispatch methods function GetTypeInfoCount(out Count: Integer): HResult; stdcall; function GetTypeInfo(const iid: TGUID; info: Cardinal; lcid: LCID; out tinfo): HRESULT; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; end; TBCMediaControl = class(TBCUnknown, IDispatch) public FBaseDisp: TBCBaseDispatch; constructor Create(name: string; unk: IUnknown); destructor Destroy; override; // IDispatch methods function GetTypeInfoCount(out Count: Integer): HResult; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; end; TBCMediaEvent = class(TBCUnknown, IDisPatch{,IMediaEventEx}) protected FBasedisp: TBCBaseDispatch; public constructor Create(Name: string; Unk: IUnknown); destructor destroy; override; // IDispatch methods function GetTypeInfoCount(out Count: Integer): HResult; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; end; TBCMediaPosition = class(TBCUnknown, IDispatch {IMediaPosition}) protected FBaseDisp: TBCBaseDispatch; public constructor Create(Name: String; Unk: IUnknown); overload; constructor Create(Name: String; Unk: IUnknown; out hr: HRESULT); overload; destructor Destroy; override; // IDispatch methods function GetTypeInfoCount(out Count: Integer): HResult; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; end; // A utility class that handles IMediaPosition and IMediaSeeking on behalf // of single-input pin renderers, or transform filters. // // Renderers will expose this from the filter; transform filters will // expose it from the output pin and not the renderer. // // Create one of these, giving it your IPin* for your input pin, and delegate // all IMediaPosition methods to it. It will query the input pin for // IMediaPosition and respond appropriately. // // Call ForceRefresh if the pin connection changes. // // This class no longer caches the upstream IMediaPosition or IMediaSeeking // it acquires it on each method call. This means ForceRefresh is not needed. // The method is kept for source compatibility and to minimise the changes // if we need to put it back later for performance reasons. TBCPosPassThru = class(TBCMediaPosition, IMediaSeeking) protected FPin: IPin; function GetPeer(out MP: IMediaPosition): HRESULT; function GetPeerSeeking(out MS: IMediaSeeking): HRESULT; public constructor Create(name: String; Unk: IUnknown; out hr: HRESULT; Pin: IPin); function ForceRefresh: HRESULT;{return S_OK;} // override to return an accurate current position function GetMediaTime(out StartTime, EndTime: int64): HRESULT; virtual; // IMediaSeeking methods function GetCapabilities(out pCapabilities: DWORD): HRESULT; stdcall; function CheckCapabilities(var pCapabilities: DWORD): HRESULT; stdcall; function IsFormatSupported(const pFormat: TGUID): HRESULT; stdcall; function QueryPreferredFormat(out pFormat: TGUID): HRESULT; stdcall; function GetTimeFormat(out pFormat: TGUID): HRESULT; stdcall; function IsUsingTimeFormat(const pFormat: TGUID): HRESULT; stdcall; function SetTimeFormat(const pFormat: TGUID): HRESULT; stdcall; function GetDuration(out pDuration: int64): HRESULT; stdcall; function GetStopPosition(out pStop: int64): HRESULT; stdcall; function GetCurrentPosition(out pCurrent: int64): HRESULT; stdcall; function ConvertTimeFormat(out pTarget: int64; pTargetFormat: PGUID; Source: int64; pSourceFormat: PGUID): HRESULT; stdcall; function SetPositions(var pCurrent: int64; dwCurrentFlags: DWORD; var pStop: int64; dwStopFlags: DWORD): HRESULT; stdcall; function GetPositions(out pCurrent, pStop: int64): HRESULT; stdcall; function GetAvailable(out pEarliest, pLatest: int64): HRESULT; stdcall; function SetRate(dRate: double): HRESULT; stdcall; function GetRate(out pdRate: double): HRESULT; stdcall; function GetPreroll(out pllPreroll: int64): HRESULT; stdcall; // IMediaPosition properties function get_Duration(out plength: TRefTime): HResult; stdcall; function put_CurrentPosition(llTime: TRefTime): HResult; stdcall; function get_CurrentPosition(out pllTime: TRefTime): HResult; stdcall; function get_StopTime(out pllTime: TRefTime): HResult; stdcall; function put_StopTime(llTime: TRefTime): HResult; stdcall; function get_PrerollTime(out pllTime: TRefTime): HResult; stdcall; function put_PrerollTime(llTime: TRefTime): HResult; stdcall; function put_Rate(dRate: double): HResult; stdcall; function get_Rate(out pdRate: double): HResult; stdcall; function CanSeekForward(out pCanSeekForward: Longint): HResult; stdcall; function CanSeekBackward(out pCanSeekBackward: Longint): HResult; stdcall; end; TBCRendererPosPassThru = class(TBCPosPassThru) protected FPositionLock: TBCCritSec; // Locks access to our position FStartMedia : Int64; // Start media time last seen FEndMedia : Int64; // And likewise the end media FReset : boolean; // Have media times been set public // Used to help with passing media times through graph constructor Create(name: String; Unk: IUnknown; out hr: HRESULT; Pin: IPin); reintroduce; destructor destroy; override; function RegisterMediaTime(MediaSample: IMediaSample): HRESULT; overload; function RegisterMediaTime(StartTime, EndTime: int64): HRESULT; overload; function GetMediaTime(out StartTime, EndTime: int64): HRESULT; override; function ResetMediaTime: HRESULT; function EOS: HRESULT; end; // wrapper for event objects TBCAMEvent = class protected FEvent: THANDLE; public constructor Create(ManualReset: boolean = false); destructor destroy; override; property Handle: THandle read FEvent; procedure SetEv; function Wait(Timeout: Cardinal = INFINITE): boolean; procedure Reset; function Check: boolean; end; TBCTimeoutEvent = TBCAMEvent; // wrapper for event objects that do message processing // This adds ONE method to the CAMEvent object to allow sent // messages to be processed while waiting TBCAMMsgEvent = class(TBCAMEvent) public // Allow SEND messages to be processed while waiting function WaitMsg(Timeout: DWord = INFINITE): boolean; end; // support for a worker thread // simple thread class supports creation of worker thread, synchronization // and communication. Can be derived to simplify parameter passing TThreadProc = function: DWORD of object; TBCAMThread = class private FEventSend: TBCAMEvent; FEventComplete: TBCAMEvent; FParam: DWord; FReturnVal: DWord; FThreadProc: TThreadProc; protected FThread: THandle; // thread will run this function on startup // must be supplied by derived class function ThreadProc: DWord; virtual; public FAccessLock: TBCCritSec; // locks access by client threads FWorkerLock: TBCCritSec; // locks access to shared objects constructor Create; destructor Destroy; override; // thread initially runs this. param is actually 'this'. function // just gets this and calls ThreadProc function InitialThreadProc(p: Pointer): DWORD; virtual; stdcall; // WINAPI; // start thread running - error if already running function Create_: boolean; // signal the thread, and block for a response // function CallWorker(Param: DWORD): DWORD; // accessor thread calls this when done with thread (having told thread // to exit) procedure Close; // ThreadExists // Return True if the thread exists. FALSE otherwise function ThreadExists: boolean; // const // wait for the next request function GetRequest: DWORD; // is there a request? function CheckRequest(Param: PDWORD): boolean; // reply to the request procedure Reply(v: DWORD); // If you want to do WaitForMultipleObjects you'll need to include // this handle in your wait list or you won't be responsive function GetRequestHandle: THANDLE; // Find out what the request was function GetRequestParam: DWORD; // call CoInitializeEx (COINIT_DISABLE_OLE1DDE) if // available. S_FALSE means it's not available. class function CoInitializeHelper: HRESULT; end; TBCRenderedInputPin = class(TBCBaseInputPin) private procedure DoCompleteHandling; protected // Member variables to track state FAtEndOfStream : boolean; // Set by EndOfStream FCompleteNotified : boolean; // Set when we notify for EC_COMPLETE public constructor Create(ObjectName: string; Filter: TBCBaseFilter; Lock: TBCCritSec; out hr: HRESULT; Name: WideString); // Override methods to track end of stream state function EndOfStream: HRESULT; override; stdcall; function EndFlush: HRESULT; override; stdcall; function Active: HRESULT; override; function Run(Start: TReferenceTime): HRESULT; override; end; (* A generic list of pointers to objects. No storage management or copying is done on the objects pointed to. Objectives: avoid using MFC libraries in ndm kernel mode and provide a really useful list type. The class is thread safe in that separate threads may add and delete items in the list concurrently although the application must ensure that constructor and destructor access is suitably synchronised. An application can cause deadlock with operations which use two lists by simultaneously calling list1->Operation(list2) and list2->Operation(list1). So don't! The names must not conflict with MFC classes as an application may use both. *) (* A POSITION represents (in some fashion that's opaque) a cursor on the list that can be set to identify any element. NULL is a valid value and several operations regard NULL as the position "one step off the end of the list". (In an n element list there are n+1 places to insert and NULL is that "n+1-th" value). The POSITION of an element in the list is only invalidated if that element is deleted. Move operations may mean that what was a valid POSITION in one list is now a valid POSITION in a different list. Some operations which at first sight are illegal are allowed as harmless no-ops. For instance RemoveHead is legal on an empty list and it returns NULL. This allows an atomic way to test if there is an element there, and if so, get it. The two operations AddTail and RemoveHead thus implement a MONITOR (See Hoare's paper). Single element operations return POSITIONs, non-NULL means it worked. whole list operations return a BOOL. True means it all worked. This definition is the same as the POSITION type for MFCs, so we must avoid defining it twice. *) Position = Pointer; {$ifdef DEBUG} TBCNode = class(TBCBaseObject) {$else} TBCNode = class {$endif} private FPrev: TBCNode; // Previous node in the list FNext: TBCNode; // Next node in the list FObject: Pointer; // Pointer to the object public // Constructor - initialise the object's pointers {$ifdef DEBUG} constructor Create; {$endif} // Return the previous node before this one property Prev: TBCNode read FPrev write FPrev; // Return the next node after this one property Next: TBCNode read FNext write FNext; // Get the pointer to the object for this node */ property Data: Pointer read FObject write FObject; end; TBCNodeCache = class private FCacheSize: Integer; FUsed: Integer; FHead: TBCNode; public constructor Create(CacheSize: Integer); destructor Destroy; override; procedure AddToCache(Node: TBCNode); function RemoveFromCache: TBCNode; end; (* A class representing one node in a list. Each node knows a pointer to it's adjacent nodes and also a pointer to the object that it looks after. All of these pointers can be retrieved or set through member functions. *) TBCBaseList = class {$ifdef DEBUG} (TBCBaseObject) {$endif} (* Making these classes inherit from CBaseObject does nothing functionally but it allows us to check there are no memory leaks in debug builds. *) protected FFirst: TBCNode; // Pointer to first node in the list FLast: TBCNode; // Pointer to the last node in the list FCount: LongInt; // Number of nodes currently in the list private FCache: TBCNodeCache; // Cache of unused node pointers public constructor Create(Name: string; Items: Integer = DEFAULTCACHE); destructor Destroy; override; // Remove all the nodes from self i.e. make the list empty procedure RemoveAll; // Return a cursor which identifies the first element of self function GetHeadPositionI: Position; /// Return a cursor which identifies the last element of self function GetTailPositionI: Position; // Return the number of objects in self function GetCountI: Integer; protected (* Return the pointer to the object at rp, Update rp to the next node in self but make it nil if it was at the end of self. This is a wart retained for backwards compatibility. GetPrev is not implemented. Use Next, Prev and Get separately. *) function GetNextI(var rp: Position): Pointer; (* Return a pointer to the object at p Asking for the object at nil will return nil harmlessly. *) function GetI(p: Position): Pointer; public (* return the next / prev position in self return NULL when going past the end/start. Next(nil) is same as GetHeadPosition() Prev(nil) is same as GetTailPosition() An n element list therefore behaves like a n+1 element cycle with nil at the start/end. !!WARNING!! - This handling of nil is DIFFERENT from GetNext. Some reasons are: 1. For a list of n items there are n+1 positions to insert These are conveniently encoded as the n POSITIONs and nil. 2. If you are keeping a list sorted (fairly common) and you search forward for an element to insert before and don't find it you finish up with nil as the element before which to insert. You then want that nil to be a valid POSITION so that you can insert before it and you want that insertion point to mean the (n+1)-th one that doesn't have a POSITION. (symmetrically if you are working backwards through the list). 3. It simplifies the algebra which the methods generate. e.g. AddBefore(p,x) is identical to AddAfter(Prev(p),x) in ALL cases. All the other arguments probably are reflections of the algebraic point. *) function Next(pos: Position): Position; function Prev(pos: Position): Position; (* Return the first position in self which holds the given pointer. Return nil if the pointer was not not found. *) protected function FindI(Obj: Pointer): Position; (* Remove the first node in self (deletes the pointer to its object from the list, does not free the object itself). Return the pointer to its object. If self was already empty it will harmlessly return nil. *) function RemoveHeadI: Pointer; (* Remove the last node in self (deletes the pointer to its object from the list, does not free the object itself). Return the pointer to its object. If self was already empty it will harmlessly return nil. *) function RemoveTailI: Pointer; (* Remove the node identified by p from the list (deletes the pointer to its object from the list, does not free the object itself). Asking to Remove the object at nil will harmlessly return nil. Return the pointer to the object removed. *) function RemoveI(pos: Position): Pointer; (* Add single object *pObj to become a new last element of the list. Return the new tail position, nil if it fails. If you are adding a COM objects, you might want AddRef it first. Other existing POSITIONs in self are still valid *) function AddTailI(Obj: Pointer): Position; public (* Add all the elements in *pList to the tail of self. This duplicates all the nodes in *pList (i.e. duplicates all its pointers to objects). It does not duplicate the objects. If you are adding a list of pointers to a COM object into the list it's a good idea to AddRef them all it when you AddTail it. Return True if it all worked, FALSE if it didn't. If it fails some elements may have been added. Existing POSITIONs in self are still valid If you actually want to MOVE the elements, use MoveToTail instead. *) function AddTail(List: TBCBaseList): boolean; // Mirror images of AddHead: (* Add single object to become a new first element of the list. Return the new head position, nil if it fails. Existing POSITIONs in self are still valid *) protected function AddHeadI(Obj: Pointer): Position; public (* Add all the elements in *pList to the head of self. Same warnings apply as for AddTail. Return True if it all worked, FALSE if it didn't. If it fails some of the objects may have been added. If you actually want to MOVE the elements, use MoveToHead instead. *) function AddHead(List: TBCBaseList): BOOL; (* Add the object *pObj to self after position p in self. AddAfter(nil,x) adds x to the start - equivalent to AddHead Return the position of the object added, nil if it failed. Existing POSITIONs in self are undisturbed, including p. *) protected function AddAfterI(pos: Position; Obj: Pointer): Position; public (* Add the list *pList to self after position p in self AddAfter(nil,x) adds x to the start - equivalent to AddHead Return True if it all worked, FALSE if it didn't. If it fails, some of the objects may be added Existing POSITIONs in self are undisturbed, including p. *) function AddAfter(p: Position; List: TBCBaseList): BOOL; (* Mirror images: Add the object *pObj to this-List after position p in self. AddBefore(nil,x) adds x to the end - equivalent to AddTail Return the position of the new object, nil if it fails Existing POSITIONs in self are undisturbed, including p. *) protected function AddBeforeI(pos: Position; Obj: Pointer): Position; public (* Add the list *pList to self before position p in self AddAfter(nil,x) adds x to the start - equivalent to AddHead Return True if it all worked, FALSE if it didn't. If it fails, some of the objects may be added Existing POSITIONs in self are undisturbed, including p. *) function AddBefore(p: Position; List: TBCBaseList): BOOL; (* Note that AddAfter(p,x) is equivalent to AddBefore(Next(p),x) even in cases where p is nil or Next(p) is nil. Similarly for mirror images etc. This may make it easier to argue about programs. *) (* The following operations do not copy any elements. They move existing blocks of elements around by switching pointers. They are fairly efficient for long lists as for short lists. (Alas, the Count slows things down). They split the list into two parts. One part remains as the original list, the other part is appended to the second list. There are eight possible variations: Split the list {after/before} a given element keep the {head/tail} portion in the original list append the rest to the {head/tail} of the new list. Since After is strictly equivalent to Before Next we are not in serious need of the Before/After variants. That leaves only four. If you are processing a list left to right and dumping the bits that you have processed into another list as you go, the Tail/Tail variant gives the most natural result. If you are processing in reverse order, Head/Head is best. By using nil positions and empty lists judiciously either of the other two can be built up in two operations. The definition of nil (see Next/Prev etc) means that degenerate cases include "move all elements to new list" "Split a list into two lists" "Concatenate two lists" (and quite a few no-ops) !!WARNING!! The type checking won't buy you much if you get list positions muddled up - e.g. use a POSITION that's in a different list and see what a mess you get! *) (* 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(nil, bar); is a no-op, returns nil 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 MoveToTail(pos: Position; List: TBCBaseList): boolean; (* Mirror image: 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 e.g. foo->MoveToHead(foo->GetTailPosition(), bar); moves one element from the tail of foo to the head of bar foo->MoveToHead(nil, bar); is a no-op, returns nil foo->MoveToHead(foo->GetHeadPosition, bar); concatenates foo onto the start of bar and empties foo. *) function MoveToHead(pos: Position; List: TBCBaseList): boolean; (* Reverse the order of the [pointers to] objects in self *) procedure Reverse; end; // Desc: DirectShow base classes - defines classes to simplify creation of // ActiveX source filters that support continuous generation of data. // No support is provided for IMediaControl or IMediaPosition. // // Derive your source filter from CSource. // During construction either: // Create some CSourceStream objects to manage your pins // Provide the user with a means of doing so eg, an IPersistFile interface. // // CSource provides: // IBaseFilter interface management // IMediaFilter interface management, via CBaseFilter // Pin counting for CBaseFilter // // Derive a class from CSourceStream to manage your output pin types // Implement GetMediaType/1 to return the type you support. If you support multiple // types then overide GetMediaType/3, CheckMediaType and GetMediaTypeCount. // Implement Fillbuffer() to put data into one buffer. // // CSourceStream provides: // IPin management via CBaseOutputPin // Worker thread management // Override construction to provide a means of creating // CSourceStream derived objects - ie a way of creating pins. TBCSourceStream = class; TStreamArray = array of TBCSourceStream; TBCSource = class(TBCBaseFilter) protected FPins: Integer; // The number of pins on this filter. Updated by CSourceStream FStreams: Pointer; // the pins on this filter. FStateLock: TBCCritSec; public constructor Create(const Name: string; unk: IUnknown; const clsid: TGUID; out hr: HRESULT); overload; constructor Create(const Name: string; unk: IUnknown; const clsid: TGUID); overload; destructor Destroy; override; function GetPinCount: Integer; override; function GetPin(n: Integer): TBCBasePin; override; // -- Utilities -- property StateLock: TBCCritSec read FStateLock; // provide our critical section function AddPin(Stream: TBCSourceStream): HRESULT; function RemovePin(Stream: TBCSourceStream): HRESULT; function FindPin(Id: PWideChar; out Pin: IPin): HRESULT; override; function FindPinNumber(Pin: IPin): Integer; end; // // CSourceStream // // Use this class to manage a stream of data that comes from a // pin. // Uses a worker thread to put data on the pin. TThreadCommand = ( CMD_INIT, CMD_PAUSE, CMD_RUN, CMD_STOP, CMD_EXIT ); TBCSourceStream = class(TBCBaseOutputPin) public constructor Create(const ObjectName: string; out hr: HRESULT; Filter: TBCSource; const Name: WideString); destructor Destroy; override; protected FThread: TBCAMThread; FFilter: TBCSource; // The parent of this stream // * // * Data Source // * // * The following three functions: FillBuffer, OnThreadCreate/Destroy, are // * called from within the ThreadProc. They are used in the creation of // * the media samples this pin will provide // * // Override this to provide the worker thread a means // of processing a buffer function FillBuffer(Samp: IMediaSample): HRESULT; virtual; abstract; // Called as the thread is created/destroyed - use to perform // jobs such as start/stop streaming mode // If OnThreadCreate returns an error the thread will exit. function OnThreadCreate: HRESULT; virtual; function OnThreadDestroy: HRESULT; virtual; function OnThreadStartPlay: HRESULT; virtual; public // * // * Worker Thread // * function Active: HRESULT; override; // Starts up the worker thread function Inactive: HRESULT; override; // Exits the worker thread. // thread commands function Init: HRESULT; function Exit_: HRESULT; function Run: HRESULT; reintroduce; function Pause: HRESULT; function Stop: HRESULT; // * // * AM_MEDIA_TYPE support // * // If you support more than one media type then override these 2 functions function CheckMediaType(MediaType: PAMMediaType): HRESULT; override; function GetMediaType(Position: integer; out MediaType: PAMMediaType): HRESULT; overload; override; // List pos. 0-n // If you support only one type then override this fn. // This will only be called by the default implementations // of CheckMediaType and GetMediaType(int, CMediaType*) // You must override this fn. or the above 2! function GetMediaType(MediaType: PAMMediaType): HRESULT; reintroduce; overload; virtual; function QueryId(out id: PWideChar): HRESULT; override; protected function GetRequest: TThreadCommand; function CheckRequest(var com: TThreadCommand): boolean; // override these if you want to add thread commands function ThreadProc: DWORD; virtual; // the thread function function DoBufferProcessingLoop: HRESULT; virtual; // the loop executed whilst running end; TBCBaseRenderer = class; TBCRendererInputPin = class; // This is our input pin class that channels calls to the renderer TBCRendererInputPin = class(TBCBaseInputPin) protected FRenderer: TBCBaseRenderer; public constructor Create(Renderer: TBCBaseRenderer; out hr: HResult; Name: PWideChar); // Overriden from the base pin classes function BreakConnect: HResult; override; function CompleteConnect(ReceivePin: IPin): HResult; override; function SetMediaType(MediaType: PAMMediaType): HResult; override; function CheckMediaType(MediaType: PAMMediaType): HResult; override; function Active: HResult; override; function Inactive: HResult; override; // Add rendering behaviour to interface functions function QueryId(out Id: PWideChar): HResult; override; stdcall; function EndOfStream: HResult; override; stdcall; function BeginFlush: HResult; override; stdcall; function EndFlush: HResult; override; stdcall; function Receive(MediaSample: IMediaSample): HResult; override; stdcall; function InheritedReceive(MediaSample: IMediaSample): HResult; virtual; stdcall; end; // Main renderer class that handles synchronisation and state changes TBCBaseRenderer = class(TBCBaseFilter) protected // friend class CRendererInputPin; //FEndOfStreamTimerCB: TFNTimeCallBack; // Media seeking pass by object FPosition: TBCRendererPosPassThru; //FPosition: IUnknown; // Used to signal timer events FRenderEvent: TBCAMEvent; // Signalled to release worker thread FThreadSignal: TBCAMEvent; // Signalled when state complete FCompleteEvent: TBCAMEvent; // Stop us from rendering more data FAbort: Boolean; // Are we currently streaming FIsStreaming: Boolean; // Timer advise cookie FAdvisedCookie: DWord; // Current image media sample FMediaSample: IMediaSample; // Any more samples in the stream FIsEOS: Boolean; // Have we delivered an EC_COMPLETE FIsEOSDelivered: Boolean; // Our renderer input pin object FInputPin: TBCRendererInputPin; // Critical section for interfaces FInterfaceLock: TBCCritSec; // Controls access to internals FRendererLock: TBCCritSec; // QualityControl sink FQSink: IQualityControl; // Can we signal an EC_REPAINT FRepaintStatus: Boolean; // Avoid some deadlocks by tracking filter during stop // Inside Receive between PrepareReceive and actually processing the sample FInReceive: Boolean; // Time when we signal EC_COMPLETE FSignalTime: TReferenceTime; // Used to signal end of stream FEndOfStreamTimer: DWord; // This lock protects the creation and of FPosition and FInputPin. // It ensures that two threads cannot create either object simultaneously. FObjectCreationLock: TBCCritSec; // Milenko start (must be outside of the class and with stdcall; or it will crash) // procedure EndOfStreamTimer( // uID: UINT; // Timer identifier // uMsg: UINT; // Not currently used // dwUser: DWord; // User information // dw1: DWord; // Windows reserved // dw2: DWord // Is also reserved // ); stdcall; // Milenko end public {$IFDEF PERF} // Just before we started drawing // Set in OnRenderStart, Used in OnRenderEnd FRenderStart: TReferenceTime; // MSR_id for frame time stamp FBaseStamp: Integer; // MSR_id for true wait time FBaseRenderTime: Integer; // MSR_id for time frame is late (int) FBaseAccuracy: Integer; {$ENDIF} constructor Create( // CLSID for this renderer RendererClass: TGUID; // Debug ONLY description Name: PChar; // Aggregated owner object Unk: IUnknown; // General OLE return code hr: HResult); destructor Destroy; override; // milenko start (added as a workaround for the TBCRendererPosPAssThru/FPosition and Renderer destructor) function JoinFilterGraph(pGraph: IFilterGraph; pName: PWideChar): HRESULT; override; // milenko end // Overriden to say what interfaces we support and where function GetMediaPositionInterface(IID: TGUID; out Obj): HResult; virtual; function NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall; function SourceThreadCanWait(CanWait: Boolean): HResult; virtual; {$IFDEF DEBUG} // Debug only dump of the renderer state procedure DisplayRendererState; {$ENDIF} function WaitForRenderTime: HResult; virtual; function CompleteStateChange(OldState: TFilterState): HResult; virtual; // Return internal information about this filter property IsEndOfStream: Boolean read FIsEOS; property IsEndOfStreamDelivered: Boolean read FIsEOSDelivered; property IsStreaming: Boolean read FIsStreaming; procedure SetAbortSignal(Abort_: Boolean); procedure OnReceiveFirstSample(MediaSample: IMediaSample); virtual; property RenderEvent: TBCAMEvent read FRenderEvent; // Permit access to the transition state procedure Ready; procedure NotReady; function CheckReady: Boolean; function GetPinCount: Integer; override; function GetPin(n: integer): TBCBasePin; override; function GetRealState: TFilterState; procedure SendRepaint; procedure SendNotifyWindow(Pin: IPin; Handle: HWND); function OnDisplayChange: Boolean; procedure SetRepaintStatus(Repaint: Boolean); // Override the filter and pin interface functions function Stop: HResult; override; stdcall; function Pause: HResult; override; stdcall; function Run(StartTime: TReferenceTime): HResult; override; stdcall; function GetState(MSecs: DWord; out State: TFilterState): HResult; override; stdcall; function FindPin(id: PWideChar; out Pin: IPin): HResult; override; stdcall; // These are available for a quality management implementation procedure OnRenderStart(MediaSample: IMediaSample); virtual; procedure OnRenderEnd(MediaSample: IMediaSample); virtual; function OnStartStreaming: HResult; virtual; function OnStopStreaming: HResult; virtual; procedure OnWaitStart; virtual; procedure OnWaitEnd; virtual; procedure PrepareRender; virtual; // Quality management implementation for scheduling rendering function ScheduleSample(MediaSample: IMediaSample): Boolean; virtual; function GetSampleTimes(MediaSample: IMediaSample; out StartTime: TReferenceTime; out EndTime: TReferenceTime): HResult; virtual; function ShouldDrawSampleNow(MediaSample: IMediaSample; StartTime: TReferenceTime; out EndTime: TReferenceTime): HResult; virtual; // Lots of end of stream complexities procedure TimerCallback; procedure ResetEndOfStreamTimer; function NotifyEndOfStream: HResult; function SendEndOfStream: HResult; virtual; function ResetEndOfStream: HResult; virtual; function EndOfStream: HResult; virtual; // Rendering is based around the clock procedure SignalTimerFired; function CancelNotification: HResult; virtual; function ClearPendingSample: HResult; virtual; // Called when the filter changes state function Active: HResult; virtual; function Inactive: HResult; virtual; function StartStreaming: HResult; virtual; function StopStreaming: HResult; virtual; function BeginFlush: HResult; virtual; function EndFlush: HResult; virtual; // Deal with connections and type changes function BreakConnect: HResult; virtual; function SetMediaType(MediaType: PAMMediaType): HResult; virtual; function CompleteConnect(ReceivePin: IPin): HResult; virtual; // These look after the handling of data samples function PrepareReceive(MediaSample: IMediaSample): HResult; virtual; function Receive(MediaSample: IMediaSample): HResult; virtual; function HaveCurrentSample: Boolean; virtual; function GetCurrentSample: IMediaSample; virtual; function Render(MediaSample: IMediaSample): HResult; virtual; // Derived classes MUST override these function DoRenderSample(MediaSample: IMediaSample): HResult; virtual; abstract; function CheckMediaType(MediaType: PAMMediaType): HResult; virtual; abstract; // Helper procedure WaitForReceiveToComplete; (* // callback property EndOfStreamTimerCB: TFNTimeCallBack read FEndOfStreamTimerCB write FEndOfStreamTimerCB; *) end; const AVGPERIOD = 4; type // CBaseVideoRenderer is a renderer class (see its ancestor class) and // it handles scheduling of media samples so that they are drawn at the // correct time by the reference clock. It implements a degradation // strategy. Possible degradation modes are: // Drop frames here (only useful if the drawing takes significant time) // Signal supplier (upstream) to drop some frame(s) - i.e. one-off skip. // Signal supplier to change the frame rate - i.e. ongoing skipping. // Or any combination of the above. // In order to determine what's useful to try we need to know what's going // on. This is done by timing various operations (including the supplier). // This timing is done by using timeGetTime as it is accurate enough and // usually cheaper than calling the reference clock. It also tells the // truth if there is an audio break and the reference clock stops. // We provide a number of public entry points (named OnXxxStart, OnXxxEnd) // which the rest of the renderer calls at significant moments. These do // the timing. // the number of frames that the sliding averages are averaged over. // the rule is (1024*NewObservation + (AVGPERIOD-1) * PreviousAverage)/AVGPERIOD // #define DO_MOVING_AVG(avg,obs) (avg = (1024*obs + (AVGPERIOD-1)*avg)/AVGPERIOD) // Spot the bug in this macro - I can't. but it doesn't work! TBCBaseVideoRenderer = class( // Base renderer class TBCBaseRenderer, // Property page guff IQualProp, // Allow throttling IQualityControl) protected //****************************************************************** // State variables to control synchronisation //****************************************************************** // Control of sending Quality messages. We need to know whether // we are in trouble (e.g. frames being dropped) and where the time // is being spent. // When we drop a frame we play the next one early. // The frame after that is likely to wait before drawing and counting this // wait as spare time is unfair, so we count it as a zero wait. // We therefore need to know whether we are playing frames early or not. // The number of consecutive frames drawn at their normal time (not early) // -1 means we just dropped a frame. FNormal: Integer; {$IFDEF PERF} // Don't drop any frames (debug and I'm not keen on people using it!) FDrawLateFrames: Bool; {$ENDIF} // The response to Quality messages says our supplier is handling things. // We will allow things to go extra late before dropping frames. // We will play very early after he has dropped one. FSupplierHandlingQuality: Boolean; // Control of scheduling, frame dropping etc. // We need to know where the time is being spent so as to tell whether // we should be taking action here, signalling supplier or what. // The variables are initialised to a mode of NOT dropping frames. // They will tell the truth after a few frames. // We typically record a start time for an event, later we get the time // again and subtract to get the elapsed time, and we average this over // a few frames. The average is used to tell what mode we are in. // Although these are reference times (64 bit) they are all DIFFERENCES // between times which are small. An int will go up to 214 secs before // overflow. Avoiding 64 bit multiplications and divisions seems // worth while. // Audio-video throttling. If the user has turned up audio quality // very high (in principle it could be any other stream, not just audio) // then we can receive cries for help via the graph manager. In this case // we put in a wait for some time after rendering each frame. FThrottle: Integer; // The time taken to render (i.e. BitBlt) frames controls which component // needs to degrade. If the blt is expensive, the renderer degrades. // If the blt is cheap it's done anyway and the supplier degrades. // Time frames are taking to blt FRenderAvg: Integer; // Time for last frame blt FRenderLast: Integer; // Just before we started drawing (mSec) derived from timeGetTime. FRenderStart: Integer; // When frames are dropped we will play the next frame as early as we can. // If it was a false alarm and the machine is fast we slide gently back to // normal timing. To do this, we record the offset showing just how early // we really are. This will normally be negative meaning early or zero. FEarliness: Integer; // Target provides slow long-term feedback to try to reduce the // average sync offset to zero. Whenever a frame is actually rendered // early we add a msec or two, whenever late we take off a few. // We add or take off 1/32 of the error time. // Eventually we should be hovering around zero. For a really bad case // where we were (say) 300mSec off, it might take 100 odd frames to // settle down. The rate of change of this is intended to be slower // than any other mechanism in Quartz, thereby avoiding hunting. FTarget: Integer; // The proportion of time spent waiting for the right moment to blt // controls whether we bother to drop a frame or whether we reckon that // we're doing well enough that we can stand a one-frame glitch. // Average of last few wait times (actually we just average how early we were). // Negative here means LATE. FWaitAvg: Integer; // The average inter-frame time. // This is used to calculate the proportion of the time used by the // three operations (supplying us, waiting, rendering) // Average inter-frame time FFrameAvg: Integer; // duration of last frame. FDuration: Integer; {$IFDEF PERF} // Performance logging identifiers // MSR_id for frame time stamp FTimeStamp: Integer; // MSR_id for true wait time FWaitReal: Integer; // MSR_id for wait time recorded FWait: Integer; // MSR_id for time frame is late (int) FFrameAccuracy: Integer; // MSR_id for lateness at scheduler FSchLateTime: Integer; // MSR_id for Quality rate requested FQualityRate: Integer; // MSR_id for Quality time requested FQualityTime: Integer; // MSR_id for decision code FDecision: Integer; // MSR_id for trace style debugging FDebug: Integer; // MSR_id for timing the notifications per se FSendQuality: Integer; {$ENDIF} // original time stamp of frame with no earliness fudges etc. FRememberStampforPerf: TReferenceTime; {$IFDEF PERF} // time when previous frame rendered FRememberFrameForPerf: TReferenceTime; {$ENDIF} // PROPERTY PAGE // This has edit fields that show the user what's happening // These member variables hold these counts. // cumulative frames dropped IN THE RENDERER FFramesDropped: Integer; // Frames since streaming started seen BY THE RENDERER // (some may be dropped upstream) FFramesDrawn: Integer; // Next two support average sync offset and standard deviation of sync offset. // Sum of accuracies in mSec FTotAcc: Int64; // Sum of squares of (accuracies in mSec) FSumSqAcc: Int64; // Next two allow jitter calculation. Jitter is std deviation of frame time. // Time of prev frame (for inter-frame times) FLastDraw: TReferenceTime; // Sum of squares of (inter-frame time in mSec) FSumSqFrameTime: Int64; // Sum of inter-frame times in mSec FSumFrameTime: Int64; // To get performance statistics on frame rate, jitter etc, we need // to record the lateness and inter-frame time. What we actually need are the // data above (sum, sum of squares and number of entries for each) but the data // is generated just ahead of time and only later do we discover whether the // frame was actually drawn or not. So we have to hang on to the data // hold onto frame lateness FLate: Integer; // hold onto inter-frame time FFrame: Integer; // if streaming then time streaming started // else time of last streaming session // used for property page statistics FStreamingStart: Integer; {$IFDEF PERF} // timeGetTime*10000+m_llTimeOffset==ref time FTimeOffset: Int64; {$ENDIF} public constructor Create( // CLSID for this renderer RenderClass: TGUID; // Debug ONLY description Name: PChar; // Aggregated owner object Unk: IUnknown; // General OLE return code hr: HResult); destructor Destroy; override; function NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall; // IQualityControl methods - Notify allows audio-video throttling function SetSink(QualityControl: IQualityControl): HResult; stdcall; function Notify(Filter: IBaseFilter; q: TQuality): HResult; stdcall; // These provide a full video quality management implementation procedure OnRenderStart(MediaSample: IMediaSample); override; procedure OnRenderEnd(MediaSample: IMediaSample); override; procedure OnWaitStart; reintroduce; procedure OnWaitEnd; reintroduce; function OnStartStreaming: HResult; reintroduce; function OnStopStreaming: HResult; reintroduce; procedure ThrottleWait; // Handle the statistics gathering for our quality management procedure PreparePerformanceData(Late, Frame: Integer); procedure RecordFrameLateness(Late, Frame: Integer); virtual; procedure OnDirectRender(MediaSample: IMediaSample); virtual; function ResetStreamingTimes: HResult; virtual; function ScheduleSample(MediaSample: IMediaSample): Boolean; override; function ShouldDrawSampleNow(MediaSample: IMediaSample; StartTime: TReferenceTime; out EndTime: TReferenceTime): HResult; override; function SendQuality(Late, RealStream: TReferenceTime): HResult; virtual; // milenko start (TBCBaseFilter made virtual, so just add override here) function JoinFilterGraph(Graph: IFilterGraph; Name: PWideChar): HResult; override; // milenko end // // Do estimates for standard deviations for per-frame // statistics // // *piResult = (llSumSq - iTot * iTot / m_cFramesDrawn - 1) / // (m_cFramesDrawn - 2) // or 0 if m_cFramesDrawn <= 3 // function GetStdDev(Samples: Integer; out Res: Integer; SumSq, Tot: Int64): HResult; // IQualProp property page support // ??? out <- var function get_FramesDroppedInRenderer(out pcFrames : Integer) : HResult; stdcall; function get_FramesDroppedInRenderer(var FramesDropped: Integer): HResult; stdcall; function get_FramesDrawn(out FramesDrawn: Integer): HResult; stdcall; function get_AvgFrameRate(out AvgFrameRate: Integer): HResult; stdcall; function get_Jitter(out Jitter: Integer): HResult; stdcall; function get_AvgSyncOffset(out Avg: Integer): HResult; stdcall; function get_DevSyncOffset(out Dev: Integer): HResult; stdcall; end; // milenko start (added TBCPullPin) // // CPullPin // // object supporting pulling data from an IAsyncReader interface. // Given a start/stop position, calls a pure Receive method with each // IMediaSample received. // // This is essentially for use in a MemInputPin when it finds itself // connected to an IAsyncReader pin instead of a pushing pin. // TThreadMsg = ( TM_Pause, // stop pulling and wait for next message TM_Start, // start pulling TM_Exit // stop and exit ); TBCPullPin = class(TBCAMThread) private FReader: IAsyncReader; FStart: TReferenceTime; FStop: TReferenceTime; FDuration: TReferenceTime; FSync: Boolean; FState: TThreadMsg; // running pull method (check m_bSync) procedure Process; // clean up any cancelled i/o after a flush procedure CleanupCancelled; // suspend thread from pulling, eg during seek function PauseThread: HRESULT; // start thread pulling - create thread if necy function StartThread: HRESULT; // stop and close thread function StopThread: HRESULT; // called from ProcessAsync to queue and collect requests function QueueSample(var tCurrent: TReferenceTime; tAlignStop: TReferenceTime; bDiscontinuity: Boolean): HRESULT; function CollectAndDeliver(tStart,tStop: TReferenceTime): HRESULT; function DeliverSample(pSample: IMediaSample; tStart,tStop: TReferenceTime): HRESULT; protected FAlloc: IMemAllocator; // override pure thread proc from CAMThread function ThreadProc: DWord; override; public constructor Create; destructor Destroy; override; // returns S_OK if successfully connected to an IAsyncReader interface // from this object // Optional allocator should be proposed as a preferred allocator if // necessary // bSync is TRUE if we are to use sync reads instead of the // async methods. function Connect(pUnk: IUnknown; pAlloc: IMemAllocator; bSync: Boolean): HRESULT; // disconnect any connection made in Connect function Disconnect: HRESULT; // 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 DecideAllocator(pAlloc: IMemAllocator; pProps: PAllocatorProperties): HRESULT; // set start and stop position. if active, will start immediately at // the new position. Default is 0 to duration function Seek(tStart, tStop: TReferenceTime): HRESULT; // return the total duration function Duration(out ptDuration: TReferenceTime): HRESULT; // start pulling data function Active: HRESULT; // stop pulling data function Inactive: HRESULT; // helper functions function AlignDown(ll: Int64; lAlign: LongInt): Int64; function AlignUp(ll: Int64; lAlign: LongInt): Int64; // GetReader returns the (addrefed) IAsyncReader interface // for SyncRead etc function GetReader: IAsyncReader; // -- pure -- // override this to handle data arrival // return value other than S_OK will stop data function Receive(Sample: IMediaSample): HRESULT; virtual; abstract; // override this to handle end-of-stream function EndOfStream: HRESULT; virtual; abstract; // called on runtime errors that will have caused pulling // to stop // these errors are all returned from the upstream filter, who // will have already reported any errors to the filtergraph. procedure OnError(hr: HRESULT); virtual; abstract; // flush this pin and all downstream function BeginFlush: HRESULT; virtual; abstract; function EndFlush: HRESULT; virtual; abstract; end; // milenko end // milenko start (needed to access functions outside. usefull for Filter Development) function CreateMemoryAllocator(out Allocator: IMemAllocator): HRESULT; function AMGetWideString(Source: WideString; out Dest: PWideChar): HRESULT; function CreatePosPassThru(Agg: IUnknown; Renderer: boolean; Pin: IPin; out PassThru: IUnknown): HRESULT; stdcall; // milenko end // milenko start reftime implementation //------------------------------------------------------------------------------ // File: RefTime.h // // Desc: DirectShow base classes - defines CRefTime, a class that manages // reference times. // // Copyright (c) 1992-2002 Microsoft Corporation. All rights reserved. //------------------------------------------------------------------------------ // // CRefTime // // Manage reference times. // Shares same data layout as REFERENCE_TIME, but adds some (nonvirtual) // functions providing simple comparison, conversion and arithmetic. // // A reference time (at the moment) is a unit of seconds represented in // 100ns units as is used in the Win32 FILETIME structure. BUT the time // a REFERENCE_TIME represents is NOT the time elapsed since 1/1/1601 it // will either be stream time or reference time depending upon context // // This class provides simple arithmetic operations on reference times // // keep non-virtual otherwise the data layout will not be the same as // REFERENCE_TIME // ----- // note that you are safe to cast a CRefTime* to a REFERENCE_TIME*, but // you will need to do so explicitly // ----- type TBCRefTime = object public // *MUST* be the only data member so that this class is exactly // equivalent to a REFERENCE_TIME. // Also, must be *no virtual functions* FTime: TReferenceTime; // DCODER: using Create_ as contructor replacement ... procedure Create_; overload; procedure Create_(msecs: Longint); overload; // delphi 5 doesn't like "const rt: TBCRefTime" ??? function SetTime(var rt: TBCRefTime): TBCRefTime; overload; function SetTime(var ll: LONGLONG): TBCRefTime; overload; function AddTime(var rt: TBCRefTime): TBCRefTime; overload; function SubstractTime(var rt: TBCRefTime): TBCRefTime; overload; function Millisecs: Longint; function GetUnits: LONGLONG; end; // milenko end; // milenko start schedule implementation //------------------------------------------------------------------------------ // File: Schedule.cpp // // Desc: DirectShow base classes. // // Copyright (c) 1996-2002 Microsoft Corporation. All rights reserved. //------------------------------------------------------------------------------ type TBCAdvisePacket = class public FNext : TBCAdvisePacket; FAdviseCookie: DWORD; FEventTime : TReferenceTime; // Time at which event should be set FPeriod : TReferenceTime; // Periodic time FNotify : THandle; // Handle to event or semephore FPeriodic : Boolean; // TRUE => Periodic event constructor Create; overload; constructor Create(Next: TBCAdvisePacket; Time: LONGLONG); overload; procedure InsertAfter(Packet: TBCAdvisePacket); // That is, is it the node that represents the end of the list function IsZ: Boolean; function RemoveNext: TBCAdvisePacket; procedure DeleteNext; function Next: TBCAdvisePacket; function Cookie: DWORD; end; TBCAMSchedule = class(TBCBaseObject) private // Structure is: // head -> elmt1 -> elmt2 -> z -> null // So an empty list is: head -> z -> null // Having head & z as links makes insertaion, // deletion and shunting much easier. FHead, FZ : TBCAdvisePacket; // z is both a tail and a sentry FNextCookie : DWORD; // Strictly increasing FAdviseCount: DWORD; // Number of elements on list FSerialize : TBCCritSec; // Event that we should set if the packed added above will be the next to fire. FEvent : THandle; // Rather than delete advise packets, we cache them for future use FAdviseCache: TBCAdvisePacket; FCacheCount : DWORD; // AddAdvisePacket: adds the packet, returns the cookie (0 if failed) function AddAdvisePacket(Packet: TBCAdvisePacket): DWORD; overload; // A Shunt is where we have changed the first element in the // list and want it re-evaluating (i.e. repositioned) in // the list. procedure ShuntHead; procedure Delete(Packet: TBCAdvisePacket);// This "Delete" will cache the Link public // ev is the event we should fire if the advise time needs re-evaluating constructor Create(Event: THandle); destructor Destroy; override; function GetAdviseCount: DWORD; function GetNextAdviseTime: TReferenceTime; // We need a method for derived classes to add advise packets, we return the cookie function AddAdvisePacket(const Time1, Time2: TReferenceTime; h: THandle; Periodic: Boolean): DWORD; overload; // And a way to cancel function Unadvise(AdviseCookie: DWORD): HRESULT; // Tell us the time please, and we'll dispatch the expired events. // We return the time of the next event. // NB: The time returned will be "useless" if you start adding extra Advises. // But that's the problem of // whoever is using this helper class (typically a clock). function Advise(const Time_: TReferenceTime): TReferenceTime; // Get the event handle which will be set if advise time requires re-evaluation. function GetEvent: THandle; procedure DumpLinkedList; end; // milenko end // milenko start refclock implementation //------------------------------------------------------------------------------ // File: RefClock.h // // Desc: DirectShow base classes - defines the IReferenceClock interface. // // Copyright (c) 1992-2002 Microsoft Corporation. All rights reserved. //------------------------------------------------------------------------------ (* This class hierarchy will support an IReferenceClock interface so that an audio card (or other externally driven clock) can update the system wide clock that everyone uses. The interface will be pretty thin with probably just one update method This interface has not yet been defined. *) (* This abstract base class implements the IReferenceClock * interface. Classes that actually provide clock signals (from * whatever source) have to be derived from this class. * * The abstract class provides implementations for: * CUnknown support * locking support (CCritSec) * client advise code (creates a thread) * * Question: what can we do about quality? Change the timer * resolution to lower the system load? Up the priority of the * timer thread to force more responsive signals? * * During class construction we create a worker thread that is destroyed during * destuction. This thread executes a series of WaitForSingleObject calls, * waking up when a command is given to the thread or the next wake up point * is reached. The wakeup points are determined by clients making Advise * calls. * * Each advise call defines a point in time when they wish to be notified. A * periodic advise is a series of these such events. We maintain a list of * advise links and calculate when the nearest event notification is due for. * We then call WaitForSingleObject with a timeout equal to this time. The * handle we wait on is used by the class to signal that something has changed * and that we must reschedule the next event. This typically happens when * someone comes in and asks for an advise link while we are waiting for an * event to timeout. * * While we are modifying the list of advise requests we * are protected from interference through a critical section. Clients are NOT * advised through callbacks. One shot clients have an event set, while * periodic clients have a semaphore released for each event notification. A * semaphore allows a client to be kept up to date with the number of events * actually triggered and be assured that they can't miss multiple events being * set. * * Keeping track of advises is taken care of by the CAMSchedule class. *) type TBCBaseReferenceClock = class(TBCUnknown, IReferenceClock) private FLock : TBCCritSec; FAbort : Boolean; // Flag used for thread shutdown FThread : THandle; // Thread handle FPrivateTime : TReferenceTime; // Current best estimate of time FPrevSystemTime : DWORD; // Last vaule we got from timeGetTime FLastGotTime : TReferenceTime; // Last time returned by GetTime FNextAdvise : TReferenceTime; // Time of next advise FTimerResolution: DWORD; {$IFDEF PERF} FGetSystemTime : integer; {$ENDIF} function AdviseThread: HRESULT; // Method in which the advise thread runs protected FSchedule : TBCAMSchedule; public constructor Create(Name: String; Unk: IUnknown; out hr: HRESULT; Sched: TBCAMSchedule = nil); destructor Destroy; override; // Don't let me be created on the stack! function NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall; // IReferenceClock methods // Derived classes must implement GetPrivateTime(). All our GetTime // does is call GetPrivateTime and then check so that time does not // go backwards. A return code of S_FALSE implies that the internal // clock has gone backwards and GetTime time has halted until internal // time has caught up. (Don't know if this will be much use to folk, // but it seems odd not to use the return code for something useful.) function GetTime(out Time: int64): HResult; stdcall; // When this is called, it sets m_rtLastGotTime to the time it returns. // Provide standard mechanisms for scheduling events // Ask for an async notification that a time has elapsed */ function AdviseTime( BaseTime, // base reference time StreamTime: int64; // stream offset time Event: THandle; // advise via this event out AdviseCookie: DWORD // where your cookie goes ): HResult; stdcall; // Ask for an asynchronous periodic notification that a time has elapsed function AdvisePeriodic( const StartTime, // starting at this time PeriodTime: int64; // time between notifications Semaphore: THandle; // advise via a semaphore out AdviseCookie: DWORD // where your cookie goes ): HResult; stdcall; (* Cancel a request for notification(s) - if the notification was * a one shot timer then this function doesn't need to be called * as the advise is automatically cancelled, however it does no * harm to explicitly cancel a one-shot advise. It is REQUIRED that * clients call Unadvise to clear a Periodic advise setting. *) function Unadvise(AdviseCookie: DWORD): HResult; stdcall; // Methods for the benefit of derived classes or outer objects // GetPrivateTime() is the REAL clock. GetTime is just a cover for // it. Derived classes will probably override this method but not // GetTime() itself. // The important point about GetPrivateTime() is it's allowed to go // backwards. Our GetTime() will keep returning the LastGotTime // until GetPrivateTime() catches up. function GetPrivateTime: TReferenceTime; virtual; // Provide a method for correcting drift function SetTimeDelta(const TimeDelta: TReferenceTime): HRESULT; stdcall; function GetSchedule: TBCAMSchedule; // Thread stuff // Wakes thread up. Need to do this if time to next advise needs reevaluating. procedure TriggerThread; end; // milenko end // milenko start sysclock implementation //------------------------------------------------------------------------------ // File: SysClock.h // // Desc: DirectShow base classes - defines a system clock implementation of // IReferenceClock. // // Copyright (c) 1992-2002 Microsoft Corporation. All rights reserved. //------------------------------------------------------------------------------ const IID_IPersist : TGUID = '{0000010C-0000-0000-C000-000000000046}'; type TBCSystemClock = class(TBCBaseReferenceClock, IAMClockAdjust, IPersist) public constructor Create(Name: WideString; Unk : IUnknown; out hr : HRESULT); function NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall; // Yield up our class id so that we can be persisted // Implement required Ipersist method function GetClassID(out classID: TCLSID): HResult; stdcall; // IAMClockAdjust methods function SetClockDelta(rtDelta: TReferenceTime): HResult; stdcall; end; {$IFDEF DEBUG} procedure DbgLog(obj: TBCBaseObJect; const msg: string); overload; procedure DbgLog(const msg: string); overload; procedure DbgAssert(const Message, Filename: string; LineNumber: Integer; ErrorAddr: Pointer); {$ENDIF} function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall; function DllCanUnloadNow: HResult; stdcall; function DllRegisterServer: HResult; stdcall; function DllUnregisterServer: HResult; stdcall; (* milenko start (needed for TBCBaseReferenceClock and TBCVideoTransformFilter ) *) {$IFDEF PERF} procedure MSR_START(Id_: Integer); procedure MSR_STOP(Id_: Integer); procedure MSR_INTEGER(Id_, i: Integer); function MSR_REGISTER(s: String): Integer; {$ENDIF} (* milenko end *) implementation var ObjectCount : Integer; FactoryCount : Integer; TemplatesVar : TBCFilterTemplate; // milenko start (added global variables instead of local constants) IsCheckedVersion: Bool = False; IsTimeKillSynchronousFlagAvailable: Bool = False; MsgId: Cardinal = 0; // milenko end {$IFDEF DEBUG} {$IFNDEF MESSAGE} DebugFile : TextFile; {$ENDIF} procedure DbgLog(obj: TBCBaseObJect; const msg: string); begin {$IFNDEF MESSAGE} if (obj = nil) then Writeln(DebugFile, TimeToStr(time) +' > '+ msg) else Writeln(DebugFile, TimeToStr(time) +' > '+ format('Object: %s, msg: %s.',[obj.FName, msg])); Flush(DebugFile); {$ELSE} if (obj = nil) then OutputDebugString(PChar(TimeToStr(time) +' > '+ msg)) else OutputDebugString(PChar(TimeToStr(time) +' > '+ format('Object: %s, msg: %s.',[obj.FName, msg]))); {$ENDIF} end; procedure DbgLog(const msg: string); overload; begin {$IFNDEF MESSAGE} Writeln(DebugFile, TimeToStr(time) +' > '+ msg); Flush(DebugFile); {$ELSE} OutputDebugString(PChar(TimeToStr(time) +' > '+ msg)); {$ENDIF} end; procedure DbgAssert(const Message, Filename: string; LineNumber: Integer; ErrorAddr: Pointer); begin DbgLog(format('[ASSERT] %s (%s) line: %d, adr: $%x', [Message, Filename, LineNumber, Integer(ErrorAddr)])); end; {$ENDIF} // ----------------------------------------------------------------------------- // TBCMediaType // ----------------------------------------------------------------------------- function TBCMediaType.Equal(mt: TBCMediaType): boolean; begin result := ((IsEqualGUID(Mediatype.majortype,mt.MediaType.majortype) = True) and (IsEqualGUID(Mediatype.subtype,mt.MediaType.subtype) = True) and (IsEqualGUID(Mediatype.formattype,mt.MediaType.formattype) = True) and (Mediatype.cbFormat = mt.MediaType.cbFormat) and ( (Mediatype.cbFormat = 0) or (CompareMem(Mediatype.pbFormat, mt.MediaType.pbFormat, Mediatype.cbFormat)))); end; function TBCMediaType.Equal(mt: PAMMediaType): boolean; begin result := ((IsEqualGUID(Mediatype.majortype,mt.majortype) = True) and (IsEqualGUID(Mediatype.subtype,mt.subtype) = True) and (IsEqualGUID(Mediatype.formattype,mt.formattype) = True) and (Mediatype.cbFormat = mt.cbFormat) and ( (Mediatype.cbFormat = 0) or (CompareMem(Mediatype.pbFormat, mt.pbFormat, Mediatype.cbFormat)))); end; function TBCMediaType.MatchesPartial(Partial: PAMMediaType): boolean; begin result := false; if (not IsEqualGUID(partial.majortype, GUID_NULL) and not IsEqualGUID(MediaType.majortype, partial.majortype)) then exit; if (not IsEqualGUID(partial.subtype, GUID_NULL) and not IsEqualGUID(MediaType.subtype, partial.subtype)) then exit; if not IsEqualGUID(partial.formattype, GUID_NULL) then begin if not IsEqualGUID(MediaType.formattype, partial.formattype) then exit; if (MediaType.cbFormat <> partial.cbFormat) then exit; if ((MediaType.cbFormat <> 0) and (CompareMem(MediaType.pbFormat, partial.pbFormat, MediaType.cbFormat) <> false)) then exit; end; result := True; end; function TBCMediaType.IsPartiallySpecified: boolean; begin if (IsEqualGUID(Mediatype.majortype, GUID_NULL) or IsEqualGUID(Mediatype.formattype, GUID_NULL)) then result := True else result := false; end; function TBCMediaType.IsValid: boolean; begin result := not IsEqualGUID(MediaType.majortype,GUID_NULL); end; procedure TBCMediaType.InitMediaType; begin ZeroMemory(MediaType, sizeof(TAMMediaType)); MediaType.lSampleSize := 1; MediaType.bFixedSizeSamples := True; end; function TBCMediaType.FormatLength: Cardinal; begin result := MediaType.cbFormat end; // ----------------------------------------------------------------------------- // milenko start function AMGetWideString(Source: WideString; out Dest: PWideChar): HRESULT; var NameLen: Cardinal; begin if not assigned(@Dest) then begin Result := E_POINTER; Exit; end; nameLen := sizeof(WCHAR) * (length(source)+1); Dest := CoTaskMemAlloc(nameLen); if (Dest = nil) then begin Result := E_OUTOFMEMORY; Exit; end; CopyMemory(Dest, PWideChar(Source), nameLen); Result := NOERROR; end; { function AMGetWideString(Source: WideString; out Dest: PWideChar): HRESULT; type TWideCharArray = array of WideChar; var NameLen: Cardinal; begin if Source = '' then begin dest := nil; result := S_OK; exit; end; assert(@dest <> nil); nameLen := (length(Source)+1)*2; Dest := CoTaskMemAlloc(nameLen); if(Dest = nil) then begin result := E_OUTOFMEMORY; exit; end; CopyMemory(dest, pointer(Source), nameLen-1); TWideCharArray(dest)[(nameLen div 2)-1] := #0; result := NOERROR; end; } // milenko end // ----------------------------------------------------------------------------- function CreateMemoryAllocator(out Allocator: IMemAllocator): HRESULT; begin result := CoCreateInstance(CLSID_MemoryAllocator, nil, CLSCTX_INPROC_SERVER, IID_IMemAllocator, Allocator); end; // Put this one here rather than in ctlutil.cpp to avoid linking // anything brought in by ctlutil.cpp function CreatePosPassThru(Agg: IUnknown; Renderer: boolean; Pin: IPin; out PassThru: IUnknown): HRESULT; stdcall; var UnkSeek: IUnknown; APassThru: ISeekingPassThru; begin PassThru := nil; result := CoCreateInstance(CLSID_SeekingPassThru, Agg, CLSCTX_INPROC_SERVER, IUnknown, UnkSeek); if FAILED(result) then exit; result := UnkSeek.QueryInterface(IID_ISeekingPassThru, APassThru); if FAILED(result) then begin UnkSeek := nil; exit; end; result := APassThru.Init(Renderer, Pin); APassThru := nil; if FAILED(result) then begin UnkSeek := nil; exit; end; PassThru := UnkSeek; result := S_OK; end; // ----------------------------------------------------------------------------- function Templates: TBCFilterTemplate; begin if TemplatesVar = nil then TemplatesVar := TBCFilterTemplate.Create; result := TemplatesVar; end; function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall; var Factory: TBCClassFactory; begin Factory := Templates.GetFactoryFromClassID(CLSID); if Factory <> nil then if Factory.GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE else begin Pointer(Obj) := nil; Result := CLASS_E_CLASSNOTAVAILABLE; end; end; function DllCanUnloadNow: HResult; stdcall; begin if (ObjectCount = 0) and (FactoryCount = 0) then result := S_OK else result := S_FALSE;; end; function DllRegisterServer: HResult; stdcall; begin if Templates.RegisterServer(True) then result := S_OK else result := E_FAIL; end; function DllUnregisterServer: HResult; stdcall; begin if Templates.RegisterServer(false) then result := S_OK else result := E_FAIL; end; { TBCClassFactory } constructor TBCClassFactory.CreateFilter(ComClass: TBCUnknownClass; Name: string; const ClassID: TGUID; const Category: TGUID; Merit: LongWord; PinCount: Cardinal; Pins: PRegFilterPins); begin Templates.AddObjectFactory(Self); FComClass := ComClass; FName := Name; FClassID := ClassID; FCategory := Category; FMerit := Merit; FPinCount := PinCount; FPins := Pins; end; constructor TBCClassFactory.CreatePropertyPage(ComClass: TFormPropertyPageClass; const ClassID: TGUID); begin Templates.AddObjectFactory(Self); FPropClass := ComClass; FClassID := ClassID; FCategory := ClassID; end; function TBCClassFactory.CreateInstance(const unkOuter: IUnKnown; const iid: TIID; out obj): HResult; var ComObject: TBCUnknown; PropObject: TFormPropertyPage; begin if @obj = nil then begin Result := E_POINTER; Exit; end; Pointer(obj) := nil; if FPropClass <> nil then begin PropObject := TFormPropertyPageClass(FPropClass).Create(nil); PropObject.FPropertyPage := TBCBasePropertyPage.Create('',nil, PropObject); Result := PropObject.QueryInterface(IID, obj); end else begin ComObject := TBCUnknownClass(FComClass).CreateFromFactory(self, unkOuter); Result := ComObject.QueryInterface(IID, obj); if ComObject.FRefCount = 0 then ComObject.Free; end; end; procedure TBCClassFactory.UpdateRegistry(Register: Boolean); var FileName: array[0..MAX_PATH-1] of Char; ClassID, ServerKeyName: String; begin ClassID := GUIDToString(FClassID); ServerKeyName := 'CLSID\' + ClassID + '\' + 'InprocServer32'; if Register then begin CreateRegKey('CLSID\' + ClassID, '', FName); GetModuleFileName(hinstance, FileName, MAX_PATH); CreateRegKey(ServerKeyName, '', FileName); CreateRegKey(ServerKeyName, 'ThreadingModel', 'Both'); end else begin DeleteRegKey(ServerKeyName); DeleteRegKey('CLSID\' + ClassID); end; end; function TBCClassFactory.RegisterFilter(FilterMapper: IFilterMapper; Register: Boolean): boolean; type TDynArrayPins = array of TRegFilterPins; TDynArrayPinType = array of TRegPinTypes; var i, j: integer; FilterGUID: TGUID; begin result := Succeeded(FilterMapper.UnregisterFilter(FClassID)); if Register then begin result := Succeeded(FilterMapper.RegisterFilter(FClassID, StringToOleStr(FName), FMerit)); if result then begin for i := 0 to FPinCount - 1 do begin if TDynArrayPins(FPins)[i].oFilter = nil then FilterGUID := GUID_NULL else FilterGUID := TDynArrayPins(FPins)[i].oFilter^; result := Succeeded(FilterMapper.RegisterPin(FClassID, TDynArrayPins(FPins)[i].strName, TDynArrayPins(FPins)[i].bRendered, TDynArrayPins(FPins)[i].bOutput, TDynArrayPins(FPins)[i].bZero, TDynArrayPins(FPins)[i].bMany, FilterGUID, TDynArrayPins(FPins)[i].strConnectsToPin)); if result then begin for j := 0 to TDynArrayPins(FPins)[i].nMediaTypes - 1 do begin result := Succeeded(FilterMapper.RegisterPinType(FClassID, TDynArrayPins(FPins)[i].strName, TDynArrayPinType(TDynArrayPins(FPins)[i].lpMediaType)[j].clsMajorType^, TDynArrayPinType(TDynArrayPins(FPins)[i].lpMediaType)[j].clsMinorType^)); if not result then break; end; if not result then break; end; if not result then break; end; end; end; end; function TBCClassFactory.RegisterFilter(FilterMapper: IFilterMapper2; Register: Boolean): boolean; var RegFilter: TRegFilter2; begin result := Succeeded(FilterMapper.UnregisterFilter(FCategory, nil, FClassID)); // milenko start (bugfix for Windows 98) // Windows 98 fails when unregistering a Property Page, so the whole // DLLUnregisterServer function fails without unregistering the Filter. if not result and not Register and (FName = '') then Result := True; // milenko end if Register then begin RegFilter.dwVersion := 1; RegFilter.dwMerit := FMerit; RegFilter.cPins := FPinCount; RegFilter.rgPins := FPins; result := Succeeded(FilterMapper.RegisterFilter(FClassID, PWideChar(WideString(FName)), nil, @FCategory, nil, RegFilter)); end; end; function TBCClassFactory._AddRef: Integer; begin result := InterlockedIncrement(FactoryCount); end; function TBCClassFactory._Release: Integer; begin result := InterlockedDecrement(FactoryCount); end; function TBCClassFactory.LockServer(fLock: BOOL): HResult; begin Result := CoLockObjectExternal(Self, fLock, True); if flock then InterlockedIncrement(ObjectCount) else InterlockedDecrement(ObjectCount); end; function TBCClassFactory.QueryInterface(const IID: TGUID; out Obj): HResult; begin if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; { TBCFilterTemplate } procedure TBCFilterTemplate.AddObjectFactory(Factory: TBCClassFactory); begin Factory.FNext := FFactoryList; FFactoryList := Factory; end; constructor TBCFilterTemplate.Create; begin FFactoryList := nil; end; destructor TBCFilterTemplate.Destroy; var AFactory: TBCClassFactory; begin while FFactoryList <> nil do begin AFactory := FFactoryList; FFactoryList := AFactory.FNext; AFactory.Free; end; inherited Destroy; end; function TBCFilterTemplate.GetFactoryFromClassID(const CLSID: TGUID): TBCClassFactory; var AFactory: TBCClassFactory; begin result := nil; AFactory := FFactoryList; while AFactory <> nil do begin if IsEqualGUID(CLSID, AFactory.FClassID) then begin result := AFactory; break; end; AFactory := AFactory.FNext; end; end; function TBCFilterTemplate.RegisterServer(Register: Boolean): boolean; var {$IFDEF DEBUG} Filename: array[0..MAX_PATH-1] of Char; {$ENDIF} FilterMapper : IFilterMapper; FilterMapper2: IFilterMapper2; Factory: TBCClassFactory; begin result := false; {$IFDEF DEBUG} GetModuleFileName(hinstance, Filename, sizeof(Filename)); DbgLog('TBCFilterTemplate.RegisterServer in ' + Filename); {$ENDIF} if Failed(CoCreateInstance(CLSID_FilterMapper2, nil, CLSCTX_INPROC_SERVER, IFilterMapper2, FilterMapper2)) then if Failed(CoCreateInstance(CLSID_FilterMapper, nil, CLSCTX_INPROC_SERVER, IFilterMapper, FilterMapper)) then exit; Factory := FFactoryList; while Factory <> nil do begin Factory.UpdateRegistry(false); if FilterMapper2 <> nil then result := Factory.RegisterFilter(FilterMapper2, Register) else result := Factory.RegisterFilter(FilterMapper, Register); if not result then break else Factory.UpdateRegistry(register); Factory := Factory.FNext; end; FilterMapper := nil; FilterMapper2 := nil; end; { TBCBaseObject } constructor TBCBaseObject.Create(Name: string); begin {$IFDEF DEBUG} DbgLog('[' + ClassName + ': ' + Name + '] CREATE'); {$ENDIF} FName := name; end; destructor TBCBaseObject.Destroy; begin {$IFDEF DEBUG} DbgLog('[' + ClassName + ': ' + FName + '] FREE'); {$ENDIF} inherited; end; procedure TBCBaseObject.FreeInstance; begin inherited; InterlockedDecrement(ObjectCount); end; class function TBCBaseObject.NewInstance: TObject; begin result := inherited NewInstance; InterlockedIncrement(ObjectCount); end; class function TBCBaseObject.ObjectsActive: integer; begin result := ObjectCount; end; { TBCUnknown } function TBCUnknown.QueryInterface(const IID: TGUID; out Obj): HResult; begin if FOwner <> nil then Result := IUnknown(FOwner).QueryInterface(IID, Obj) else Result := NonDelegatingQueryInterface(IID, Obj); end; function TBCUnknown._AddRef: Integer; begin if FOwner <> nil then Result := IUnknown(FOwner)._AddRef else Result := NonDelegatingAddRef; end; function TBCUnknown._Release: Integer; begin if FOwner <> nil then Result := IUnknown(FOwner)._Release else Result := NonDelegatingRelease; end; function TBCUnknown.NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult; begin if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; function TBCUnknown.NonDelegatingAddRef: Integer; begin Result := InterlockedIncrement(FRefCount); end; function TBCUnknown.NonDelegatingRelease: Integer; begin Result := InterlockedDecrement(FRefCount); if Result = 0 then Destroy; end; function TBCUnknown.GetOwner: IUnKnown; begin result := IUnKnown(FOwner); end; constructor TBCUnknown.Create(name: string; Unk: IUnKnown); begin inherited Create(name); FOwner := Pointer(Unk); end; constructor TBCUnknown.CreateFromFactory(Factory: TBCClassFactory; const Controller: IUnKnown); begin Create(Factory.FName, Controller); end; { TBCBaseFilter } constructor TBCBaseFilter.Create(Name: string; Unk: IUnKnown; Lock: TBCCritSec; const clsid: TGUID); begin inherited Create(Name, Unk); FLock := Lock; Fclsid := clsid; FState := State_Stopped; FClock := nil; FGraph := nil; FSink := nil; FFilterName := ''; FPinVersion := 1; Assert(FLock <> nil, 'Lock = nil !'); end; constructor TBCBaseFilter.Create(Name: string; Unk: IUnKnown; Lock: TBCCritSec; const clsid: TGUID; out hr: HRESULT); begin Create(Name, Unk, Lock, clsid); assert(@hr <> nil, 'Unreferenced parameter: hr'); end; constructor TBCBaseFilter.CreateFromFactory(Factory: TBCClassFactory; const Controller: IUnknown); begin Create(Factory.FName,Controller, TBCCritSec.Create, Factory.FClassID); end; destructor TBCBaseFilter.destroy; begin FFilterName := ''; FClock := nil; FLock.Free; inherited; end; function TBCBaseFilter.EnumPins(out ppEnum: IEnumPins): HRESULT; begin // Create a new ref counted enumerator ppEnum := TBCEnumPins.Create(self, nil); if ppEnum = nil then result := E_OUTOFMEMORY else result := NOERROR; end; function TBCBaseFilter.FindPin(Id: PWideChar; out Pin: IPin): HRESULT; var i: integer; APin: TBCBasePin; begin // We're going to search the pin list so maintain integrity FLock.Lock; try for i := 0 to GetPinCount - 1 do begin APin := GetPin(i); ASSERT(APin <> nil); if (APin.FPinName = WideString(Id)) then begin // Found one that matches // AddRef() and return it Pin := APin; result := S_OK; exit; end; end; Pin := nil; result := VFW_E_NOT_FOUND; finally FLock.UnLock; end; end; function TBCBaseFilter.GetClassID(out classID: TCLSID): HResult; begin classID := FCLSID; result := NOERROR; end; function TBCBaseFilter.GetFilterGraph: IFilterGraph; begin result := FGRaph; end; function TBCBaseFilter.GetPinVersion: LongInt; begin result := FPinVersion; end; function TBCBaseFilter.GetState(dwMilliSecsTimeout: DWORD; out State: TFilterState): HRESULT; begin State := FState; result := S_OK; end; function TBCBaseFilter.GetSyncSource(out pClock: IReferenceClock): HRESULT; begin FLock.Lock; try pClock := FClock; finally result := NOERROR; FLock.UnLock; end; end; procedure TBCBaseFilter.IncrementPinVersion; begin InterlockedIncrement(FPinVersion) end; function TBCBaseFilter.IsActive: boolean; begin FLock.Lock; try result := ((FState = State_Paused) or (FState = State_Running)); finally FLock.UnLock; end; end; function TBCBaseFilter.IsStopped: boolean; begin result := (FState = State_Stopped); end; function TBCBaseFilter.JoinFilterGraph(pGraph: IFilterGraph; pName: PWideChar): HRESULT; begin FLock.Lock; try //Henri: This implementation seem to be stupid but it's the exact conversion ????? // NOTE: we no longer hold references on the graph (m_pGraph, m_pSink) Pointer(FGraph) := Pointer(pGraph); if (FGraph <> nil) then begin if FAILED(FGraph.QueryInterface(IID_IMediaEventSink, FSink)) then ASSERT(FSink = nil) else FSink._Release; // we do NOT keep a reference on it. end else begin // if graph pointer is null, then we should // also release the IMediaEventSink on the same object - we don't // refcount it, so just set it to null Pointer(FSink) := nil; end; FFilterName := ''; if assigned(pName) then FFilterName := WideString(pName); result := NOERROR; finally FLock.UnLock; end; end; function TBCBaseFilter.NotifyEvent(EventCode, EventParam1, EventParam2: Integer): HRESULT; var Filter : IBaseFilter; begin // Snapshot so we don't have to lock up if assigned(FSink) then begin QueryInterface(IID_IBaseFilter,Filter); if (EC_COMPLETE = EventCode) then EventParam2 := LongInt(Filter); result := FSink.Notify(EventCode, EventParam1, EventParam2); Filter := nil; end else result := E_NOTIMPL; end; function TBCBaseFilter.Pause: HRESULT; var c: integer; pin: TBCBasePin; begin FLock.Lock; try if FState = State_Stopped then begin for c := 0 to GetPinCount - 1 do begin Pin := GetPin(c); // Disconnected pins are not activated - this saves pins // worrying about this state themselves if Pin.IsConnected then begin result := Pin.Active; if FAILED(result) then exit; end; end; end; // notify all pins of the change to active state FState := State_Paused; result := S_OK; finally FLock.UnLock; end; end; function TBCBaseFilter.QueryFilterInfo(out pInfo: TFilterInfo): HRESULT; var len: Integer; begin len := Length(pInfo.achName)-1; if (Length(FFilterName) > 0) then if (Length(FFilterName) > len) then begin CopyMemory(@pInfo.achName, PWideChar(FFilterName), len * SizeOf(WCHAR)); pInfo.achName[len] := #0; end else CopyMemory(@pInfo.achName, PWideChar(FFilterName), (Length(FFilterName)+1) * SizeOf(WCHAR)) else pInfo.achName[0] := #0; pInfo.pGraph := FGraph; result := NOERROR; end; function TBCBaseFilter.QueryVendorInfo(out pVendorInfo: PWideChar): HRESULT; begin result := E_NOTIMPL; end; function TBCBaseFilter.ReconnectPin(Pin: IPin; pmt: PAMMediaType): HRESULT; var Graph2: IFilterGraph2; begin if (FGraph <> nil) then begin result := FGraph.QueryInterface(IID_IFilterGraph2, Graph2); if Succeeded(result) then begin result := Graph2.ReconnectEx(Pin, pmt); Graph2 := nil; end else result := FGraph.Reconnect(Pin); end else result := E_NOINTERFACE; end; function TBCBaseFilter.Register: HRESULT; var {$IFDEF DEBUG} Filename: array[0..MAX_PATH-1] of Char; {$ENDIF} FilterMapper : IFilterMapper; FilterMapper2: IFilterMapper2; Factory: TBCClassFactory; AResult : boolean; begin Aresult := false; Result := S_FALSE; Factory := Templates.GetFactoryFromClassID(FCLSID); if Factory <> nil then begin {$IFDEF DEBUG} GetModuleFileName(hinstance, Filename, sizeof(Filename)); DbgLog(Self,'Register in ' + Filename); {$ENDIF} if Failed(CoCreateInstance(CLSID_FilterMapper2, nil, CLSCTX_INPROC_SERVER, IFilterMapper2, FilterMapper2)) then if Failed(CoCreateInstance(CLSID_FilterMapper, nil, CLSCTX_INPROC_SERVER, IFilterMapper, FilterMapper)) then exit; Factory.UpdateRegistry(false); if FilterMapper2 <> nil then AResult := Factory.RegisterFilter(FilterMapper2, True) else AResult := Factory.RegisterFilter(FilterMapper, True); if Aresult then Factory.UpdateRegistry(True); FilterMapper := nil; FilterMapper2 := nil; end; if AResult then result := S_OK else result := S_False; end; function TBCBaseFilter.Run(tStart: TReferenceTime): HRESULT; var c: integer; Pin: TBCBasePin; begin FLock.Lock; try // remember the stream time offset FStart := tStart; if FState = State_Stopped then begin result := Pause; if FAILED(result) then exit; end; // notify all pins of the change to active state if (FState <> State_Running) then begin for c := 0 to GetPinCount - 1 do begin Pin := GetPin(c); // Disconnected pins are not activated - this saves pins // worrying about this state themselves if Pin.IsConnected then begin result := Pin.Run(tStart); if FAILED(result) then exit; end; end; end; FState := State_Running; result := S_OK; finally FLock.UnLock; end; end; function TBCBaseFilter.SetSyncSource(pClock: IReferenceClock): HRESULT; begin FLock.Lock; try FClock := pClock; finally result := NOERROR; FLock.UnLock; end; end; function TBCBaseFilter.Stop: HRESULT; var c: integer; Pin: TBCBasePin; hr: HResult; begin FLock.Lock; try result := NOERROR; // notify all pins of the state change if (FState <> State_Stopped) then begin for c := 0 to GetPinCount - 1 do begin Pin := GetPin(c); // Disconnected pins are not activated - this saves pins worrying // about this state themselves. We ignore the return code to make // sure everyone is inactivated regardless. The base input pin // class can return an error if it has no allocator but Stop can // be used to resync the graph state after something has gone bad if Pin.IsConnected then begin hr := Pin.Inactive; if (Failed(hr) and SUCCEEDED(result)) then result := hr; end; end; end; FState := State_Stopped; finally FLock.UnLock; end; end; function TBCBaseFilter.StreamTime(out rtStream: TReferenceTime): HRESULT; begin // Caller must lock for synchronization // We can't grab the filter lock because we want to be able to call // this from worker threads without deadlocking if FClock = nil then begin result := VFW_E_NO_CLOCK; exit; end; // get the current reference time result := FClock.GetTime(PInt64(@rtStream)^); if FAILED(result) then exit; // subtract the stream offset to get stream time rtStream := rtStream - FStart; result := S_OK; end; function TBCBaseFilter.Unregister: HRESULT; var {$IFDEF DEBUG} Filename: array[0..MAX_PATH-1] of Char; {$ENDIF} FilterMapper : IFilterMapper; FilterMapper2: IFilterMapper2; Factory: TBCClassFactory; AResult : boolean; begin Aresult := false; Result := S_FALSE; Factory := Templates.GetFactoryFromClassID(FCLSID); if Factory <> nil then begin {$IFDEF DEBUG} GetModuleFileName(hinstance, Filename, sizeof(Filename)); DbgLog(Self,'Unregister in ' + Filename); {$ENDIF} if Failed(CoCreateInstance(CLSID_FilterMapper2, nil, CLSCTX_INPROC_SERVER, IFilterMapper2, FilterMapper2)) then if Failed(CoCreateInstance(CLSID_FilterMapper, nil, CLSCTX_INPROC_SERVER, IFilterMapper, FilterMapper)) then exit; Factory.UpdateRegistry(false); if FilterMapper2 <> nil then AResult := Factory.RegisterFilter(FilterMapper2, false) else AResult := Factory.RegisterFilter(FilterMapper, false); if Aresult then Factory.UpdateRegistry(false); FilterMapper := nil; FilterMapper2 := nil; end; if AResult then result := S_OK else result := S_False; end; { TBCEnumPins } constructor TBCEnumPins.Create(Filter: TBCBaseFilter; EnumPins: TBCEnumPins); var i: integer; begin FPosition := 0; FPinCount := 0; FFilter := Filter; FPinCache := TList.Create; // We must be owned by a filter derived from CBaseFilter ASSERT(FFilter <> nil); // Hold a reference count on our filter FFilter._AddRef; // Are we creating a new enumerator if (EnumPins = nil) then begin FVersion := FFilter.GetPinVersion; FPinCount := FFilter.GetPinCount; end else begin ASSERT(FPosition <= FPinCount); FPosition := EnumPins.FPosition; FPinCount := EnumPins.FPinCount; FVersion := EnumPins.FVersion; FPinCache.Clear; if EnumPins.FPinCache.Count > 0 then for i := 0 to EnumPins.FPinCache.Count - 1 do FPinCache.Add(EnumPins.FPinCache.Items[i]); end; end; destructor TBCEnumPins.Destroy; begin FPinCache.Free; FFilter._Release; inherited Destroy; end; function TBCEnumPins.Clone(out ppEnum: IEnumPins): HRESULT; begin result := NOERROR; // Check we are still in sync with the filter if AreWeOutOfSync then begin ppEnum := nil; result := VFW_E_ENUM_OUT_OF_SYNC; end else begin ppEnum := TBCEnumPins.Create(FFilter, self); if ppEnum = nil then result := E_OUTOFMEMORY; end; end; function TBCEnumPins.Next(cPins: ULONG; out ppPins: IPin; pcFetched: PULONG): HRESULT; type TPointerDynArray = array of Pointer; TIPinDynArray = array of IPin; var Fetched: cardinal; RealPins: integer; Pin: TBCBasePin; begin if pcFetched <> nil then pcFetched^ := 0 else if (cPins>1) then begin result := E_INVALIDARG; exit; end; Fetched := 0; // increment as we get each one. // Check we are still in sync with the filter // If we are out of sync, we should refresh the enumerator. // This will reset the position and update the other members, but // will not clear cache of pins we have already returned. if AreWeOutOfSync then Refresh; // Calculate the number of available pins RealPins := min(FPinCount - FPosition, cPins); if RealPins = 0 then begin result := S_FALSE; exit; end; { Return each pin interface NOTE GetPin returns CBasePin * not addrefed so we must QI for the IPin (which increments its reference count) If while we are retrieving a pin from the filter an error occurs we assume that our internal state is stale with respect to the filter (for example someone has deleted a pin) so we return VFW_E_ENUM_OUT_OF_SYNC } while RealPins > 0 do begin // Get the next pin object from the filter */ inc(FPosition); Pin := FFilter.GetPin(FPosition-1); if Pin = nil then begin // If this happend, and it's not the first time through, then we've got a problem, // since we should really go back and release the iPins, which we have previously // AddRef'ed. ASSERT(Fetched = 0); result := VFW_E_ENUM_OUT_OF_SYNC; exit; end; // We only want to return this pin, if it is not in our cache if FPinCache.IndexOf(Pin) = -1 then begin // From the object get an IPin interface TPointerDynArray(@ppPins)[Fetched] := nil; TIPinDynArray(@ppPins)[Fetched] := Pin; inc(Fetched); FPinCache.Add(Pin); dec(RealPins); end; end; if (pcFetched <> nil) then pcFetched^ := Fetched; if (cPins = Fetched) then result := NOERROR else result := S_FALSE; end; function TBCEnumPins.Skip(cPins: ULONG): HRESULT; var PinsLeft: Cardinal; begin // Check we are still in sync with the filter if AreWeOutOfSync then begin result := VFW_E_ENUM_OUT_OF_SYNC; exit; end; // Work out how many pins are left to skip over // We could position at the end if we are asked to skip too many... // ..which would match the base implementation for CEnumMediaTypes::Skip PinsLeft := FPinCount - FPosition; if (cPins > PinsLeft) then begin result := S_FALSE; exit; end; inc(FPosition, cPins); result := NOERROR; end; function TBCEnumPins.Reset: HRESULT; begin FVersion := FFilter.GetPinVersion; FPinCount := FFilter.GetPinCount; FPosition := 0; FPinCache.Clear; result := S_OK; end; function TBCEnumPins.Refresh: HRESULT; begin FVersion := FFilter.GetPinVersion; FPinCount := FFilter.GetPinCount; Fposition := 0; result := S_OK; end; function TBCEnumPins.AreWeOutOfSync: boolean; begin if FFilter.GetPinVersion = FVersion then result:= FALSE else result := True; end; { TBCBasePin } { Called by IMediaFilter implementation when the state changes from Stopped to either paused or running and in derived classes could do things like commit memory and grab hardware resource (the default is to do nothing) } function TBCBasePin.Active: HRESULT; begin result := NOERROR; end; { This is called to make the connection, including the task of finding a media type for the pin connection. pmt is the proposed media type from the Connect call: if this is fully specified, we will try that. Otherwise we enumerate and try all the input pin's types first and if that fails we then enumerate and try all our preferred media types. For each media type we check it against pmt (if non-null and partially specified) as well as checking that both pins will accept it. } function TBCBasePin.AgreeMediaType(ReceivePin: IPin; pmt: PAMMediaType): HRESULT; var EnumMT: IEnumMediaTypes; hrFailure: HResult; i: integer; begin ASSERT(ReceivePin <> nil); // if the media type is fully specified then use that if ((pmt <> nil) and (not TBCMediaType(pmt).IsPartiallySpecified)) then begin // if this media type fails, then we must fail the connection // since if pmt is nonnull we are only allowed to connect // using a type that matches it. result := AttemptConnection(ReceivePin, pmt); exit; end; // Try the other pin's enumerator hrFailure := VFW_E_NO_ACCEPTABLE_TYPES; for i := 0 to 1 do begin if (i = byte(FTryMyTypesFirst)) then result := ReceivePin.EnumMediaTypes(EnumMT) else result := EnumMediaTypes(EnumMT); if Succeeded(Result) then begin Assert(EnumMT <> nil); result := TryMediaTypes(ReceivePin,pmt,EnumMT); EnumMT := nil; if Succeeded(result) then begin result := NOERROR; exit; end else begin // try to remember specific error codes if there are any if ((result <> E_FAIL) and (result <> E_INVALIDARG) and (result <> VFW_E_TYPE_NOT_ACCEPTED)) then hrFailure := result; end; end; end; result := hrFailure; end; function TBCBasePin.AttemptConnection(ReceivePin: IPin; pmt: PAMMediaType): HRESULT; begin // The caller should hold the filter lock becasue this function // uses m_Connected. The caller should also hold the filter lock // because this function calls SetMediaType(), IsStopped() and // CompleteConnect(). ASSERT(FLock.CritCheckIn); // Check that the connection is valid -- need to do this for every // connect attempt since BreakConnect will undo it. result := CheckConnect(ReceivePin); if FAILED(result) then begin {$IFDEF DEBUG} DbgLog(self, 'CheckConnect failed'); {$ENDIF} // Since the procedure is already returning an error code, there // is nothing else this function can do to report the error. Assert(SUCCEEDED(BreakConnect)); exit; end; DisplayTypeInfo(ReceivePin, pmt); // Check we will accept this media type result := CheckMediaType(pmt); if (result = NOERROR) then begin // Make ourselves look connected otherwise ReceiveConnection // may not be able to complete the connection FConnected := ReceivePin; result := SetMediaType(pmt); if Succeeded(result) then begin // See if the other pin will accept this type */ result := ReceivePin.ReceiveConnection(self, pmt^); if Succeeded(result) then begin // Complete the connection result := CompleteConnect(ReceivePin); if Succeeded(result) then exit else begin {$IFDEF DEBUG} DbgLog(self, 'Failed to complete connection'); {$ENDIF} ReceivePin.Disconnect; end; end; end; end else begin // we cannot use this media type // return a specific media type error if there is one // or map a general failure code to something more helpful // (in particular S_FALSE gets changed to an error code) if (SUCCEEDED(result) or (result = E_FAIL) or (result = E_INVALIDARG)) then result := VFW_E_TYPE_NOT_ACCEPTED; end; // BreakConnect and release any connection here in case CheckMediaType // failed, or if we set anything up during a call back during // ReceiveConnection. // Since the procedure is already returning an error code, there // is nothing else this function can do to report the error. Assert(Succeeded(BreakConnect)); // If failed then undo our state FConnected := nil; end; { This is called when we realise we can't make a connection to the pin and must undo anything we did in CheckConnect - override to release QIs done } function TBCBasePin.BreakConnect: HRESULT; begin result := NOERROR; end; { This is called during Connect() to provide a virtual method that can do any specific check needed for connection such as QueryInterface. This base class method just checks that the pin directions don't match } function TBCBasePin.CheckConnect(Pin: IPin): HRESULT; var pd: TPinDirection; begin // Check that pin directions DONT match Pin.QueryDirection(pd); ASSERT((pd = PINDIR_OUTPUT) or (pd = PINDIR_INPUT)); ASSERT((Fdir = PINDIR_OUTPUT) or (Fdir = PINDIR_INPUT)); // we should allow for non-input and non-output connections? if (pd = Fdir) then result := VFW_E_INVALID_DIRECTION else result := NOERROR; end; { Called when we want to complete a connection to another filter. Failing this will also fail the connection and disconnect the other pin as well } function TBCBasePin.CompleteConnect(ReceivePin: IPin): HRESULT; begin result := NOERROR; end; { Asked to connect to a pin. A pin is always attached to an owning filter object so we always delegate our locking to that object. We first of all retrieve a media type enumerator for the input pin and see if we accept any of the formats that it would ideally like, failing that we retrieve our enumerator and see if it will accept any of our preferred types } function TBCBasePin.Connect(pReceivePin: IPin; const pmt: PAMMediaType): HRESULT; var HR: HResult; begin FLock.Lock; try DisplayPinInfo(pReceivePin); // See if we are already connected if FConnected <> nil then begin {$IFDEF DEBUG} DbgLog(self, 'Already connected'); {$ENDIF} result := VFW_E_ALREADY_CONNECTED; // milenko start Exit; // milenko end end; // See if the filter is active if (not IsStopped) and (not FCanReconnectWhenActive) then begin result := VFW_E_NOT_STOPPED; exit; end; // Find a mutually agreeable media type - // Pass in the template media type. If this is partially specified, // each of the enumerated media types will need to be checked against // it. If it is non-null and fully specified, we will just try to connect // with this. Hr := AgreeMediaType(pReceivePin, pmt); if Failed(hr) then begin {$IFDEF DEBUG} DbgLog(self, 'Failed to agree type'); {$ENDIF} // Since the procedure is already returning an error code, there // is nothing else this function can do to report the error. ASSERT(SUCCEEDED(BreakConnect)); result := HR; exit; end; {$IFDEF DEBUG} DbgLog(self, 'Connection succeeded'); {$ENDIF} result := NOERROR; finally FLock.UnLock; end; end; // Return an AddRef()'d pointer to the connected pin if there is one function TBCBasePin.ConnectedTo(out pPin: IPin): HRESULT; begin // It's pointless to lock here. // The caller should ensure integrity. pPin := FConnected; if (pPin <> nil) then result := S_OK else result := VFW_E_NOT_CONNECTED; end; function TBCBasePin.ConnectionMediaType(out pmt: TAMMediaType): HRESULT; begin FLock.Lock; try // Copy constructor of m_mt allocates the memory if IsConnected then begin CopyMediaType(@pmt,@Fmt); result := S_OK; end else begin zeromemory(@pmt, SizeOf(TAMMediaType)); pmt.lSampleSize := 1; pmt.bFixedSizeSamples := True; result := VFW_E_NOT_CONNECTED; end; finally FLock.UnLock; end; end; constructor TBCBasePin.Create(ObjectName: string; Filter: TBCBaseFilter; Lock: TBCCritSec; out hr: HRESULT; Name: WideString; dir: TPinDirection); begin inherited Create(ObjectName, nil); FFilter := Filter; FLock := Lock; FPinName := Name; FConnected := nil; Fdir := dir; FRunTimeError := FALSE; FQSink := nil; FTypeVersion := 1; FStart := 0; FStop := MAX_TIME; FCanReconnectWhenActive := false; FTryMyTypesFirst := false; FRate := 1.0; { WARNING - Filter is often not a properly constituted object at this state (in particular QueryInterface may not work) - this is because its owner is often its containing object and we have been called from the containing object's constructor so the filter's owner has not yet had its CUnknown constructor called.} FRef := 0; // debug ZeroMemory(@fmt, SizeOf(TAMMediaType)); ASSERT(Filter <> nil); ASSERT(Lock <> nil); end; destructor TBCBasePin.destroy; begin // We don't call disconnect because if the filter is going away // all the pins must have a reference count of zero so they must // have been disconnected anyway - (but check the assumption) ASSERT(FConnected = nil); FPinName := ''; Assert(FRef = 0); FreeMediaType(@fmt); inherited Destroy; end; // Called when we want to terminate a pin connection function TBCBasePin.Disconnect: HRESULT; begin FLock.Lock; try // See if the filter is active if not IsStopped then result := VFW_E_NOT_STOPPED else result := DisconnectInternal; finally FLock.UnLock; end; end; function TBCBasePin.DisconnectInternal: HRESULT; begin ASSERT(FLock.CritCheckIn); if (FConnected <> nil) then begin result := BreakConnect; if FAILED(result) then begin // There is usually a bug in the program if BreakConnect() fails. {$IFDEF DEBUG} DbgLog(self, 'WARNING: BreakConnect() failed in CBasePin::Disconnect().'); {$ENDIF} exit; end; FConnected := nil; result := S_OK; exit; end else // no connection - not an error result := S_FALSE; end; procedure TBCBasePin.DisplayPinInfo(ReceivePin: IPin); {$IFDEF DEBUG} const BadPin : WideString = 'Bad Pin'; var ConnectPinInfo, ReceivePinInfo: TPinInfo; begin if FAILED(QueryPinInfo(ConnectPinInfo)) then move(Pointer(BadPin)^, ConnectPinInfo.achName, length(BadPin) * 2 +2) else ConnectPinInfo.pFilter := nil; if FAILED(ReceivePin.QueryPinInfo(ReceivePinInfo)) then move(Pointer(BadPin)^, ReceivePinInfo.achName, length(BadPin) * 2 +2) else ReceivePinInfo.pFilter := nil; DbgLog(self, 'Trying to connect Pins :'); DbgLog(self, format(' <%s>', [ConnectPinInfo.achName])); DbgLog(self, format(' <%s>', [ReceivePinInfo.achName])); {$ELSE} begin {$ENDIF} end; procedure TBCBasePin.DisplayTypeInfo(Pin: IPin; pmt: PAMMediaType); begin {$IFDEF DEBUG} DbgLog(self, 'Trying media type:'); DbgLog(self, ' major type: '+ GuidToString(pmt.majortype)); DbgLog(self, ' sub type : '+ GuidToString(pmt.subtype)); DbgLog(self, GetMediaTypeDescription(pmt)); {$ENDIF} end; // Called when no more data will arrive function TBCBasePin.EndOfStream: HRESULT; begin result := S_OK; end; { This can be called to return an enumerator for the pin's list of preferred media types. An input pin is not obliged to have any preferred formats although it can do. For example, the window renderer has a preferred type which describes a video image that matches the current window size. All output pins should expose at least one preferred format otherwise it is possible that neither pin has any types and so no connection is possible } function TBCBasePin.EnumMediaTypes(out ppEnum: IEnumMediaTypes): HRESULT; begin // Create a new ref counted enumerator ppEnum := TBCEnumMediaTypes.Create(self, nil); if (ppEnum = nil) then result := E_OUTOFMEMORY else result := NOERROR; end; { This is a virtual function that returns a media type corresponding with place iPosition in the list. This base class simply returns an error as we support no media types by default but derived classes should override } function TBCBasePin.GetMediaType(Position: integer; out MediaType: PAMMediaType): HRESULT; begin result := E_UNEXPECTED;; end; { This is a virtual function that returns the current media type version. The base class initialises the media type enumerators with the value 1 By default we always returns that same value. A Derived class may change the list of media types available and after doing so it should increment the version either in a method derived from this, or more simply by just incrementing the m_TypeVersion base pin variable. The type enumerators call this when they want to see if their enumerations are out of date } function TBCBasePin.GetMediaTypeVersion: longint; begin result := FTypeVersion; end; { Also called by the IMediaFilter implementation when the state changes to Stopped at which point you should decommit allocators and free hardware resources you grabbed in the Active call (default is also to do nothing) } function TBCBasePin.Inactive: HRESULT; begin FRunTimeError := FALSE; result := NOERROR; end; // Increment the cookie representing the current media type version procedure TBCBasePin.IncrementTypeVersion; begin InterlockedIncrement(FTypeVersion); end; function TBCBasePin.IsConnected: boolean; begin result := FConnected <> nil; end; function TBCBasePin.IsStopped: boolean; begin result := FFilter.FState = State_Stopped; end; // NewSegment notifies of the start/stop/rate applying to the data // about to be received. Default implementation records data and // returns S_OK. // Override this to pass downstream. function TBCBasePin.NewSegment(tStart, tStop: TReferenceTime; dRate: double): HRESULT; begin FStart := tStart; FStop := tStop; FRate := dRate; result := S_OK; end; function TBCBasePin.NonDelegatingAddRef: Integer; begin ASSERT(InterlockedIncrement(FRef) > 0); result := FFilter._AddRef; end; function TBCBasePin.NonDelegatingRelease: Integer; begin ASSERT(InterlockedDecrement(FRef) >= 0); result := FFilter._Release end; function TBCBasePin.Notify(pSelf: IBaseFilter; q: TQuality): HRESULT; begin {$IFDEF DEBUG} DbgLog(self, 'IQualityControl::Notify not over-ridden from CBasePin. (IGNORE is OK)'); {$ENDIF} result := E_NOTIMPL; end; { Does this pin support this media type WARNING this interface function does not lock the main object as it is meant to be asynchronous by nature - if the media types you support depend on some internal state that is updated dynamically then you will need to implement locking in a derived class } function TBCBasePin.QueryAccept(const pmt: TAMMediaType): HRESULT; begin { The CheckMediaType method is valid to return error codes if the media type is horrible, an example might be E_INVALIDARG. What we do here is map all the error codes into either S_OK or S_FALSE regardless } result := CheckMediaType(@pmt); if FAILED(result) then result := S_FALSE; end; function TBCBasePin.QueryDirection(out pPinDir: TPinDirection): HRESULT; begin pPinDir := Fdir; result := NOERROR; end; function TBCBasePin.QueryId(out Id: PWideChar): HRESULT; begin result := AMGetWideString(FPinName, id); end; function TBCBasePin.QueryInternalConnections(out apPin: IPin; var nPin: ULONG): HRESULT; begin result := E_NOTIMPL; end; // Return information about the filter we are connect to function TBCBasePin.QueryPinInfo(out pInfo: TPinInfo): HRESULT; begin pInfo.pFilter := FFilter; if (FPinName <> '') then begin move(Pointer(FPinName)^, pInfo.achName, length(FPinName)*2); pInfo.achName[length(FPinName)] := #0; end else pInfo.achName[0] := #0; pInfo.dir := Fdir; result := NOERROR; end; { Called normally by an output pin on an input pin to try and establish a connection. } function TBCBasePin.ReceiveConnection(pConnector: IPin; const pmt: TAMMediaType): HRESULT; begin FLock.Lock; try // Are we already connected if (FConnected <> nil) then begin result := VFW_E_ALREADY_CONNECTED; exit; end; // See if the filter is active if (not IsStopped) and (not FCanReconnectWhenActive) then begin result := VFW_E_NOT_STOPPED; exit; end; result := CheckConnect(pConnector); if FAILED(result) then begin // Since the procedure is already returning an error code, there // is nothing else this function can do to report the error. ASSERT(SUCCEEDED(BreakConnect)); exit; end; // Ask derived class if this media type is ok //CMediaType * pcmt = (CMediaType*) pmt; result := CheckMediaType(@pmt); if (result <> NOERROR) then begin // no -we don't support this media type // Since the procedure is already returning an error code, there // is nothing else this function can do to report the error. ASSERT(SUCCEEDED(BreakConnect)); // return a specific media type error if there is one // or map a general failure code to something more helpful // (in particular S_FALSE gets changed to an error code) if (SUCCEEDED(result) or (result = E_FAIL) or (result = E_INVALIDARG)) then result := VFW_E_TYPE_NOT_ACCEPTED; exit; end; // Complete the connection FConnected := pConnector; result := SetMediaType(@pmt); if SUCCEEDED(result) then begin result := CompleteConnect(pConnector); if SUCCEEDED(result) then begin result := S_OK; exit; end; end; {$IFDEF DEBUG} DbgLog(self, 'Failed to set the media type or failed to complete the connection.'); {$ENDIF} FConnected := nil; // Since the procedure is already returning an error code, there // is nothing else this function can do to report the error. ASSERT(SUCCEEDED(BreakConnect)); finally FLock.UnLock; end; end; { Called by IMediaFilter implementation when the state changes from to either paused to running and in derived classes could do things like commit memory and grab hardware resource (the default is to do nothing) } function TBCBasePin.Run(Start: TReferenceTime): HRESULT; begin result := NOERROR; end; function TBCBasePin.GetCurrentMediaType: TBCMediaType; begin result := TBCMediaType(@FMT); end; function TBCBasePin.GetAMMediaType: PAMMediaType; begin result := @FMT; end; { This is called to set the format for a pin connection - CheckMediaType will have been called to check the connection format and if it didn't return an error code then this (virtual) function will be invoked } function TBCBasePin.SetMediaType(mt: PAMMediaType): HRESULT; begin FreeMediaType(@Fmt); CopyMediaType(@Fmt, mt); result := NOERROR; end; function TBCBasePin.SetSink(piqc: IQualityControl): HRESULT; begin FLock.Lock; try FQSink := piqc; result := NOERROR; finally FLock.UnLock; end; end; { Given an enumerator we cycle through all the media types it proposes and firstly suggest them to our derived pin class and if that succeeds try them with the pin in a ReceiveConnection call. This means that if our pin proposes a media type we still check in here that we can support it. This is deliberate so that in simple cases the enumerator can hold all of the media types even if some of them are not really currently available } function TBCBasePin.TryMediaTypes(ReceivePin: IPin; pmt: PAMMediaType; Enum: IEnumMediaTypes): HRESULT; var MediaCount: Cardinal; hrFailure : HResult; MediaType : PAMMediaType; begin // Reset the current enumerator position result := Enum.Reset; if Failed(result) then exit; MediaCount := 0; // attempt to remember a specific error code if there is one hrFailure := S_OK; while True do begin { Retrieve the next media type NOTE each time round the loop the enumerator interface will allocate another AM_MEDIA_TYPE structure If we are successful then we copy it into our output object, if not then we must delete the memory allocated before returning } result := Enum.Next(1, MediaType, @MediaCount); if (result <> S_OK) then begin if (S_OK = hrFailure) then hrFailure := VFW_E_NO_ACCEPTABLE_TYPES; result := hrFailure; exit; end; ASSERT(MediaCount = 1); ASSERT(MediaType <> nil); // check that this matches the partial type (if any) if (pmt = nil) or TBCMediaType(MediaType).MatchesPartial(pmt) then begin result := AttemptConnection(ReceivePin, MediaType); // attempt to remember a specific error code if FAILED(result) and SUCCEEDED(hrFailure) and (result <> E_FAIL) and (result <> E_INVALIDARG) and (result <> VFW_E_TYPE_NOT_ACCEPTED) then hrFailure := result; end else result := VFW_E_NO_ACCEPTABLE_TYPES; DeleteMediaType(MediaType); if result = S_OK then exit; end; end; { TBCEnumMediaTypes } { The media types a filter supports can be quite dynamic so we add to the general IEnumXXXX interface the ability to be signaled when they change via an event handle the connected filter supplies. Until the Reset method is called after the state changes all further calls to the enumerator (except Reset) will return E_UNEXPECTED error code. } function TBCEnumMediaTypes.AreWeOutOfSync: boolean; begin if FPin.GetMediaTypeVersion = FVersion then result := FALSE else result := True; end; { One of an enumerator's basic member functions allows us to create a cloned interface that initially has the same state. Since we are taking a snapshot of an object (current position and all) we must lock access at the start } function TBCEnumMediaTypes.Clone(out ppEnum: IEnumMediaTypes): HRESULT; begin result := NOERROR; // Check we are still in sync with the pin if AreWeOutOfSync then begin ppEnum := nil; result := VFW_E_ENUM_OUT_OF_SYNC; exit; end else begin ppEnum := TBCEnumMediaTypes.Create(FPin, self); if (ppEnum = nil) then result := E_OUTOFMEMORY; end; end; constructor TBCEnumMediaTypes.Create(Pin: TBCBasePin; EnumMediaTypes: TBCEnumMediaTypes); begin FPosition := 0; FPin := Pin; {$IFDEF DEBUG} DbgLog('TBCEnumMediaTypes.Create'); {$ENDIF} // We must be owned by a pin derived from CBasePin */ ASSERT(Pin <> nil); // Hold a reference count on our pin FPin._AddRef; // Are we creating a new enumerator if (EnumMediaTypes = nil) then begin FVersion := FPin.GetMediaTypeVersion; exit; end; FPosition := EnumMediaTypes.FPosition; FVersion := EnumMediaTypes.FVersion; end; { Destructor releases the reference count on our base pin. NOTE since we hold a reference count on the pin who created us we know it is safe to release it, no access can be made to it afterwards though as we might have just caused the last reference count to go and the object to be deleted } destructor TBCEnumMediaTypes.Destroy; begin {$IFDEF DEBUG} DbgLog('TBCEnumMediaTypes.Destroy'); {$ENDIF} FPin._Release; inherited; end; { Enumerate the next pin(s) after the current position. The client using this interface passes in a pointer to an array of pointers each of which will be filled in with a pointer to a fully initialised media type format Return NOERROR if it all works, S_FALSE if fewer than cMediaTypes were enumerated. VFW_E_ENUM_OUT_OF_SYNC if the enumerator has been broken by state changes in the filter The actual count always correctly reflects the number of types in the array.} function TBCEnumMediaTypes.Next(cMediaTypes: ULONG; out ppMediaTypes: PAMMediaType; pcFetched: PULONG): HRESULT; type TMTDynArray = array of PAMMediaType; var Fetched: Cardinal; cmt: PAMMediaType; begin // Check we are still in sync with the pin if AreWeOutOfSync then begin result := VFW_E_ENUM_OUT_OF_SYNC; exit; end; if (pcFetched <> nil) then pcFetched^ := 0 // default unless we succeed // now check that the parameter is valid else if (cMediaTypes > 1) then begin // pcFetched == NULL result := E_INVALIDARG; exit; end; Fetched := 0; // increment as we get each one. { Return each media type by asking the filter for them in turn - If we have an error code retured to us while we are retrieving a media type we assume that our internal state is stale with respect to the filter (for example the window size changing) so we return VFW_E_ENUM_OUT_OF_SYNC } new(cmt); while (cMediaTypes > 0) do begin TBCMediaType(cmt).InitMediaType; inc(FPosition); result := FPin.GetMediaType(FPosition-1, cmt); if (S_OK <> result) then Break; { We now have a CMediaType object that contains the next media type but when we assign it to the array position we CANNOT just assign the AM_MEDIA_TYPE structure because as soon as the object goes out of scope it will delete the memory we have just copied. The function we use is CreateMediaType which allocates a task memory block } { Transfer across the format block manually to save an allocate and free on the format block and generally go faster } TMTDynArray(@ppMediaTypes)[Fetched] := CoTaskMemAlloc(sizeof(TAMMediaType)); if TMTDynArray(@ppMediaTypes)[Fetched] = nil then Break; { Do a regular copy } //CopyMediaType(TMTDynArray(@ppMediaTypes)[Fetched], cmt); Move(cmt^,TMTDynArray(@ppMediaTypes)[Fetched]^,SizeOf(TAMMediaType)); // Make sure the destructor doesn't free these cmt.pbFormat := nil; cmt.cbFormat := 0; Pointer(cmt.pUnk) := nil; inc(Fetched); dec(cMediaTypes); end; dispose(cmt); if (pcFetched <> nil) then pcFetched^ := Fetched; if cMediaTypes = 0 then result := NOERROR else result := S_FALSE; end; { Set the current position back to the start Reset has 3 simple steps: set position to head of list sync enumerator with object being enumerated return S_OK } function TBCEnumMediaTypes.Reset: HRESULT; begin FPosition := 0; // Bring the enumerator back into step with the current state. This // may be a noop but ensures that the enumerator will be valid on the // next call. FVersion := FPin.GetMediaTypeVersion; result := NOERROR; end; // Skip over one or more entries in the enumerator function TBCEnumMediaTypes.Skip(cMediaTypes: ULONG): HRESULT; var cmt: PAMMediaType; begin cmt := nil; // If we're skipping 0 elements we're guaranteed to skip the // correct number of elements if (cMediaTypes = 0) then begin result := S_OK; exit; end; // Check we are still in sync with the pin if AreWeOutOfSync then begin result := VFW_E_ENUM_OUT_OF_SYNC; exit; end; FPosition := FPosition + cMediaTypes; // See if we're over the end if (S_OK = FPin.GetMediaType(FPosition - 1, cmt)) then result := S_OK else result := S_FALSE; end; { TBCBaseOutputPin } // Commit the allocator's memory, this is called through IMediaFilter // which is responsible for locking the object before calling us function TBCBaseOutputPin.Active: HRESULT; begin if (FAllocator = nil) then result := VFW_E_NO_ALLOCATOR else result := FAllocator.Commit; end; function TBCBaseOutputPin.BeginFlush: HRESULT; begin result := E_UNEXPECTED; end; // Overriden from CBasePin function TBCBaseOutputPin.BreakConnect: HRESULT; begin // Release any allocator we hold if (FAllocator <> nil) then begin // Always decommit the allocator because a downstream filter may or // may not decommit the connection's allocator. A memory leak could // occur if the allocator is not decommited when a connection is broken. result := FAllocator.Decommit; if FAILED(result) then exit; FAllocator := nil; end; // Release any input pin interface we hold if (FInputPin <> nil) then FInputPin := nil; result := NOERROR; end; { This method is called when the output pin is about to try and connect to an input pin. It is at this point that you should try and grab any extra interfaces that you need, in this case IMemInputPin. Because this is only called if we are not currently connected we do NOT need to call BreakConnect. This also makes it easier to derive classes from us as BreakConnect is only called when we actually have to break a connection (or a partly made connection) and not when we are checking a connection } function TBCBaseOutputPin.CheckConnect(Pin: IPin): HRESULT; begin result := inherited CheckConnect(Pin); if FAILED(result) then exit; // get an input pin and an allocator interface result := Pin.QueryInterface(IID_IMemInputPin, FInputPin); if FAILED(result) then exit; result := NOERROR; end; // This is called after a media type has been proposed // Try to complete the connection by agreeing the allocator function TBCBaseOutputPin.CompleteConnect(ReceivePin: IPin): HRESULT; begin result := DecideAllocator(FInputPin, FAllocator); end; constructor TBCBaseOutputPin.Create(ObjectName: string; Filter: TBCBaseFilter; Lock: TBCCritSec; out hr: HRESULT; const Name: WideString); begin inherited Create(ObjectName, Filter, Lock, hr, Name, PINDIR_OUTPUT); FAllocator := nil; FInputPin := nil; ASSERT(FFilter <> nil); end; { Decide on an allocator, override this if you want to use your own allocator Override DecideBufferSize to call SetProperties. If the input pin fails the GetAllocator call then this will construct a CMemAllocator and call DecideBufferSize on that, and if that fails then we are completely hosed. If the you succeed the DecideBufferSize call, we will notify the input pin of the selected allocator. NOTE this is called during Connect() which therefore looks after grabbing and locking the object's critical section } // We query the input pin for its requested properties and pass this to // DecideBufferSize to allow it to fulfill requests that it is happy // with (eg most people don't care about alignment and are thus happy to // use the downstream pin's alignment request). function TBCBaseOutputPin.DecideAllocator(Pin: IMemInputPin; out Alloc: IMemAllocator): HRESULT; var prop: TAllocatorProperties; begin Alloc := nil; // get downstream prop request // the derived class may modify this in DecideBufferSize, but // we assume that he will consistently modify it the same way, // so we only get it once ZeroMemory(@prop, sizeof(TAllocatorProperties)); // whatever he returns, we assume prop is either all zeros // or he has filled it out. Pin.GetAllocatorRequirements(prop); // if he doesn't care about alignment, then set it to 1 if (prop.cbAlign = 0) then prop.cbAlign := 1; // Try the allocator provided by the input pin result := Pin.GetAllocator(Alloc); if SUCCEEDED(result) then begin result := DecideBufferSize(Alloc, @prop); if SUCCEEDED(result) then begin result := Pin.NotifyAllocator(Alloc, FALSE); if SUCCEEDED(result) then begin result := NOERROR; exit; end; end; end; // If the GetAllocator failed we may not have an interface if (Alloc <> nil) then Alloc := nil; // Try the output pin's allocator by the same method result := InitAllocator(Alloc); if SUCCEEDED(result) then begin // note - the properties passed here are in the same // structure as above and may have been modified by // the previous call to DecideBufferSize result := DecideBufferSize(Alloc, @prop); if SUCCEEDED(result) then begin result := Pin.NotifyAllocator(Alloc, FALSE); if SUCCEEDED(result) then begin result := NOERROR; exit; end; end; end; // Likewise we may not have an interface to release if (Alloc <> nil) then Alloc := nil; end; function TBCBaseOutputPin.DecideBufferSize(Alloc: IMemAllocator; propInputRequest: PAllocatorProperties): HRESULT; begin result := S_OK; // ??? end; { Deliver a filled-in sample to the connected input pin. NOTE the object must have locked itself before calling us otherwise we may get halfway through executing this method only to find the filter graph has got in and disconnected us from the input pin. If the filter has no worker threads then the lock is best applied on Receive(), otherwise it should be done when the worker thread is ready to deliver. There is a wee snag to worker threads that this shows up. The worker thread must lock the object when it is ready to deliver a sample, but it may have to wait until a state change has completed, but that may never complete because the state change is waiting for the worker thread to complete. The way to handle this is for the state change code to grab the critical section, then set an abort event for the worker thread, then release the critical section and wait for the worker thread to see the event we set and then signal that it has finished (with another event). At which point the state change code can complete } // note (if you've still got any breath left after reading that) that you // need to release the sample yourself after this call. if the connected // input pin needs to hold onto the sample beyond the call, it will addref // the sample itself. // of course you must release this one and call GetDeliveryBuffer for the // next. You cannot reuse it directly. function TBCBaseOutputPin.Deliver(Sample: IMediaSample): HRESULT; begin if (FInputPin = nil) then result := VFW_E_NOT_CONNECTED else result := FInputPin.Receive(Sample); end; // call BeginFlush on the connected input pin function TBCBaseOutputPin.DeliverBeginFlush: HRESULT; begin // remember this is on IPin not IMemInputPin if (FConnected = nil) then result := VFW_E_NOT_CONNECTED else result := FConnected.BeginFlush; end; // call EndFlush on the connected input pin function TBCBaseOutputPin.DeliverEndFlush: HRESULT; begin // remember this is on IPin not IMemInputPin if (FConnected = nil) then result := VFW_E_NOT_CONNECTED else result := FConnected.EndFlush; end; // called from elsewhere in our filter to pass EOS downstream to // our connected input pin function TBCBaseOutputPin.DeliverEndOfStream: HRESULT; begin // remember this is on IPin not IMemInputPin if (FConnected = nil) then result := VFW_E_NOT_CONNECTED else result := FConnected.EndOfStream; end; // deliver NewSegment to connected pin function TBCBaseOutputPin.DeliverNewSegment(Start, Stop: TReferenceTime; Rate: double): HRESULT; begin if (FConnected = nil) then result := VFW_E_NOT_CONNECTED else result := FConnected.NewSegment(Start, Stop, Rate); end; function TBCBaseOutputPin.EndFlush: HRESULT; begin result := E_UNEXPECTED; end; // we have a default handling of EndOfStream which is to return // an error, since this should be called on input pins only function TBCBaseOutputPin.EndOfStream: HRESULT; begin result := E_UNEXPECTED; end; // This returns an empty sample buffer from the allocator WARNING the same // dangers and restrictions apply here as described below for Deliver() function TBCBaseOutputPin.GetDeliveryBuffer(out Sample: IMediaSample; StartTime, EndTime: PReferenceTime; Flags: Longword): HRESULT; begin if (FAllocator <> nil) then result := FAllocator.GetBuffer(Sample, StartTime, EndTime, Flags) else result := E_NOINTERFACE; end; { Free up or unprepare allocator's memory, this is called through IMediaFilter which is responsible for locking the object first } function TBCBaseOutputPin.Inactive: HRESULT; begin FRunTimeError := FALSE; if (FAllocator = nil) then result := VFW_E_NO_ALLOCATOR else result := FAllocator.Decommit; end; // This is called when the input pin didn't give us a valid allocator function TBCBaseOutputPin.InitAllocator(out Alloc: IMemAllocator): HRESULT; begin result := CoCreateInstance(CLSID_MemoryAllocator, nil, CLSCTX_INPROC_SERVER, IID_IMemAllocator, Alloc); end; { TBCBaseInputPin } // Default handling for BeginFlush - call at the beginning // of your implementation (makes sure that all Receive calls // fail). After calling this, you need to free any queued data // and then call downstream. function TBCBaseInputPin.BeginFlush: HRESULT; begin // BeginFlush is NOT synchronized with streaming but is part of // a control action - hence we synchronize with the filter FLock.Lock; try // if we are already in mid-flush, this is probably a mistake // though not harmful - try to pick it up for now so I can think about it ASSERT(not FFlushing); // first thing to do is ensure that no further Receive calls succeed FFlushing := True; // now discard any data and call downstream - must do that // in derived classes result := S_OK; finally FLock.UnLock; end; end; function TBCBaseInputPin.BreakConnect: HRESULT; begin // We don't need our allocator any more if (FAllocator <> nil) then begin // Always decommit the allocator because a downstream filter may or // may not decommit the connection's allocator. A memory leak could // occur if the allocator is not decommited when a pin is disconnected. result := FAllocator.Decommit; if FAILED(result) then exit; FAllocator := nil; end; result := S_OK; end; // Check if it's OK to process data function TBCBaseInputPin.CheckStreaming: HRESULT; begin // Shouldn't be able to get any data if we're not connected! ASSERT(IsConnected); // Don't process stuff in Stopped state if IsStopped then begin result := VFW_E_WRONG_STATE; exit end; if FFlushing then begin result := S_FALSE; exit end; if FRunTimeError then begin result := VFW_E_RUNTIME_ERROR; exit end; result := S_OK; end; // Constructor creates a default allocator object constructor TBCBaseInputPin.Create(ObjectName: string; Filter: TBCBaseFilter; Lock: TBCCritSec; out hr: HRESULT; Name: WideString); begin inherited create(ObjectName, Filter, Lock, hr, Name, PINDIR_INPUT); FAllocator := nil; FReadOnly := false; FFlushing := false; ZeroMemory(@FSampleProps, sizeof(FSampleProps)); end; destructor TBCBaseInputPin.Destroy; begin if FAllocator <> nil then FAllocator := nil; inherited; end; // default handling for EndFlush - call at end of your implementation // - before calling this, ensure that there is no queued data and no thread // pushing any more without a further receive, then call downstream, // then call this method to clear the m_bFlushing flag and re-enable // receives function TBCBaseInputPin.EndFlush: HRESULT; begin // Endlush is NOT synchronized with streaming but is part of // a control action - hence we synchronize with the filter FLock.Lock; try // almost certainly a mistake if we are not in mid-flush ASSERT(FFlushing); // before calling, sync with pushing thread and ensure // no more data is going downstream, then call EndFlush on // downstream pins. // now re-enable Receives FFlushing := FALSE; // No more errors FRunTimeError := FALSE; result := S_OK; finally FLock.UnLock; end; end; { Return the allocator interface that this input pin would like the output pin to use. NOTE subsequent calls to GetAllocator should all return an interface onto the SAME object so we create one object at the start Note: The allocator is Release()'d on disconnect and replaced on NotifyAllocator(). Override this to provide your own allocator.} function TBCBaseInputPin.GetAllocator( out ppAllocator: IMemAllocator): HRESULT; begin FLock.Lock; try if (FAllocator = nil) then begin result := CoCreateInstance(CLSID_MemoryAllocator, nil, CLSCTX_INPROC_SERVER, IID_IMemAllocator, FAllocator); if FAILED(result) then exit; end; ASSERT(FAllocator <> nil); ppAllocator := FAllocator; result := NOERROR; finally FLock.UnLock; end; end; // what requirements do we have of the allocator - override if you want // to support other people's allocators but need a specific alignment // or prefix. function TBCBaseInputPin.GetAllocatorRequirements( out pProps: TAllocatorProperties): HRESULT; begin result := E_NOTIMPL; end; { Free up or unprepare allocator's memory, this is called through IMediaFilter which is responsible for locking the object first. } function TBCBaseInputPin.Inactive: HRESULT; begin FRunTimeError := FALSE; if (FAllocator = nil) then begin result := VFW_E_NO_ALLOCATOR; exit; end; FFlushing := FALSE; result := FAllocator.Decommit; end; function TBCBaseInputPin.Notify(pSelf: IBaseFilter; q: TQuality): HRESULT; begin {$IFDEF DEBUG} DbgLog(self, 'IQuality.Notify called on an input pin'); {$ENDIF} result := NOERROR; end; { Tell the input pin which allocator the output pin is actually going to use Override this if you care - NOTE the locking we do both here and also in GetAllocator is unnecessary but derived classes that do something useful will undoubtedly have to lock the object so this might help remind people } function TBCBaseInputPin.NotifyAllocator(pAllocator: IMemAllocator; bReadOnly: BOOL): HRESULT; begin FLock.Lock; try FAllocator := pAllocator; // the readonly flag indicates whether samples from this allocator should // be regarded as readonly - if True, then inplace transforms will not be // allowed. FReadOnly := bReadOnly; result := NOERROR; finally FLock.UnLock; end; end; // Pass on the Quality notification q to // a. Our QualityControl sink (if we have one) or else // b. to our upstream filter // and if that doesn't work, throw it away with a bad return code function TBCBaseInputPin.PassNotify(const q: TQuality): HRESULT; var IQC: IQualityControl; begin // We pass the message on, which means that we find the quality sink // for our input pin and send it there {$IFDEF DEBUG} DbgLog(self, 'Passing Quality notification through transform'); {$ENDIF} if (FQSink <> nil) then begin result := FQSink.Notify(FFilter, q); exit; end else begin // no sink set, so pass it upstream result := VFW_E_NOT_FOUND; // default if (FConnected <> nil) then begin FConnected.QueryInterface(IID_IQualityControl, IQC); if (IQC <> nil) then begin result := IQC.Notify(FFilter, q); IQC := nil; end; end; end; end; { Do something with this media sample - this base class checks to see if the format has changed with this media sample and if so checks that the filter will accept it, generating a run time error if not. Once we have raised a run time error we set a flag so that no more samples will be accepted It is important that any filter should override this method and implement synchronization so that samples are not processed when the pin is disconnected etc. } function TBCBaseInputPin.Receive(pSample: IMediaSample): HRESULT; var Sample2: IMediaSample2; begin ASSERT(pSample <> nil); result := CheckStreaming; if (S_OK <> result) then exit; // Check for IMediaSample2 if SUCCEEDED(pSample.QueryInterface(IID_IMediaSample2, Sample2)) then begin result := Sample2.GetProperties(sizeof(FSampleProps), FSampleProps); Sample2 := nil; if FAILED(result) then exit; end else begin // Get the properties the hard way FSampleProps.cbData := sizeof(FSampleProps); FSampleProps.dwTypeSpecificFlags := 0; FSampleProps.dwStreamId := AM_STREAM_MEDIA; FSampleProps.dwSampleFlags := 0; if (S_OK = pSample.IsDiscontinuity) then FSampleProps.dwSampleFlags := FSampleProps.dwSampleFlags or AM_SAMPLE_DATADISCONTINUITY; if (S_OK = pSample.IsPreroll) then FSampleProps.dwSampleFlags := FSampleProps.dwSampleFlags or AM_SAMPLE_PREROLL; if (S_OK = pSample.IsSyncPoint) then FSampleProps.dwSampleFlags := FSampleProps.dwSampleFlags or AM_SAMPLE_SPLICEPOINT; if SUCCEEDED(pSample.GetTime(FSampleProps.tStart, FSampleProps.tStop)) then FSampleProps.dwSampleFlags := FSampleProps.dwSampleFlags or AM_SAMPLE_TIMEVALID or AM_SAMPLE_STOPVALID; if (S_OK = pSample.GetMediaType(FSampleProps.pMediaType)) then FSampleProps.dwSampleFlags := FSampleProps.dwSampleFlags or AM_SAMPLE_TYPECHANGED; pSample.GetPointer(PByte(FSampleProps.pbBuffer)); FSampleProps.lActual := pSample.GetActualDataLength; FSampleProps.cbBuffer := pSample.GetSize; end; // Has the format changed in this sample if (not BOOL(FSampleProps.dwSampleFlags and AM_SAMPLE_TYPECHANGED)) then begin result := NOERROR; exit; end; // Check the derived class accepts this format */ // This shouldn't fail as the source must call QueryAccept first */ result := CheckMediaType(FSampleProps.pMediaType); if (result = NOERROR) then exit; // Raise a runtime error if we fail the media type FRunTimeError := True; EndOfStream; FFilter.NotifyEvent(EC_ERRORABORT,VFW_E_TYPE_NOT_ACCEPTED,0); result := VFW_E_INVALIDMEDIATYPE; end; // See if Receive() might block function TBCBaseInputPin.ReceiveCanBlock: HRESULT; var c, Pins, OutputPins: Integer; Pin: TBCBasePin; pd: TPinDirection; Connected: IPin; InputPin: IMemInputPin; begin { Ask all the output pins if they block If there are no output pin assume we do block. } Pins := FFilter.GetPinCount; OutputPins := 0; for c := 0 to Pins - 1 do begin Pin := FFilter.GetPin(c); result := Pin.QueryDirection(pd); if FAILED(result) then exit; if (pd = PINDIR_OUTPUT) then begin result := Pin.ConnectedTo(Connected); if SUCCEEDED(result) then begin assert(Connected <> nil); inc(OutputPins); result := Connected.QueryInterface(IID_IMemInputPin, InputPin); Connected := nil; if SUCCEEDED(result) then begin result := InputPin.ReceiveCanBlock; InputPin := nil; if (result <> S_FALSE) then begin result := S_OK; exit; end; end else begin // There's a transport we don't understand here result := S_OK; exit; end; end; end; end; if OutputPins = 0 then result := S_OK else result := S_FALSE; end; // Receive multiple samples function TBCBaseInputPin.ReceiveMultiple(var pSamples: IMediaSample; nSamples: Integer; out nSamplesProcessed: Integer): HRESULT; type TMediaSampleDynArray = array of IMediaSample; begin result := S_OK; nSamplesProcessed := 0; dec(nSamples); while (nSamples >= 0) do begin result := Receive(TMediaSampleDynArray(@pSamples)[nSamplesProcessed]); // S_FALSE means don't send any more if (result <> S_OK) then break; inc(nSamplesProcessed); dec(nSamples) end; end; function TBCBaseInputPin.SampleProps: PAMSample2Properties; begin ASSERT(FSampleProps.cbData <> 0); result := @FSampleProps; end; // milenko start (added TBCDynamicOutputPin conversion) { TBCDynamicOutputPin } // // The streaming thread calls IPin::NewSegment(), IPin::EndOfStream(), // IMemInputPin::Receive() and IMemInputPin::ReceiveMultiple() on the // connected input pin. The application thread calls Block(). The // following class members can only be called by the streaming thread. // // Deliver() // DeliverNewSegment() // StartUsingOutputPin() // StopUsingOutputPin() // ChangeOutputFormat() // ChangeMediaType() // DynamicReconnect() // // The following class members can only be called by the application thread. // // Block() // SynchronousBlockOutputPin() // AsynchronousBlockOutputPin() // constructor TBCDynamicOutputPin.Create(ObjectName: WideString; Filter: TBCBaseFilter; Lock: TBCCritSec; out hr: HRESULT; Name: WideString); begin inherited Create(ObjectName,Filter,Lock,hr,Name); FStopEvent := 0; FGraphConfig := nil; FPinUsesReadOnlyAllocator := False; FBlockState := NOT_BLOCKED; FUnblockOutputPinEvent := 0; FNotifyCallerPinBlockedEvent := 0; FBlockCallerThreadID := 0; FNumOutstandingOutputPinUsers := 0; FBlockStateLock := TBCCritSec.Create; hr := Initialize; end; destructor TBCDynamicOutputPin.Destroy; begin if(FUnblockOutputPinEvent <> 0) then begin // This call should not fail because we have access to m_hUnblockOutputPinEvent // and m_hUnblockOutputPinEvent is a valid event. ASSERT(CloseHandle(FUnblockOutputPinEvent)); end; if(FNotifyCallerPinBlockedEvent <> 0) then begin // This call should not fail because we have access to m_hNotifyCallerPinBlockedEvent // and m_hNotifyCallerPinBlockedEvent is a valid event. ASSERT(CloseHandle(FNotifyCallerPinBlockedEvent)); end; if Assigned(FBlockStateLock) then FreeAndNil(FBlockStateLock); inherited Destroy; end; function TBCDynamicOutputPin.NonDelegatingQueryInterface(const IID: TGUID; out Obj): HResult; begin if IsEqualGUID(IID,IID_IPinFlowControl) then begin if GetInterface(IID_IPinFlowControl, Obj) then Result := S_OK else Result := E_NOINTERFACE; end else begin Result := inherited NonDelegatingQueryInterface(IID,Obj); end; end; function TBCDynamicOutputPin.Disconnect: HRESULT; begin FLock.Lock; try Result := DisconnectInternal; finally FLock.Unlock; end; end; function TBCDynamicOutputPin.Block(dwBlockFlags: DWORD; hEvent: THandle): HResult; begin // Check for illegal flags. if BOOL(dwBlockFlags and not AM_PIN_FLOW_CONTROL_BLOCK) then begin Result := E_INVALIDARG; Exit; end; // Make sure the event is unsignaled. if(BOOL(dwBlockFlags and AM_PIN_FLOW_CONTROL_BLOCK) and (hEvent <> 0)) then begin if not ResetEvent(hEvent) then begin Result := AmGetLastErrorToHResult; Exit end; end; // No flags are set if we are unblocking the output pin. if(dwBlockFlags = 0) then begin // This parameter should be NULL because unblock operations are always synchronous. // There is no need to notify the caller when the event is done. if(hEvent <> 0) then begin Result := E_INVALIDARG; Exit; end; end; {$IFDEF DEBUG} AssertValid; {$ENDIF} // DEBUG if BOOL(dwBlockFlags and AM_PIN_FLOW_CONTROL_BLOCK) then begin // IPinFlowControl::Block()'s hEvent parameter is NULL if the block is synchronous. // If hEvent is not NULL, the block is asynchronous. if(hEvent = 0) then Result := SynchronousBlockOutputPin else Result := AsynchronousBlockOutputPin(hEvent); end else begin Result := UnblockOutputPin; end; {$IFDEF DEBUG} AssertValid; {$ENDIF} // DEBUG if(FAILED(Result)) then Exit; Result := S_OK; end; procedure TBCDynamicOutputPin.SetConfigInfo(GraphConfig: IGraphConfig; StopEvent: THandle); begin // This pointer is not addrefed because filters are not allowed to // hold references to the filter graph manager. See the documentation for // IBaseFilter::JoinFilterGraph() in the Direct Show SDK for more information. Pointer(FGraphConfig) := Pointer(GraphConfig); FStopEvent := StopEvent; end; {$IFDEF DEBUG} function TBCDynamicOutputPin.Deliver(Sample: IMediaSample): HRESULT; begin // The caller should call StartUsingOutputPin() before calling this // method. ASSERT(StreamingThreadUsingOutputPin); Result := inherited Deliver(Sample); end; function TBCDynamicOutputPin.DeliverEndOfStream: HRESULT; begin // The caller should call StartUsingOutputPin() before calling this // method. ASSERT(StreamingThreadUsingOutputPin); Result := inherited DeliverEndOfStream; end; function TBCDynamicOutputPin.DeliverNewSegment(Start, Stop: TReferenceTime; Rate: Double): HRESULT; begin // The caller should call StartUsingOutputPin() before calling this // method. ASSERT(StreamingThreadUsingOutputPin); Result := inherited DeliverNewSegment(Start, Stop, Rate); end; {$ENDIF} function TBCDynamicOutputPin.DeliverBeginFlush: HRESULT; begin // If this ASSERT fires, the user may have passed an invalid event handle to SetConfigInfo(). // The ASSERT can also fire if the event if destroyed and then DeliverBeginFlush() is called. // An event handle is invalid if 1) the event does not exist or the user does not have the security // permissions to use the event. ASSERT(SetEvent(FStopEvent)); Result := inherited DeliverBeginFlush; end; function TBCDynamicOutputPin.DeliverEndFlush: HRESULT; begin // If this ASSERT fires, the user may have passed an invalid event handle to SetConfigInfo(). // The ASSERT can also fire if the event if destroyed and then DeliverBeginFlush() is called. // An event handle is invalid if 1) the event does not exist or the user does not have the security // permissions to use the event. ASSERT(ResetEvent(FStopEvent)); Result := inherited DeliverEndFlush; end; function TBCDynamicOutputPin.Active: HRESULT; begin // Make sure the user initialized the object by calling SetConfigInfo(). if(FStopEvent = 0) or (FGraphConfig = nil) then begin {$IFDEF DEBUG} DbgLog('ERROR: TBCDynamicOutputPin.Active() failed because m_pGraphConfig' + ' and m_hStopEvent were not initialized. Call SetConfigInfo() to initialize them.'); {$ENDIF} // DEBUG Result := E_FAIL; Exit; end; // If this ASSERT fires, the user may have passed an invalid event handle to SetConfigInfo(). // The ASSERT can also fire if the event if destroyed and then Active() is called. An event // handle is invalid if 1) the event does not exist or the user does not have the security // permissions to use the event. ASSERT(ResetEvent(FStopEvent)); Result := inherited Active; end; function TBCDynamicOutputPin.Inactive: HRESULT; begin // If this ASSERT fires, the user may have passed an invalid event handle to SetConfigInfo(). // The ASSERT can also fire if the event if destroyed and then Active() is called. An event // handle is invalid if 1) the event does not exist or the user does not have the security // permissions to use the event. ASSERT(SetEvent(FStopEvent)); Result := inherited Inactive; end; function TBCDynamicOutputPin.CompleteConnect(ReceivePin: IPin): HRESULT; begin Result := inherited CompleteConnect(ReceivePin); if(SUCCEEDED(Result)) then begin if (not IsStopped) and (FAllocator <> nil) then begin Result := FAllocator.Commit; ASSERT(Result <> VFW_E_ALREADY_COMMITTED); end; end; end; function TBCDynamicOutputPin.StartUsingOutputPin: HRESULT; var WaitEvents: array[0..1] of THandle; NumWaitEvents: DWORD; ReturnValue: DWORD; begin // The caller should not hold m_BlockStateLock. If the caller does, // a deadlock could occur. ASSERT(FBlockStateLock.CritCheckIn); FBlockStateLock.Lock; try {$IFDEF DEBUG} AssertValid; {$ENDIF} // DEBUG // Are we in the middle of a block operation? while(BLOCKED = FBlockState) do begin FBlockStateLock.Unlock; // If this ASSERT fires, a deadlock could occur. The caller should make sure // that this thread never acquires the Block State lock more than once. ASSERT(FBlockStateLock.CritCheckIn); // WaitForMultipleObjects() returns WAIT_OBJECT_0 if the unblock event // is fired. It returns WAIT_OBJECT_0 + 1 if the stop event if fired. // See the Windows SDK documentation for more information on // WaitForMultipleObjects(). WaitEvents[0] := FUnblockOutputPinEvent; WaitEvents[0] := FStopEvent; NumWaitEvents := sizeof(WaitEvents) div sizeof(THANDLE); ReturnValue := WaitForMultipleObjects(NumWaitEvents, @WaitEvents, False, INFINITE); FBlockStateLock.Lock; {$IFDEF DEBUG} AssertValid; {$ENDIF} // DEBUG case ReturnValue of WAIT_OBJECT_0: break; WAIT_OBJECT_0 + 1: begin Result := VFW_E_STATE_CHANGED; Exit; end; WAIT_FAILED: begin Result := AmGetLastErrorToHResult; Exit; end; else begin {$IFDEF DEBUG} DbgLog('An Unexpected case occured in TBCDynamicOutputPin.StartUsingOutputPin().'); {$ENDIF} // DEBUG Result := E_UNEXPECTED; Exit; end; end; end; inc(FNumOutstandingOutputPinUsers); {$IFDEF DEBUG} AssertValid; {$ENDIF} // DEBUG Result := S_OK; finally FBlockStateLock.Unlock; end; end; procedure TBCDynamicOutputPin.StopUsingOutputPin; begin FBlockStateLock.Lock; try {$IFDEF DEBUG} AssertValid; {$ENDIF} // DEBUG dec(FNumOutstandingOutputPinUsers); if(FNumOutstandingOutputPinUsers = 0) and (NOT_BLOCKED <> FBlockState) then BlockOutputPin; {$IFDEF DEBUG} AssertValid; {$ENDIF} // DEBUG finally FBlockStateLock.Unlock; end; end; function TBCDynamicOutputPin.StreamingThreadUsingOutputPin: Boolean; begin FBlockStateLock.Lock; try Result := (FNumOutstandingOutputPinUsers > 0); finally FBlockStateLock.UnLock; end; end; function TBCDynamicOutputPin.ChangeOutputFormat(const pmt: PAMMEdiaType; tSegmentStart, tSegmentStop: TreferenceTime; dSegmentRate: Double): HRESULT; begin // The caller should call StartUsingOutputPin() before calling this // method. ASSERT(StreamingThreadUsingOutputPin); // Callers should always pass a valid media type to ChangeOutputFormat() . ASSERT(pmt <> nil); Result := ChangeMediaType(pmt); if (FAILED(Result)) then Exit; Result :=DeliverNewSegment(tSegmentStart, tSegmentStop, dSegmentRate); if(FAILED(Result)) then Exit; Result := S_OK; end; function TBCDynamicOutputPin.ChangeMediaType(const pmt: PAMMediaType): HRESULT; var pConnection: IPinConnection; begin // The caller should call StartUsingOutputPin() before calling this // method. ASSERT(StreamingThreadUsingOutputPin); // This function assumes the filter graph is running. ASSERT(not IsStopped); if (not IsConnected) then begin Result := VFW_E_NOT_CONNECTED; Exit; end; // First check if the downstream pin will accept a dynamic // format change FConnected.QueryInterface(IID_IPinConnection, pConnection); if(pConnection <> nil) then begin if(S_OK = pConnection.DynamicQueryAccept(pmt^)) then begin Result := ChangeMediaTypeHelper(pmt); if(FAILED(Result)) then Exit; Result := S_OK; Exit; end; end; // Can't do the dynamic connection Result := DynamicReconnect(pmt); end; // this method has to be called from the thread that is pushing data, // and it's the caller's responsibility to make sure that the thread // has no outstand samples because they cannot be delivered after a // reconnect // function TBCDynamicOutputPin.DynamicReconnect(const pmt: PAMMediaType): HRESULT; begin // The caller should call StartUsingOutputPin() before calling this // method. ASSERT(StreamingThreadUsingOutputPin); if(FGraphConfig = nil) or (FStopEvent = 0) then begin Result := E_FAIL; Exit; end; Result := FGraphConfig.Reconnect(Self,nil,pmt,nil,FStopEvent, AM_GRAPH_CONFIG_RECONNECT_CACHE_REMOVED_FILTERS); end; function TBCDynamicOutputPin.SynchronousBlockOutputPin: HRESULT; var NotifyCallerPinBlockedEvent: THandle; begin NotifyCallerPinBlockedEvent := CreateEvent(nil, // The event will have the default security attributes. False, // This is an automatic reset event. False, // The event is initially unsignaled. nil); // The event is not named. // CreateEvent() returns NULL if an error occurs. if(NotifyCallerPinBlockedEvent = 0) then begin Result := AmGetLastErrorToHResult; Exit; end; Result := AsynchronousBlockOutputPin(NotifyCallerPinBlockedEvent); if(FAILED(Result)) then begin // This call should not fail because we have access to hNotifyCallerPinBlockedEvent // and hNotifyCallerPinBlockedEvent is a valid event. ASSERT(CloseHandle(NotifyCallerPinBlockedEvent)); Exit; end; Result := WaitEvent(NotifyCallerPinBlockedEvent); // This call should not fail because we have access to hNotifyCallerPinBlockedEvent // and hNotifyCallerPinBlockedEvent is a valid event. ASSERT(CloseHandle(NotifyCallerPinBlockedEvent)); if(FAILED(Result)) then Exit; Result := S_OK; end; function TBCDynamicOutputPin.AsynchronousBlockOutputPin(NotifyCallerPinBlockedEvent: THandle): HRESULT; var Success : Boolean; begin // This function holds the m_BlockStateLock because it uses // m_dwBlockCallerThreadID, m_BlockState and // m_hNotifyCallerPinBlockedEvent. FBlockStateLock.Lock; try if (NOT_BLOCKED <> FBlockState) then begin if(FBlockCallerThreadID = GetCurrentThreadId) then Result := VFW_E_PIN_ALREADY_BLOCKED_ON_THIS_THREAD else Result := VFW_E_PIN_ALREADY_BLOCKED; Exit; end; Success := DuplicateHandle(GetCurrentProcess, NotifyCallerPinBlockedEvent, GetCurrentProcess, @FNotifyCallerPinBlockedEvent, EVENT_MODIFY_STATE, False, 0); if not Success then begin Result := AmGetLastErrorToHResult; Exit; end; FBlockState := PENDING; FBlockCallerThreadID := GetCurrentThreadId; // The output pin cannot be blocked if the streaming thread is // calling IPin::NewSegment(), IPin::EndOfStream(), IMemInputPin::Receive() // or IMemInputPin::ReceiveMultiple() on the connected input pin. Also, it // cannot be blocked if the streaming thread is calling DynamicReconnect(), // ChangeMediaType() or ChangeOutputFormat(). // The output pin can be immediately blocked. if not StreamingThreadUsingOutputPin then BlockOutputPin(); Result := S_OK; finally FBlockStateLock.Unlock; end; end; function TBCDynamicOutputPin.UnblockOutputPin: HRESULT; begin // UnblockOutputPin() holds the m_BlockStateLock because it // uses m_BlockState, m_dwBlockCallerThreadID and // m_hNotifyCallerPinBlockedEvent. FBlockStateLock.Lock; try if (NOT_BLOCKED = FBlockState) then begin Result := S_FALSE; Exit; end; // This should not fail because we successfully created the event // and we have the security permissions to change it's state. ASSERT(SetEvent(FUnblockOutputPinEvent)); // Cancel the block operation if it's still pending. if (FNotifyCallerPinBlockedEvent <> 0) then begin // This event should not fail because AsynchronousBlockOutputPin() successfully // duplicated this handle and we have the appropriate security permissions. ASSERT(SetEvent(FNotifyCallerPinBlockedEvent)); ASSERT(CloseHandle(FNotifyCallerPinBlockedEvent)); end; FBlockState := NOT_BLOCKED; FBlockCallerThreadID := 0; FNotifyCallerPinBlockedEvent := 0; Result := S_OK; finally FBlockStateLock.Unlock; end; end; procedure TBCDynamicOutputPin.BlockOutputPin; begin // The caller should always hold the m_BlockStateLock because this function // uses m_BlockState and m_hNotifyCallerPinBlockedEvent. ASSERT(FBlockStateLock.CritCheckIn); // This function should not be called if the streaming thread is modifying // the connection state or it's passing data downstream. ASSERT(not StreamingThreadUsingOutputPin); // This should not fail because we successfully created the event // and we have the security permissions to change it's state. ASSERT(ResetEvent(FUnblockOutputPinEvent)); // This event should not fail because AsynchronousBlockOutputPin() successfully // duplicated this handle and we have the appropriate security permissions. ASSERT(SetEvent(FNotifyCallerPinBlockedEvent)); ASSERT(CloseHandle(FNotifyCallerPinBlockedEvent)); FBlockState := BLOCKED; FNotifyCallerPinBlockedEvent := 0; end; procedure TBCDynamicOutputPin.ResetBlockState; begin end; class function TBCDynamicOutputPin.WaitEvent(Event: THandle): HRESULT; var ReturnValue: DWORD; begin ReturnValue := WaitForSingleObject(Event, INFINITE); case ReturnValue of WAIT_OBJECT_0: Result := S_OK; WAIT_FAILED : Result := AmGetLastErrorToHResult; else begin {$IFDEF DEBUG} DbgLog('An Unexpected case occured in TBCDynamicOutputPin::WaitEvent.'); {$ENDIF} Result := E_UNEXPECTED; end; end; end; function TBCDynamicOutputPin.Initialize: HRESULT; begin FUnblockOutputPinEvent := CreateEvent(nil, // The event will have the default security descriptor. True, // This is a manual reset event. True, // The event is initially signaled. nil); // The event is not named. // CreateEvent() returns NULL if an error occurs. if (FUnblockOutputPinEvent = 0) then begin Result := AmGetLastErrorToHResult; Exit; end; // Set flag to say we can reconnect while streaming. CanReconnectWhenActive := True; Result := S_OK; end; function TBCDynamicOutputPin.ChangeMediaTypeHelper(const pmt: PAMMediaType): HRESULT; var InputPinRequirements: ALLOCATOR_PROPERTIES; begin // The caller should call StartUsingOutputPin() before calling this // method. ASSERT(StreamingThreadUsingOutputPin); Result := FConnected.ReceiveConnection(Self,pmt^); if(FAILED(Result)) then Exit; Result := SetMediaType(pmt); if(FAILED(Result)) then Exit; // Does this pin use the local memory transport? if(FInputPin <> nil) then begin // This function assumes that m_pInputPin and m_Connected are // two different interfaces to the same object. ASSERT(IsEqualObject(FConnected, FInputPin)); InputPinRequirements.cbAlign := 0; InputPinRequirements.cbBuffer := 0; InputPinRequirements.cbPrefix := 0; InputPinRequirements.cBuffers := 0; FInputPin.GetAllocatorRequirements(InputPinRequirements); // A zero allignment does not make any sense. if(0 = InputPinRequirements.cbAlign) then InputPinRequirements.cbAlign := 1; Result := FAllocator.Decommit; if(FAILED(Result)) then Exit; Result := DecideBufferSize(FAllocator, @InputPinRequirements); if(FAILED(Result)) then Exit; Result := FAllocator.Commit; if(FAILED(Result)) then Exit; Result := FInputPin.NotifyAllocator(FAllocator, FPinUsesReadOnlyAllocator); if(FAILED(Result)) then Exit; end; Result := S_OK; end; {$IFDEF DEBUG} procedure TBCDynamicOutputPin.AssertValid; begin // Make sure the object was correctly initialized. // This ASSERT only fires if the object failed to initialize // and the user ignored the constructor's return code (phr). ASSERT(FUnblockOutputPinEvent <> 0); // If either of these ASSERTs fire, the user did not correctly call // SetConfigInfo(). ASSERT(FStopEvent <> 0); ASSERT(FGraphConfig <> nil); // Make sure the block state is consistent. FBlockStateLock.Lock; try // BLOCK_STATE variables only have three legal values: PENDING, BLOCKED and NOT_BLOCKED. ASSERT((NOT_BLOCKED = FBlockState) or (PENDING = FBlockState) or (BLOCKED = FBlockState)); // m_hNotifyCallerPinBlockedEvent is only needed when a block operation cannot complete // immediately. ASSERT(((FNotifyCallerPinBlockedEvent = 0) and (PENDING <> FBlockState)) or ((FNotifyCallerPinBlockedEvent <> 0) and (PENDING = FBlockState)) ); // m_dwBlockCallerThreadID should always be 0 if the pin is not blocked and // the user is not trying to block the pin. ASSERT((0 = FBlockCallerThreadID) or (NOT_BLOCKED <> FBlockState)); // If this ASSERT fires, the streaming thread is using the output pin and the // output pin is blocked. ASSERT(((0 <> FNumOutstandingOutputPinUsers) and (BLOCKED <> FBlockState)) or ((0 = FNumOutstandingOutputPinUsers) and (NOT_BLOCKED <> FBlockState)) or ((0 = FNumOutstandingOutputPinUsers) and (NOT_BLOCKED = FBlockState)) ); finally FBlockStateLock.UnLock; end; end; {$ENDIF} // milenko end { TBCTransformInputPin } // enter flushing state. Call default handler to block Receives, then // pass to overridable method in filter function TBCTransformInputPin.BeginFlush: HRESULT; begin FTransformFilter.FcsFilter.Lock; try // Are we actually doing anything? ASSERT(FTransformFilter.FOutput <> nil); if ((not IsConnected) or (not FTransformFilter.FOutput.IsConnected)) then begin result := VFW_E_NOT_CONNECTED; exit; end; result := inherited BeginFlush; if FAILED(result) then exit; result := FTransformFilter.BeginFlush; finally FTransformFilter.FcsFilter.UnLock; end; end; // provides derived filter a chance to release it's extra interfaces function TBCTransformInputPin.BreakConnect: HRESULT; begin ASSERT(IsStopped); FTransformFilter.BreakConnect(PINDIR_INPUT); result := inherited BreakConnect; end; function TBCTransformInputPin.CheckConnect(Pin: IPin): HRESULT; begin result := FTransformFilter.CheckConnect(PINDIR_INPUT, Pin); if FAILED(result) then exit; result := inherited CheckConnect(Pin); end; // check that we can support a given media type function TBCTransformInputPin.CheckMediaType( mtIn: PAMMediaType): HRESULT; begin // Check the input type result := FTransformFilter.CheckInputType(mtIn); if (S_OK <> result) then exit; // if the output pin is still connected, then we have // to check the transform not just the input format if ((FTransformFilter.FOutput <> nil) and (FTransformFilter.FOutput.IsConnected)) then begin result := FTransformFilter.CheckTransform(mtIn, FTransformFilter.FOutput.AMMediaType); end; end; function TBCTransformInputPin.CheckStreaming: HRESULT; begin ASSERT(FTransformFilter.FOutput <> nil); if(not FTransformFilter.FOutput.IsConnected) then begin result := VFW_E_NOT_CONNECTED; exit; end else begin // Shouldn't be able to get any data if we're not connected! ASSERT(IsConnected); // we're flushing if FFlushing then begin result := S_FALSE; exit; end; // Don't process stuff in Stopped state if IsStopped then begin result := VFW_E_WRONG_STATE; exit; end; if FRunTimeError then begin result := VFW_E_RUNTIME_ERROR; exit; end; result := S_OK; end; end; function TBCTransformInputPin.CompleteConnect(ReceivePin: IPin): HRESULT; begin result := FTransformFilter.CompleteConnect(PINDIR_INPUT, ReceivePin); if FAILED(result) then exit; result := inherited CompleteConnect(ReceivePin); end; constructor TBCTransformInputPin.Create(ObjectName: string; TransformFilter: TBCTransformFilter; out hr: HRESULT; Name: WideString); begin inherited Create(ObjectName, TransformFilter, TransformFilter.FcsFilter, hr, Name); {$IFDEF DEBUG} DbgLog(self, 'TBCTransformInputPin.Create'); {$ENDIF} FTransformFilter := TransformFilter; end; // leave flushing state. // Pass to overridable method in filter, then call base class // to unblock receives (finally) destructor TBCTransformInputPin.destroy; begin {$IFDEF DEBUG} DbgLog(self, 'TBCTransformInputPin.destroy'); {$ENDIF} inherited; end; function TBCTransformInputPin.EndFlush: HRESULT; begin FTransformFilter.FcsFilter.Lock; try // Are we actually doing anything? ASSERT(FTransformFilter.FOutput <> nil); if((not IsConnected) or (not FTransformFilter.FOutput.IsConnected)) then begin result := VFW_E_NOT_CONNECTED; exit; end; result := FTransformFilter.EndFlush; if FAILED(result) then exit; result := inherited EndFlush; finally FTransformFilter.FcsFilter.UnLock; end; end; // provide EndOfStream that passes straight downstream // (there is no queued data) function TBCTransformInputPin.EndOfStream: HRESULT; begin FTransformFilter.FcsReceive.Lock; try result := CheckStreaming; if (S_OK = result) then result := FTransformFilter.EndOfStream; finally FTransformFilter.FcsReceive.UnLock; end; end; function TBCTransformInputPin.NewSegment(Start, Stop: TReferenceTime; Rate: double): HRESULT; begin // Save the values in the pin inherited NewSegment(Start, Stop, Rate); result := FTransformFilter.NewSegment(Start, Stop, Rate); end; function TBCTransformInputPin.QueryId(out id: PWideChar): HRESULT; begin // milenko start (AMGetWideString was bugged, now the second line is not needed) Result := AMGetWideString('In', Id); // if id <> nil then result := S_OK else result := S_FALSE; // milenko end end; // here's the next block of data from the stream. // AddRef it yourself if you need to hold it beyond the end // of this call. function TBCTransformInputPin.Receive(pSample: IMediaSample): HRESULT; begin FTransformFilter.FcsReceive.Lock; try ASSERT(pSample <> nil); // check all is well with the base class result := inherited Receive(pSample); if (result = S_OK) then result := FTransformFilter.Receive(pSample); finally FTransformFilter.FcsReceive.Unlock; end; end; // set the media type for this connection function TBCTransformInputPin.SetMediaType(mt: PAMMediaType): HRESULT; begin // Set the base class media type (should always succeed) result := inherited SetMediaType(mt); if FAILED(result) then exit; // check the transform can be done (should always succeed) ASSERT(SUCCEEDED(FTransformFilter.CheckInputType(mt))); result := FTransformFilter.SetMediaType(PINDIR_INPUT,mt); end; { TBCCritSec } constructor TBCCritSec.Create; begin InitializeCriticalSection(FCritSec); {$IFDEF DEBUG} FcurrentOwner := 0; FlockCount := 0; // {$IFDEF TRACE} // FTrace := True; // {$ELSE} // FTrace := FALSE; // {$ENDIF} {$ENDIF} end; function TBCCritSec.CritCheckIn: boolean; begin {$IFDEF DEBUG} result := (GetCurrentThreadId = Self.FcurrentOwner); {$ELSE} result := True; {$ENDIF} end; function TBCCritSec.CritCheckOut: boolean; begin {$IFDEF DEBUG} result := (GetCurrentThreadId <> Self.FcurrentOwner); {$ELSE} result := false; {$ENDIF} end; destructor TBCCritSec.Destroy; begin DeleteCriticalSection(FCritSec) end; procedure TBCCritSec.Lock; begin {$IFDEF DEBUG} if ((FCurrentOwner <> 0) and (FCurrentOwner <> GetCurrentThreadId)) then begin // already owned, but not by us {$IFDEF TRACE} DbgLog(format('Thread %d about to wait for lock %x owned by %d', [GetCurrentThreadId, longint(self), FCurrentOwner])); {$ENDIF} end; {$ENDIF} EnterCriticalSection(FCritSec); {$IFDEF DEBUG} inc(FLockCount); if (FLockCount > 0) then begin // we now own it for the first time. Set owner information FcurrentOwner := GetCurrentThreadId; {$IFDEF TRACE} DbgLog(format('Thread %d now owns lock %x', [FcurrentOwner, LongInt(self)])); {$ENDIF} end; {$ENDIF} end; procedure TBCCritSec.UnLock; begin {$IFDEF DEBUG} dec(FlockCount); if(FlockCount = 0) then begin // about to be unowned {$IFDEF TRACE} DbgLog(format('Thread %d releasing lock %x', [FcurrentOwner, LongInt(Self)])); {$ENDIF} FcurrentOwner := 0; end; {$ENDIF} LeaveCriticalSection(FCritSec) end; { TBCTransformFilter } // Return S_FALSE to mean "pass the note on upstream" // Return NOERROR (Same as S_OK) // to mean "I've done something about it, don't pass it on" function TBCTransformFilter.AlterQuality(const q: TQuality): HRESULT; begin result := S_FALSE; end; // enter flush state. Receives already blocked // must override this if you have queued data or a worker thread function TBCTransformFilter.BeginFlush: HRESULT; begin result := NOERROR; if (FOutput <> nil) then // block receives -- done by caller (CBaseInputPin::BeginFlush) // discard queued data -- we have no queued data // free anyone blocked on receive - not possible in this filter // call downstream result := FOutput.DeliverBeginFlush; end; function TBCTransformFilter.BreakConnect(dir: TPinDirection): HRESULT; begin result := NOERROR; end; function TBCTransformFilter.CheckConnect(dir: TPinDirection; Pin: IPin): HRESULT; begin result := NOERROR; end; function TBCTransformFilter.CompleteConnect(direction: TPinDirection; ReceivePin: IPin): HRESULT; begin result := NOERROR; end; constructor TBCTransformFilter.Create(ObjectName: string; unk: IUnKnown; const clsid: TGUID); begin FcsFilter := TBCCritSec.Create; FcsReceive := TBCCritSec.Create; inherited Create(ObjectName,Unk,FcsFilter, clsid); FInput := nil; FOutput := nil; FEOSDelivered := FALSE; FQualityChanged:= FALSE; FSampleSkipped := FALSE; {$ifdef PERF} // RegisterPerfId; {$endif} end; constructor TBCTransformFilter.CreateFromFactory(Factory: TBCClassFactory; const Controller: IUnknown); begin Create(Factory.FName, Controller, Factory.FClassID); end; destructor TBCTransformFilter.destroy; begin if FInput <> nil then FInput.Free; if FOutput <> nil then FOutput.Free; {$IFDEF DEBUG} DbgLog(self, 'TBCTransformFilter.destroy'); {$ENDIF} FcsReceive.Free; inherited; end; // leave flush state. must override this if you have queued data // or a worker thread function TBCTransformFilter.EndFlush: HRESULT; begin // sync with pushing thread -- we have no worker thread // ensure no more data to go downstream -- we have no queued data // call EndFlush on downstream pins ASSERT(FOutput <> nil); result := FOutput.DeliverEndFlush; // caller (the input pin's method) will unblock Receives end; // EndOfStream received. Default behaviour is to deliver straight // downstream, since we have no queued data. If you overrode Receive // and have queue data, then you need to handle this and deliver EOS after // all queued data is sent function TBCTransformFilter.EndOfStream: HRESULT; begin result := NOERROR; if (FOutput <> nil) then result := FOutput.DeliverEndOfStream; end; // If Id is In or Out then return the IPin* for that pin // creating the pin if need be. Otherwise return NULL with an error. function TBCTransformFilter.FindPin(Id: PWideChar; out ppPin: IPin): HRESULT; begin if(WideString(Id) = 'In') then ppPin := GetPin(0) else if(WideString(Id) = 'Out') then ppPin := GetPin(1) else begin ppPin := nil; result := VFW_E_NOT_FOUND; exit; end; result := NOERROR; if(ppPin = nil) then result := E_OUTOFMEMORY; 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 // We return the objects as and when they are needed. If either of these fails // then we return NULL, the assumption being that the caller will realise the // whole deal is off and destroy us - which in turn will delete everything. function TBCTransformFilter.GetPin(n: integer): TBCBasePin; var hr: HRESULT; begin hr := S_OK; // Create an input pin if necessary if(FInput = nil) then begin FInput := TBCTransformInputPin.Create('Transform input pin', self, // Owner filter hr, // Result code 'XForm In'); // Pin name // Can't fail ASSERT(SUCCEEDED(hr)); if(FInput = nil) then begin result := nil; exit; end; FOutput := TBCTransformOutputPin.Create('Transform output pin', self, // Owner filter hr, // Result code 'XForm Out'); // Pin name // Can't fail ASSERT(SUCCEEDED(hr)); if(FOutput = nil) then FreeAndNil(FInput); end; // Return the appropriate pin case n of 0 : result := FInput; 1 : result := FOutput; else result := nil; end; end; function TBCTransformFilter.GetPinCount: integer; begin result := 2; end; // Set up our output sample function TBCTransformFilter.InitializeOutputSample(Sample: IMediaSample; out OutSample: IMediaSample): HRESULT; var Props: PAMSample2Properties; Flags: DWORD; Start, Stop: PReferenceTime; OutSample2: IMediaSample2; OutProps: TAMSample2Properties; MediaStart, MediaEnd: Int64; begin // default - times are the same Props := FInput.SampleProps; if FSampleSkipped then Flags := AM_GBF_PREVFRAMESKIPPED else Flags := 0; // This will prevent the image renderer from switching us to DirectDraw // when we can't do it without skipping frames because we're not on a // keyframe. If it really has to switch us, it still will, but then we // will have to wait for the next keyframe if(not BOOL(Props.dwSampleFlags and AM_SAMPLE_SPLICEPOINT)) then Flags := Flags or AM_GBF_NOTASYNCPOINT; ASSERT(FOutput.FAllocator <> nil); if BOOL(Props.dwSampleFlags and AM_SAMPLE_TIMEVALID) then Start := @Props.tStart else Start := nil; if BOOL(Props.dwSampleFlags and AM_SAMPLE_STOPVALID) then Stop := @Props.tStop else Stop := nil; result := FOutput.FAllocator.GetBuffer(OutSample, Start, Stop, Flags); if FAILED(result) then exit; ASSERT(OutSample <> nil); if SUCCEEDED(OutSample.QueryInterface(IID_IMediaSample2, OutSample2)) then begin ASSERT(SUCCEEDED(OutSample2.GetProperties(4*4, OutProps))); OutProps.dwTypeSpecificFlags := Props.dwTypeSpecificFlags; OutProps.dwSampleFlags := (OutProps.dwSampleFlags and AM_SAMPLE_TYPECHANGED) or (Props.dwSampleFlags and (not AM_SAMPLE_TYPECHANGED)); OutProps.tStart := Props.tStart; OutProps.tStop := Props.tStop; OutProps.cbData := (4*4) + (2*8); OutSample2.SetProperties((4*4)+(2*8), OutProps); if BOOL(Props.dwSampleFlags and AM_SAMPLE_DATADISCONTINUITY) then FSampleSkipped := FALSE; OutSample2 := nil; end else begin if BOOL(Props.dwSampleFlags and AM_SAMPLE_TIMEVALID) then OutSample.SetTime(@Props.tStart, @Props.tStop); if BOOL(Props.dwSampleFlags and AM_SAMPLE_SPLICEPOINT) then OutSample.SetSyncPoint(True); if BOOL(Props.dwSampleFlags and AM_SAMPLE_DATADISCONTINUITY) then begin OutSample.SetDiscontinuity(True); FSampleSkipped := FALSE; end; // Copy the media times if (Sample.GetMediaTime(MediaStart,MediaEnd) = NOERROR) then OutSample.SetMediaTime(@MediaStart, @MediaEnd); end; result := S_OK; end; function TBCTransformFilter.NewSegment(Start, Stop: TReferenceTime; Rate: double): HRESULT; begin result := S_OK; if (FOutput <> nil) then result := FOutput.DeliverNewSegment(Start, Stop, Rate); end; function TBCTransformFilter.Pause: HRESULT; begin FcsFilter.Lock; try result := NOERROR; if (FState = State_Paused) then begin // (This space left deliberately blank) end // If we have no input pin or it isn't yet connected then when we are // asked to pause we deliver an end of stream to the downstream filter. // This makes sure that it doesn't sit there forever waiting for // samples which we cannot ever deliver without an input connection. else if ((FInput = nil) or (FInput.IsConnected = FALSE)) then begin if ((FOutput <> nil) and (FEOSDelivered = FALSE)) then begin FOutput.DeliverEndOfStream; FEOSDelivered := True; end; FState := State_Paused; end // We may have an input connection but no output connection // However, if we have an input pin we do have an output pin else if (FOutput.IsConnected = FALSE) then FState := State_Paused else begin if(FState = State_Stopped) then begin // allow a class derived from CTransformFilter // to know about starting and stopping streaming FcsReceive.Lock; try result := StartStreaming; finally FcsReceive.UnLock; end; end; if SUCCEEDED(result) then result := inherited Pause; end; FSampleSkipped := FALSE; FQualityChanged := FALSE; finally FcsFilter.UnLock; end; end; // override this to customize the transform process function TBCTransformFilter.Receive(Sample: IMediaSample): HRESULT; var Props: PAMSample2Properties; OutSample: IMediaSample; begin // Check for other streams and pass them on Props := FInput.SampleProps; if(Props.dwStreamId <> AM_STREAM_MEDIA) then begin result := FOutput.FInputPin.Receive(Sample); exit; end; // If no output to deliver to then no point sending us data ASSERT(FOutput <> nil) ; // Set up the output sample result := InitializeOutputSample(Sample, OutSample); if FAILED(result) then exit; result := Transform(Sample, OutSample); if FAILED(result) then begin {$IFDEF DEBUG} DbgLog(self, 'Error from transform'); {$ENDIF} exit; end else begin // 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 begin result := FOutput.FInputPin.Receive(OutSample); FSampleSkipped := FALSE; // last thing no longer dropped end else 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. if (result = S_FALSE) then begin // Release the sample before calling notify to avoid // deadlocks if the sample holds a lock on the system // such as DirectDraw buffers do OutSample := nil; FSampleSkipped := True; if not FQualityChanged then begin NotifyEvent(EC_QUALITY_CHANGE,0,0); FQualityChanged := True; end; result := NOERROR; exit; end; end; end; // release the output buffer. If the connected pin still needs it, // it will have addrefed it itself. OutSample := nil; end; function TBCTransformFilter.SetMediaType(direction: TPinDirection; pmt: PAMMediaType): HRESULT; begin result := NOERROR; end; // override these two functions if you want to inform something // about entry to or exit from streaming state. function TBCTransformFilter.StartStreaming: HRESULT; begin result := NOERROR; end; // override these so that the derived filter can catch them function TBCTransformFilter.Stop: HRESULT; begin FcsFilter.Lock; try if(FState = State_Stopped) then begin result := NOERROR; exit; end; // Succeed the Stop if we are not completely connected ASSERT((FInput = nil) or (FOutput <> nil)); if((FInput = nil) or (FInput.IsConnected = FALSE) or (FOutput.IsConnected = FALSE)) then begin FState := State_Stopped; FEOSDelivered := FALSE; result := NOERROR; exit; end; ASSERT(FInput <> nil); ASSERT(FOutput <> nil); // decommit the input pin before locking or we can deadlock FInput.Inactive; // synchronize with Receive calls FcsReceive.Lock; try FOutput.Inactive; // allow a class derived from CTransformFilter // to know about starting and stopping streaming result := StopStreaming; if SUCCEEDED(result) then begin // complete the state transition FState := State_Stopped; FEOSDelivered := FALSE; end; finally FcsReceive.UnLock; end; finally FcsFilter.UnLock; end; end; function TBCTransformFilter.StopStreaming: HRESULT; begin result := NOERROR; end; function TBCTransformFilter.Transform(msIn, msout: IMediaSample): HRESULT; begin {$IFDEF DEBUG} DbgLog(self, 'TBCTransformFilter.Transform should never be called'); {$ENDIF} result := E_UNEXPECTED; end; { TBCTransformOutputPin } // provides derived filter a chance to release it's extra interfaces function TBCTransformOutputPin.BreakConnect: HRESULT; begin // Can't disconnect unless stopped ASSERT(IsStopped); FTransformFilter.BreakConnect(PINDIR_OUTPUT); result := inherited BreakConnect; end; // provides derived filter a chance to grab extra interfaces function TBCTransformOutputPin.CheckConnect(Pin: IPin): HRESULT; begin // we should have an input connection first ASSERT(FTransformFilter.FInput <> nil); if(FTransformFilter.FInput.IsConnected = FALSE) then begin result := E_UNEXPECTED; exit; end; result := FTransformFilter.CheckConnect(PINDIR_OUTPUT, Pin); if FAILED(result) then exit; result := inherited CheckConnect(Pin); end; // check a given transform - must have selected input type first function TBCTransformOutputPin.CheckMediaType( mtOut: PAMMediaType): HRESULT; begin // must have selected input first ASSERT(FTransformFilter.FInput <> nil); if(FTransformFilter.FInput.IsConnected = FALSE) then begin result := E_INVALIDARG; exit; end; result := FTransformFilter.CheckTransform(FTransformFilter.FInput.AMMediaType, mtOut); end; // Let derived class know when the output pin is connected function TBCTransformOutputPin.CompleteConnect(ReceivePin: IPin): HRESULT; begin result := FTransformFilter.CompleteConnect(PINDIR_OUTPUT, ReceivePin); if FAILED(result) then exit; result := inherited CompleteConnect(ReceivePin); end; constructor TBCTransformOutputPin.Create(ObjectName: string; TransformFilter: TBCTransformFilter; out hr: HRESULT; Name: WideString); begin inherited create(ObjectName, TransformFilter, TransformFilter.FcsFilter, hr, Name); FPosition := nil; {$IFDEF DEBUG} DbgLog(self, 'TBCTransformOutputPin.Create'); {$ENDIF} FTransformFilter := TransformFilter; end; function TBCTransformOutputPin.DecideBufferSize(Alloc: IMemAllocator; Prop: PAllocatorProperties): HRESULT; begin result := FTransformFilter.DecideBufferSize(Alloc, Prop); end; destructor TBCTransformOutputPin.destroy; begin {$IFDEF DEBUG} DbgLog(self, 'TBCTransformOutputPin.Destroy'); {$ENDIF} FPosition := nil; inherited; end; function TBCTransformOutputPin.GetMediaType(Position: integer; out MediaType: PAMMediaType): HRESULT; begin ASSERT(FTransformFilter.FInput <> nil); // We don't have any media types if our input is not connected if(FTransformFilter.FInput.IsConnected) then begin result := FTransformFilter.GetMediaType(Position, MediaType); exit; end else result := VFW_S_NO_MORE_ITEMS; end; function TBCTransformOutputPin.NonDelegatingQueryInterface( const IID: TGUID; out Obj): HResult; begin if IsEqualGUID(iid, IID_IMediaPosition) or IsEqualGUID(iid, IID_IMediaSeeking) then begin // we should have an input pin by now ASSERT(FTransformFilter.FInput <> nil); if (FPosition = nil) then begin result := CreatePosPassThru(GetOwner, FALSE, FTransformFilter.FInput, FPosition); if FAILED(result) then exit; end; result := FPosition.QueryInterface(iid, obj); end else result := inherited NonDelegatingQueryInterface(iid, obj); end; // Override this if you can do something constructive to act on the // quality message. Consider passing it upstream as well // Pass the quality mesage on upstream. function TBCTransformOutputPin.Notify(Sendr: IBaseFilter; q: TQuality): HRESULT; begin // First see if we want to handle this ourselves result := FTransformFilter.AlterQuality(q); if (result <> S_FALSE) then exit; // S_FALSE means we pass the message on. // Find the quality sink for our input pin and send it there ASSERT(FTransformFilter.FInput <> nil); result := FTransformFilter.FInput.PassNotify(q); end; function TBCTransformOutputPin.QueryId(out Id: PWideChar): HRESULT; begin result := AMGetWideString('Out', Id); end; // called after we have agreed a media type to actually set it in which case // we run the CheckTransform function to get the output format type again function TBCTransformOutputPin.SetMediaType(pmt: PAMMediaType): HRESULT; begin ASSERT(FTransformFilter.FInput <> nil); ASSERT(not IsEqualGUID(FTransformFilter.FInput.AMMediaType.majortype,GUID_NULL)); // Set the base class media type (should always succeed) result := inherited SetMediaType(pmt); if FAILED(result) then exit; {$ifdef DEBUG} if(FAILED(FTransformFilter.CheckTransform(FTransformFilter.FInput.AMMediaType, pmt))) then begin DbgLog(self, '*** This filter is accepting an output media type'); DbgLog(self, ' that it can''t currently transform to. I hope'); DbgLog(self, ' it''s smart enough to reconnect its input.'); end; {$endif} result := FTransformFilter.SetMediaType(PINDIR_OUTPUT,pmt); end; // milenko start (added TBCVideoTransformFilter conversion) { TBCVideoTransformFilter } // This class is derived from CTransformFilter, but is specialised to handle // the requirements of video quality control by frame dropping. // This is a non-in-place transform, (i.e. it copies the data) such as a decoder. constructor TBCVideoTransformFilter.Create(Name: WideString; Unk: IUnknown; clsid: TGUID); begin inherited Create(name, Unk, clsid); FitrLate := 0; FKeyFramePeriod := 0; // No QM until we see at least 2 key frames FFramesSinceKeyFrame := 0; FSkipping := False; FtDecodeStart := 0; FitrAvgDecode := 300000; // 30mSec - probably allows skipping FQualityChanged := False; {$IFDEF PERF} RegisterPerfId(); {$ENDIF} // PERF end; destructor TBCVideoTransformFilter.Destroy; begin inherited Destroy; end; // Overriden to reset quality management information function TBCVideoTransformFilter.EndFlush: HRESULT; begin FcsReceive.Lock; try // Reset our stats // // Note - we don't want to call derived classes here, // we only want to reset our internal variables and this // is a convenient way to do it StartStreaming; Result := inherited EndFlush; finally FcsReceive.UnLock; end; end; {$IFDEF PERF} procedure TBCVideoTransformFilter.RegisterPerfId; begin FidSkip := MSR_REGISTER('Video Transform Skip frame'); FidFrameType := MSR_REGISTER('Video transform frame type'); FidLate := MSR_REGISTER('Video Transform Lateness'); FidTimeTillKey := MSR_REGISTER('Video Transform Estd. time to next key'); // inherited RegisterPerfId; end; {$ENDIF} function TBCVideoTransformFilter.StartStreaming: HRESULT; begin FitrLate := 0; FKeyFramePeriod := 0; // No QM until we see at least 2 key frames FFramesSinceKeyFrame := 0; FSkipping := False; FtDecodeStart := 0; FitrAvgDecode := 300000; // 30mSec - probably allows skipping FQualityChanged := False; FSampleSkipped := False; Result := NOERROR; end; // Reset our quality management state function TBCVideoTransformFilter.AbortPlayback(hr: HRESULT): HRESULT; begin NotifyEvent(EC_ERRORABORT, hr, 0); FOutput.DeliverEndOfStream; Result := hr; end; // Receive() // // Accept a sample from upstream, decide whether to process it // or drop it. If we process it then get a buffer from the // allocator of the downstream connection, transform it into the // new buffer and deliver it to the downstream filter. // If we decide not to process it then we do not get a buffer. // Remember that although this code will notice format changes coming into // the input pin, it will NOT change its output format if that results // in the filter needing to make a corresponding output format change. Your // derived filter will have to take care of that. (eg. a palette change if // the input and output is an 8 bit format). If the input sample is discarded // and nothing is sent out for this Receive, please remember to put the format // change on the first output sample that you actually do send. // If your filter will produce the same output type even when the input type // changes, then this base class code will do everything you need. function TBCVideoTransformFilter.Receive(Sample: IMediaSample): HRESULT; var pmtOut, pmt: PAMMediaType; pOutSample: IMediaSample; {$IFDEF DEBUG} fccOut: TGUID; lCompression: LongInt; lBitCount: LongInt; lStride: LongInt; rcS: TRect; rcT: TRect; rcS1: TRect; rcT1: TRect; {$ENDIF} begin // If the next filter downstream is the video renderer, then it may // be able to operate in DirectDraw mode which saves copying the data // and gives higher performance. In that case the buffer which we // get from GetDeliveryBuffer will be a DirectDraw buffer, and // drawing into this buffer draws directly onto the display surface. // This means that any waiting for the correct time to draw occurs // during GetDeliveryBuffer, and that once the buffer is given to us // the video renderer will count it in its statistics as a frame drawn. // This means that any decision to drop the frame must be taken before // calling GetDeliveryBuffer. ASSERT(FcsReceive.CritCheckIn); ASSERT(Sample <> nil); // If no output pin to deliver to then no point sending us data ASSERT (FOutput <> nil) ; // The source filter may dynamically ask us to start transforming from a // different media type than the one we're using now. If we don't, we'll // draw garbage. (typically, this is a palette change in the movie, // but could be something more sinister like the compression type changing, // or even the video size changing) Sample.GetMediaType(pmt); if (pmt <> nil) and (pmt.pbFormat <> nil) then begin // spew some debug output ASSERT(not IsEqualGUID(pmt.majortype, GUID_NULL)); {$IFDEF DEBUG} fccOut := pmt.subtype; lCompression := PVideoInfoHeader(pmt.pbFormat).bmiHeader.biCompression; lBitCount := PVideoInfoHeader(pmt.pbFormat).bmiHeader.biBitCount; lStride := (PVideoInfoHeader(pmt.pbFormat).bmiHeader.biWidth * lBitCount + 7) div 8; lStride := (lStride + 3) and not 3; rcS1 := PVideoInfoHeader(pmt.pbFormat).rcSource; rcT1 := PVideoInfoHeader(pmt.pbFormat).rcTarget; DbgLog(Self,'Changing input type on the fly to'); DbgLog(Self,'FourCC: ' + inttohex(fccOut.D1,8) + ' Compression: ' + inttostr(lCompression) + ' BitCount: ' + inttostr(lBitCount)); DbgLog(Self,'biHeight: ' + inttostr(PVideoInfoHeader(pmt.pbFormat).bmiHeader.biHeight) + ' rcDst: (' + inttostr(rcT1.left) + ', ' + inttostr(rcT1.top) + ', ' + inttostr(rcT1.right) + ', ' + inttostr(rcT1.bottom) + ')'); DbgLog(Self,'rcSrc: (' + inttostr(rcS1.left) + ', ' + inttostr(rcS1.top) + ', ' + inttostr(rcS1.right) + ', ' + inttostr(rcS1.bottom) + ') Stride' + inttostr(lStride)); {$ENDIF} // now switch to using the new format. I am assuming that the // derived filter will do the right thing when its media type is // switched and streaming is restarted. StopStreaming(); CopyMediaType(FInput.AMMediaType,pmt); DeleteMediaType(pmt); // if this fails, playback will stop, so signal an error Result := StartStreaming; if (FAILED(Result)) then begin Result := AbortPlayback(Result); Exit; end; end; // Now that we have noticed any format changes on the input sample, it's // OK to discard it. if ShouldSkipFrame(Sample) then begin {$IFDEF PERF} // MSR_NOTE(m_idSkip); {$ENDIF} FSampleSkipped := True; Result := NOERROR; Exit; end; // Set up the output sample Result := InitializeOutputSample(Sample, pOutSample); if (FAILED(Result)) then Exit; FSampleSkipped := False; // The renderer may ask us to on-the-fly to start transforming to a // different format. If we don't obey it, we'll draw garbage pOutSample.GetMediaType(pmtOut); if (pmtOut <> nil) and (pmtOut.pbFormat <> nil) then begin // spew some debug output ASSERT(not IsEqualGUID(pmtOut.majortype, GUID_NULL)); {$IFDEF DEBUG} fccOut := pmtOut.subtype; lCompression := PVideoInfoHeader(pmtOut.pbFormat).bmiHeader.biCompression; lBitCount := PVideoInfoHeader(pmtOut.pbFormat).bmiHeader.biBitCount; lStride := (PVideoInfoHeader(pmtOut.pbFormat).bmiHeader.biWidth * lBitCount + 7) div 8; lStride := (lStride + 3) and not 3; rcS := PVideoInfoHeader(pmtOut.pbFormat).rcSource; rcT := PVideoInfoHeader(pmtOut.pbFormat).rcTarget; DbgLog(Self,'Changing input type on the fly to'); DbgLog(Self,'FourCC: ' + inttohex(fccOut.D1,8) + ' Compression: ' + inttostr(lCompression) + ' BitCount: ' + inttostr(lBitCount)); DbgLog(Self,'biHeight: ' + inttostr(PVideoInfoHeader(pmtOut.pbFormat).bmiHeader.biHeight) + ' rcDst: (' + inttostr(rcT1.left) + ', ' + inttostr(rcT1.top) + ', ' + inttostr(rcT1.right) + ', ' + inttostr(rcT1.bottom) + ')'); DbgLog(Self,'rcSrc: (' + inttostr(rcS1.left) + ', ' + inttostr(rcS1.top) + ', ' + inttostr(rcS1.right) + ', ' + inttostr(rcS1.bottom) + ') Stride' + inttostr(lStride)); {$ENDIF} // now switch to using the new format. I am assuming that the // derived filter will do the right thing when its media type is // switched and streaming is restarted. StopStreaming(); CopyMediaType(FOutput.AMMediaType,pmtOut); DeleteMediaType(pmtOut); Result := StartStreaming; if (SUCCEEDED(Result)) then begin // a new format, means a new empty buffer, so wait for a keyframe // before passing anything on to the renderer. // !!! a keyframe may never come, so give up after 30 frames {$IFDEF DEBUG} DbgLog(Self,'Output format change means we must wait for a keyframe'); {$ENDIF} FWaitForKey := 30; // if this fails, playback will stop, so signal an error end else begin // Must release the sample before calling AbortPlayback // because we might be holding the win16 lock or // ddraw lock pOutSample := nil; AbortPlayback(Result); Exit; end; end; // After a discontinuity, we need to wait for the next key frame if (Sample.IsDiscontinuity = S_OK) then begin {$IFDEF DEBUG} DbgLog(Self,'Non-key discontinuity - wait for keyframe'); {$ENDIF} FWaitForKey := 30; end; // Start timing the transform (and log it if PERF is defined) if (SUCCEEDED(Result)) then begin FtDecodeStart := timeGetTime; {$IFDEF PERF} // MSR_START(FidTransform); // not added in conversion {$ENDIF} // have the derived class transform the data Result := Transform(Sample, pOutSample); // Stop the clock (and log it if PERF is defined) {$IFDEF PERF} // MSR_STOP(m_idTransform); // not added in conversion {$ENDIF} FtDecodeStart := timeGetTime - int64(FtDecodeStart); FitrAvgDecode := Round(FtDecodeStart * (10000 / 16) + 15 * (FitrAvgDecode / 16)); // Maybe we're waiting for a keyframe still? if (FWaitForKey > 0) then dec(FWaitForKey); if (FWaitForKey > 0) and (Sample.IsSyncPoint = S_OK) then BOOL(FWaitForKey) := False; // if so, then we don't want to pass this on to the renderer if (FWaitForKey > 0) and (Result = NOERROR) then begin {$IFDEF DEBUG} DbgLog(Self,'still waiting for a keyframe'); Result := S_FALSE; {$ENDIF} end; end; if (FAILED(Result)) then begin {$IFDEF DEBUG} DbgLog(Self,'Error from video transform'); {$ENDIF} end else begin // 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.) // Try not to return S_FALSE to a direct draw buffer (it's wasteful) // Try to take the decision earlier - before you get it. if (Result = NOERROR) then begin Result := FOutput.Deliver(pOutSample); end else begin // S_FALSE returned from Transform is a PRIVATE agreement // We should return NOERROR from Receive() in this case because returning S_FALSE // from Receive() means that this is the end of the stream and no more data should // be sent. if (S_FALSE = Result) then begin // We must Release() the sample before doing anything // like calling the filter graph because having the // sample means we may have the DirectDraw lock // (== win16 lock on some versions) pOutSample := nil; FSampleSkipped := True; if not FQualityChanged then begin FQualityChanged := True; NotifyEvent(EC_QUALITY_CHANGE,0,0); end; Result := NOERROR; Exit; end; end; end; // release the output buffer. If the connected pin still needs it, // it will have addrefed it itself. pOutSample := nil; ASSERT(FcsReceive.CritCheckIn); end; function TBCVideoTransformFilter.AlterQuality(const q: TQuality): HRESULT; begin // to reduce the amount of 64 bit arithmetic, m_itrLate is an int. // +, -, >, == etc are not too bad, but * and / are painful. if (FitrLate > 300000000) then begin // Avoid overflow and silliness - more than 30 secs late is already silly FitrLate := 300000000; end else begin FitrLate := integer(q.Late); end; // We ignore the other fields // We're actually not very good at handling this. In non-direct draw mode // most of the time can be spent in the renderer which can skip any frame. // In that case we'd rather the renderer handled things. // Nevertheless we will keep an eye on it and if we really start getting // a very long way behind then we will actually skip - but we'll still tell // the renderer (or whoever is downstream) that they should handle quality. Result := E_FAIL; // Tell the renderer to do his thing. end; function TBCVideoTransformFilter.ShouldSkipFrame(pIn: IMediaSample): Boolean; var Start, StopAt: TReferenceTime; itrFrame: integer; it: integer; begin Result := pIn.GetTime(Start, StopAt) = S_OK; // Don't skip frames with no timestamps if not Result then Exit; itrFrame := integer(StopAt - Start); // frame duration if(S_OK = pIn.IsSyncPoint) then begin {$IFDEF PERF} MSR_INTEGER(FidFrameType, 1); {$ENDIF} if (FKeyFramePeriod < FFramesSinceKeyFrame) then begin // record the max FKeyFramePeriod := FFramesSinceKeyFrame; end; FFramesSinceKeyFrame := 0; FSkipping := False; end else begin {$IFDEF PERF} MSR_INTEGER(FidFrameType, 2); {$ENDIF} if (FFramesSinceKeyFrame > FKeyFramePeriod) and (FKeyFramePeriod > 0) then begin // We haven't seen the key frame yet, but we were clearly being // overoptimistic about how frequent they are. FKeyFramePeriod := FFramesSinceKeyFrame; end; end; // Whatever we might otherwise decide, // if we are taking only a small fraction of the required frame time to decode // then any quality problems are actually coming from somewhere else. // Could be a net problem at the source for instance. In this case there's // no point in us skipping frames here. if (FitrAvgDecode * 4 > itrFrame) then begin // Don't skip unless we are at least a whole frame late. // (We would skip B frames if more than 1/2 frame late, but they're safe). if (FitrLate > itrFrame) then begin // Don't skip unless the anticipated key frame would be no more than // 1 frame early. If the renderer has not been waiting (we *guess* // it hasn't because we're late) then it will allow frames to be // played early by up to a frame. // Let T = Stream time from now to anticipated next key frame // = (frame duration) * (KeyFramePeriod - FramesSinceKeyFrame) // So we skip if T - Late < one frame i.e. // (duration) * (freq - FramesSince) - Late < duration // or (duration) * (freq - FramesSince - 1) < Late // We don't dare skip until we have seen some key frames and have // some idea how often they occur and they are reasonably frequent. if (FKeyFramePeriod > 0) then begin // It would be crazy - but we could have a stream with key frames // a very long way apart - and if they are further than about // 3.5 minutes apart then we could get arithmetic overflow in // reference time units. Therefore we switch to mSec at this point it := (itrFrame div 10000) * (FKeyFramePeriod - FFramesSinceKeyFrame - 1); {$IFDEF PERF} MSR_INTEGER(FidTimeTillKey, it); {$ENDIF} // For debug - might want to see the details - dump them as scratch pad {$IFDEF VTRANSPERF} MSR_INTEGER(0, itrFrame); MSR_INTEGER(0, FFramesSinceKeyFrame); MSR_INTEGER(0, FKeyFramePeriod); {$ENDIF} if (FitrLate div 10000 > it) then begin FSkipping := True; // Now we are committed. Once we start skipping, we // cannot stop until we hit a key frame. end else begin {$IFDEF VTRANSPERF} MSR_INTEGER(0, 777770); // not near enough to next key {$ENDIF} end; end else begin {$IFDEF VTRANSPERF} MSR_INTEGER(0, 777771); // Next key not predictable {$ENDIF} end; end else begin {$IFDEF VTRANSPERF} MSR_INTEGER(0, 777772); // Less than one frame late MSR_INTEGER(0, FitrLate); MSR_INTEGER(0, itrFrame); {$ENDIF} end; end else begin {$IFDEF VTRANSPERF} MSR_INTEGER(0, 777773); // Decode time short - not not worth skipping MSR_INTEGER(0, FitrAvgDecode); MSR_INTEGER(0, itrFrame); {$ENDIF} end; inc(FFramesSinceKeyFrame); if FSkipping then begin // We will count down the lateness as we skip each frame. // We re-assess each frame. The key frame might not arrive when expected. // We reset m_itrLate if we get a new Quality message, but actually that's // not likely because we're not sending frames on to the Renderer. In // fact if we DID get another one it would mean that there's a long // pipe between us and the renderer and we might need an altogether // better strategy to avoid hunting! FitrLate := FitrLate - itrFrame; end; {$IFDEF PERF} MSR_INTEGER(FidLate, integer(FitrLate div 10000)); // Note how late we think we are {$ENDIF} if FSkipping then begin if not FQualityChanged then begin FQualityChanged := True; NotifyEvent(EC_QUALITY_CHANGE,0,0); end; end; Result := FSkipping; end; // milenko end { TCTransInPlaceInputPin } function TBCTransInPlaceInputPin.CheckMediaType( pmt: PAMMediaType): HRESULT; begin result := FTIPFilter.CheckInputType(pmt); if (result <> S_OK) then exit; if FTIPFilter.FOutput.IsConnected then result := FTIPFilter.FOutput.GetConnected.QueryAccept(pmt^) else result := S_OK; end; function TBCTransInPlaceInputPin.EnumMediaTypes( out ppEnum: IEnumMediaTypes): HRESULT; begin // Can only pass through if connected if (not FTIPFilter.FOutput.IsConnected) then begin result := VFW_E_NOT_CONNECTED; exit; end; result := FTIPFilter.FOutput.GetConnected.EnumMediaTypes(ppEnum); end; function TBCTransInPlaceInputPin.GetAllocator( out Allocator: IMemAllocator): HRESULT; begin FLock.Lock; try if FTIPFilter.FOutput.IsConnected then begin // Store the allocator we got result := FTIPFilter.OutputPin.ConnectedIMemInputPin.GetAllocator(Allocator); if SUCCEEDED(result) then FTIPFilter.OutputPin.SetAllocator(Allocator); end else begin // Help upstream filter (eg TIP filter which is having to do a copy) // by providing a temp allocator here - we'll never use // this allocator because when our output is connected we'll // reconnect this pin result := inherited GetAllocator(Allocator); end; finally FLock.UnLock; end; end; function TBCTransInPlaceInputPin.GetAllocatorRequirements( props: PAllocatorProperties): HRESULT; begin if FTIPFilter.FOutput.IsConnected then result := FTIPFilter.OutputPin.ConnectedIMemInputPin.GetAllocatorRequirements(Props^) else result := E_NOTIMPL; end; function TBCTransInPlaceInputPin.NotifyAllocator(Allocator: IMemAllocator; ReadOnly: BOOL): HRESULT; var OutputAllocator: IMemAllocator; Props, Actual: TAllocatorProperties; begin result := S_OK; FLock.Lock; try FReadOnly := ReadOnly; // If we modify data then don't accept the allocator if it's // the same as the output pin's allocator // If our output is not connected just accept the allocator // We're never going to use this allocator because when our // output pin is connected we'll reconnect this pin if not FTIPFilter.OutputPin.IsConnected then begin result := inherited NotifyAllocator(Allocator, ReadOnly); exit; end; // If the allocator is read-only and we're modifying data // and the allocator is the same as the output pin's // then reject if (FReadOnly and FTIPFilter.FModifiesData) then begin OutputAllocator := FTIPFilter.OutputPin.PeekAllocator; // Make sure we have an output allocator if (OutputAllocator = nil) then begin result := FTIPFilter.OutputPin.ConnectedIMemInputPin.GetAllocator(OutputAllocator); if FAILED(result) then result := CreateMemoryAllocator(OutputAllocator); if SUCCEEDED(result) then begin FTIPFilter.OutputPin.SetAllocator(OutputAllocator); OutputAllocator := nil; end; end; if (Allocator = OutputAllocator) then begin result := E_FAIL; exit; end else if SUCCEEDED(result) then begin // Must copy so set the allocator properties on the output result := Allocator.GetProperties(Props); if SUCCEEDED(result) then result := OutputAllocator.SetProperties(Props, Actual); if SUCCEEDED(result) then begin if ((Props.cBuffers > Actual.cBuffers) or (Props.cbBuffer > Actual.cbBuffer) or (Props.cbAlign > Actual.cbAlign)) then result := E_FAIL; end; // Set the allocator on the output pin if SUCCEEDED(result) then result := FTIPFilter.OutputPin.ConnectedIMemInputPin.NotifyAllocator(OutputAllocator, FALSE); end; end else begin result := FTIPFilter.OutputPin.ConnectedIMemInputPin.NotifyAllocator(Allocator, ReadOnly); if SUCCEEDED(result) then FTIPFilter.OutputPin.SetAllocator(Allocator); end; if SUCCEEDED(result) then begin // It's possible that the old and the new are the same thing. // AddRef before release ensures that we don't unload it. Allocator._AddRef; if (FAllocator <> nil) then FAllocator := nil; Pointer(FAllocator) := Pointer(Allocator); // We have an allocator for the input pin end; finally FLock.UnLock; end; end; function TBCTransInPlaceInputPin.PeekAllocator: IMemAllocator; begin result := FAllocator; end; constructor TBCTransInPlaceInputPin.Create(ObjectName: string; Filter: TBCTransInPlaceFilter; out hr: HRESULT; Name: WideString); begin inherited Create(ObjectName, Filter, hr, Name); FReadOnly := FALSE; FTIPFilter := Filter; {$IFDEF DEBUG} DbgLog(self, 'TBCTransInPlaceInputPin.Create'); {$ENDIF} end; { TBCTransInPlaceOutputPin } function TBCTransInPlaceOutputPin.CheckMediaType( pmt: PAMMediaType): HRESULT; begin // Don't accept any output pin type changes if we're copying // between allocators - it's too late to change the input // allocator size. if (FTIPFilter.UsingDifferentAllocators and (not FFilter.IsStopped)) then begin if TBCMediaType(pmt).Equal(@Fmt) then result := S_OK else result := VFW_E_TYPE_NOT_ACCEPTED; exit; end; // Assumes the type does not change. That's why we're calling // CheckINPUTType here on the OUTPUT pin. result := FTIPFilter.CheckInputType(pmt); if (result <> S_OK) then exit; if (FTIPFilter.FInput.IsConnected) then result := FTIPFilter.FInput.GetConnected.QueryAccept(pmt^) else result := S_OK; end; function TBCTransInPlaceOutputPin.ConnectedIMemInputPin: IMemInputPin; begin pointer(result) := pointer(FInputPin); end; constructor TBCTransInPlaceOutputPin.Create(ObjectName: string; Filter: TBCTransInPlaceFilter; out hr: HRESULT; Name: WideString); begin inherited Create(ObjectName, Filter, hr, Name); FTIPFilter := Filter; {$IFDEF DEBUG} DbgLog(self, 'TBCTransInPlaceOutputPin.Create'); {$ENDIF} end; function TBCTransInPlaceOutputPin.EnumMediaTypes( out ppEnum: IEnumMediaTypes): HRESULT; begin // Can only pass through if connected. if not FTIPFilter.FInput.IsConnected then result := VFW_E_NOT_CONNECTED else result := FTIPFilter.FInput.GetConnected.EnumMediaTypes(ppEnum); end; function TBCTransInPlaceOutputPin.PeekAllocator: IMemAllocator; begin result := FAllocator; end; procedure TBCTransInPlaceOutputPin.SetAllocator(Allocator: IMemAllocator); begin Allocator._AddRef; if(FAllocator <> nil) then FAllocator._Release; 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_=0) and (Id_=0) and (Id_ 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 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(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.