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