
{*******************************************************}
{                                                       }
{       Библиотека классов                              }
{                                                       }
{       Copyright (c) 1996-2004 ЦСИ Интегро             }
{                                                       }
{*******************************************************}

unit AClasses;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
	Windows, ActiveX, Variants, Classes, SysUtils, Controls, RefObjects,
	Contnrs;

type
	{Для создания прогрессов.[brd]}
	TCallbackPurpose = (cbpBegin, cbpProcess, cbpEnd);

	TSimpleCallback = class
	public
		function Callback(aPurpose: TCallbackPurpose; aValue: Longint): Boolean; virtual; abstract;
	end;

	{Враппер над критической секцией.[brd]}
	TCriticalSection = class
	private
		FCriticalSection: TRTLCriticalSection;
	public
		constructor Create;
		destructor Destroy; override;

		procedure Enter;
		procedure Leave;
	end;

	{Для получения информации по версии файла.[brd]}
	TFileVersionInfo = class
	private
		FFileName: string;
		FLangCharset: string;
		FAutoLangCharset: string;
		FUnicode: Boolean;
		FVerInfo: Pointer;

		function GetAutoLangCharset: string;
	public
		constructor Create(const aFileName: string);
		destructor Destroy; override;

		function FixedInfo: PVSFixedFileInfo;
		function StringInfo(const aKey: string): string;
		function CompanyName: string;
		function FileDescription: string;
		function FileVersion: string;
		function InternalName: string;
		function LegalCopyright: string;
		function OriginalFilename: string;
		function ProductName: string;
		function ProductVersion: string;
		function Comments: string;
		function LegalTrademarks: string;
		function PrivateBuild: string;
		function SpecialBuild: string;

		property FileName: string read FFileName;
		property LangCharset: string read FLangCharset write FLangCharset;
		property AutoLangCharset: string read GetAutoLangCharset;
		property Unicode: Boolean read FUnicode;
		property VerInfo: Pointer read FVerInfo;
	end;

	{Для кешированного выделения блоков памяти.[brd]}
	TMemCache = class
	private
		FCount: Integer;
		FBufs: Pointer;
	public
		constructor Create(aCount: Integer);
		destructor Destroy; override;

		function MemAlloc(aSize: Integer): Pointer;
		procedure MemFree(aPtr: Pointer);

		property Count: Integer read FCount;
	end;

	TAggregatedInterface = class(TObject, IUnknown)
	private
		FRefCount: Integer;
		FUnkOuter: Pointer;

		function GetUnkOuter: IUnknown;
	protected
		procedure DoFree(var aRefCount: Integer); virtual;
	public
		constructor Create(const anUnkOuter: IUnknown);

		function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
		function _AddRef: Integer; stdcall;
		function _Release: Integer; stdcall;

		property RefCount: Integer read FRefCount;
		property UnkOuter: IUnknown read GetUnkOuter;
	end;

	TInterface = class(TAggregatedInterface)
	public
		constructor Create;
	end;

	TShamInterface = class(TInterface)
	protected
		procedure DoFree(var aRefCount: Integer); override;
	end;

	TControlledInterface = class(TInterface)
	private
		FController: TObject;
	protected
		procedure DoFree(var aRefCount: Integer); override;
	public
		constructor Create(aController: TObject);

		property Controller: TObject read FController;
	end;

	{Для работы с буфером обмена.[brd]}
	IEnumFormatEtcImp = class(TInterface, IEnumFormatEtc)
	private
		FFormats: PFormatEtc;
		FCount, FCur: Longint;
	public
		constructor Create(aFormats: PFormatEtc; aCount: Longint);
		destructor Destroy; override;

		{From IEnumFormatEtc}
		function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
		function Skip(celt: Longint): HResult; stdcall;
		function Reset: HResult; stdcall;
		function Clone(out enum: IEnumFormatEtc): HResult; stdcall;
	end;

	{Для работы с буфером обмена.[brd]}
	IDataObjectImp = class(TInterface, IDataObject)
	private
		FFormatsGet, FFormatsSet: PFormatEtc;
		FCountGet, FCountSet: Longint;
		FAdviseHolder: IDataAdviseHolder;
	public
		constructor Create(aFormatsGet: PFormatEtc; aCountGet: Longint;
				aFormatsSet: PFormatEtc; aCountSet: Longint);
		destructor Destroy; override;

		{From IDataObject}
		function GetData(const aFormat: TFormatEtc; out aMedium: TStgMedium): HResult; stdcall;
		function GetDataHere(const aFormat: TFormatEtc; out aMedium: TStgMedium): HResult; stdcall;
		function QueryGetData(const aFormat: TFormatEtc): HResult; stdcall;
		function GetCanonicalFormatEtc(const aFormat: TFormatEtc;
				out aFormatOut: TFormatEtc): HResult; stdcall;
		function SetData(const aFormat: TFormatEtc; var aMedium: TStgMedium;
				aRelease: BOOL): HResult; stdcall;
		function EnumFormatEtc(aDirection: Longint; out anEnum: IEnumFormatEtc): HResult; stdcall;
		function DAdvise(const aFormat: TFormatEtc; advf: Longint; const aSink: IAdviseSink;
				out aConnection: Longint): HResult; stdcall;
		function DUnadvise(aConnection: Longint): HResult; stdcall;
		function EnumDAdvise(out anEnum: IEnumStatData): HResult; stdcall;

		{Следующие методы можно переопределять}
		procedure OnGetData(const aFormat: TFormatEtc; out aMedium: TStgMedium; var aResult: HResult); virtual;
		procedure OnGetDataHere(const aFormat: TFormatEtc; out aMedium: TStgMedium; var aResult: HResult); virtual;

		{Вызывать при изменении данных}
		function SendOnDataChange(advf: Longint): HResult;
	end;

	{	Для выполнения частых операций над группой контролов [Власов]}
	TControlGroup = class(TList)
		constructor CreateFromControls(const aControls: array of TComponent);
		procedure AddControls(const aControls: array of TComponent);
		procedure AddGroup(aSrc: TControlGroup);

		procedure SetEnabled(aValue: Boolean);
		procedure SetVisible(aValue: Boolean);

		procedure Disable;
		procedure Enable;
		
		procedure Hide;
		procedure Show;

		property Enabled: Boolean write SetEnabled;
		property Visible: Boolean write SetVisible;
	end;

	TWordsFilter = class
	private
		FFilterWords: TStringList;
		FFilter: String;

		procedure SetFilter(const aValue: String);
		function GetFilterWord(Index: Integer): String;
		function GetWordCount: Integer;
	public
		constructor Create(const aFilter: string = '');
		destructor Destroy; override;

		function Check(const s: String): Boolean;

		property Filter: String read FFilter write SetFilter;
		property FilterWords[Index: Integer]: String read GetFilterWord;
		property WordCount: Integer read GetWordCount;
	end;


	EHResultError = class(Exception);

	procedure DecodeTargetDevice(aTD: PDVTargetDevice; var aDriver, aDevice: PAnsiChar;
			var aDevMode: PDevMode);
	function CreateTargetDevice(aDevice, aDriver, aPort: PAnsiChar;
			aDevMode: PDevMode): PDVTargetDevice;
	function CreateDCFromTargetDevice(aTD: PDVTargetDevice): HDC;
	function CreateICFromTargetDevice(aTD: PDVTargetDevice): HDC;
	function AllocTargetDevice(aTD: PDVTargetDevice): PDVTargetDevice;
	procedure FreeTargetDevice(var aTD: PDVTargetDevice);
	procedure CopyFormatEtc(const aSrc: TFormatEtc; var aDst: TFormatEtc);
	procedure ClearFormatEtc(var aSrc: TFormatEtc);
	function AllocFormatEtcArray(aSrc: PFormatEtc; aCount: Longint): PFormatEtc;
	procedure FreeFormatEtcArray(var aSrc: PFormatEtc; aCount: Longint);
	procedure SetFormatEtc(var fe: TFormatEtc; cf: TClipFormat; asp: Longint;
			td: PDVTargetDevice; med: Longint; li: Longint);
	procedure SetDefFormatEtc(var fe: TFormatEtc; cf: TClipFormat; med: Longint);
	function IsEqualTargetDevice(aLeft, aRight: PDVTargetDevice): Boolean;
	{ Returns 0 for exact match, 1 for no match, -1 for partial match (which is
		defined to mean the left is a subset of the right: fewer aspects, null target
		device, fewer medium). }
	function CompareFormatEtc(const aLeft, aRight: TFormatEtc; aConsiderTD: Boolean): Integer;

	function RaiseDispException(ACode: HResult; const AMsg, ASrc: string;
			const iid: TIID; AnExceptInfo: PExcepInfo): HResult;
	function GetDispResultText(aResult: HResult): string;
	function CheckDispResult(aResult: HResult): HResult;
	function ShowDispResult(aResult: HResult): HResult;

	function FileVersionInfo: TFileVersionInfo;

type
	{ [Власов] }
	TReadMemoryStream = class(TCustomMemoryStream)
		function Write(const Buffer; Count: Longint): Longint; override;

		constructor Create(aMemory: Pointer; aSize: Longint);
	end;

{	Два класса для организации оповещений [Власов] }
type
	TNotifyClientType = (nctModel, nctView);
	TNotifyClient = class
	private
		FOwners: TList;
		FClientType: TNotifyClientType;
	public
		constructor Create(aNotifyClientType: TNotifyClientType = nctModel);
		destructor Destroy; override;
		procedure RemoveFromLists;

		property ClientType: TNotifyClientType read FClientType;
	end;

	TNotifyList = class
	private
		FList,
		FAdding: TList;

		FEnumCount: Integer;
		procedure AttachClient(aClient: TNotifyClient);
		procedure DetachClient(aClient: TNotifyClient);
		procedure AddClient(aList: TList; aClient: TNotifyClient);
	public
		constructor Create;
		destructor Destroy; override;

		function BeginEnum: TList;
		procedure EndEnum;

		procedure Add(aClient: TNotifyClient);
		procedure Remove(aClient: TNotifyClient);
		procedure RemoveAll;
	end;

	TInsertionPos = (insNone, insChild, insBefore, insAfter);
	TContentOperation = (coItemCreated, coItemMoved, coItemDeleted, coItemChanged);
	TContentNotification = procedure(anOperation: TContentOperation;
		aSrc, aDst: TObject; anInsertion: TInsertionPos) of object;
	TContentNotifyClient = class(TNotifyClient)
		OnNotification: TContentNotification;
		procedure Notification(anOperation: TContentOperation;
			aSrc, aDst: TObject; anInsertion: TInsertionPos); virtual;
		constructor Create(aNotifyClientType: TNotifyClientType;
			anOnNotification: TContentNotification);
	end;

	TContentNotifyList = class(TNotifyList)
		procedure Add(aClient: TContentNotifyClient);
		procedure Publish(anOperation: TContentOperation;
			aSrc, aDst: TObject; anInsertion: TInsertionPos);
	end;
  
const
	InsertionPosNames: array [TInsertionPos] of string = ('None',
    'Child', 'Before', 'After');
	ContentOperationNames: array [TContentOperation] of String = ('Created',
    'Moved', 'Deleted', 'Changed');

type
	{	Сканер строки }
	TCondProc = function(c: Char): Boolean;
	TStrScan = object
		S: String;
		Pos: Integer;
		Token: String;

		procedure Init(const aStr: String);
		procedure Reset;
		function Eoln: Boolean;
		procedure Skip(aLen: Integer);
		procedure SkipBlanks;
		function FetchWhile(aCond: TCondProc): Boolean;
		function FetchNumbers: Boolean;
		function FetchLetters: Boolean;
		function FetchFloat: Boolean;
		function FetchQuoted(c1, c2: Char): Boolean;
		function FetchTo(c: Char): Boolean;
		function FetchLen(aLen: Integer): Boolean;
		procedure FetchRest;
	end;


	//	Список именованых объектов [Власов]
	//	
	TNameSpace = class(TStringList)
		function ObjectFromName(const aName: String; aClass: TClass): Pointer;
		function FindObject(const aName: String; aClass: TClass): Pointer;
		function RemoveName(const aName: String): Pointer;
		procedure AddFrom(aSrc: TNameSpace);
	end;

	{Поток во временном файле.[brd]}
	TTempFileStream = class(THandleStream)
	private
		FFileName: String;
	public
		constructor Create(const aFileName: string; aShareMode: DWORD = 0);
		destructor Destroy; override;
		property FileName: string read FFileName;
	end;

	{Распределитель пространства в потоке. [brd]}
	TInsideStreamAllocator = class
	private
		FStream: TStream;
		FEmptyBlocks: TObjectList;
	public
		constructor Create(aStream: TStream);
		destructor Destroy; override;

		procedure Clear;
		function AllocateMem(aSize: Integer;
			anUpdateFileSize: Boolean = True): Integer;
		procedure FreeMem(anOffset, aSize: Integer);

		property Stream: TStream read FStream;
	end;

	{Кэш значений.[brd]}
	TVariantCacheElem = class
	private
		Prev: TVariantCacheElem;
		Next: TVariantCacheElem;
	public
		Value: Variant;

		constructor Create(const aValue: Variant);
	end;

	TVariantCache = class
	private
		FMaxCount: Integer;
		FHeader: TVariantCacheElem; //Двунаправленный список
		FKeys: TStringList;

		function GetCount: Integer;
		function GetKey(Index: Integer): String;
	public
		constructor Create(aMaxCount: Integer);
		destructor Destroy; override;

		procedure Clear;
		function Add(const aKey: String; const aValue: Variant): TVariantCacheElem;
		procedure Delete(anElem: TVariantCacheElem); overload;
		procedure Delete(const aKey: String); overload;

		function Find(const aKey: String): TVariantCacheElem;
		procedure MakeLRU(anElem: TVariantCacheElem);

		property MaxCount: Integer read FMaxCount;

		property Count: Integer read GetCount;
		property Keys[Index: Integer]: String read GetKey;
	end;


	//	Данный компонент рпедназначен для оповещения об уничтожении других компонентов
	//	[М. Власов]
	TDestroyNotifier = class(TComponent)
	private
		FOnDestroy: TNotifyEvent;
	protected
		procedure Notification(aComponent: TComponent; anOperation: TOperation); override;
	public
		constructor CreateFor(anOnDestroy: TNotifyEvent; const aComponents: array of TComponent);
		procedure Add(aComponent: TComponent);

		property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
	end;

	PPointerSetHashItem = ^TPointerSetHashItem;
	TPointerSetHashItem = record
		ItemKind: (ikEmpty, ikItem, ikList);
		ItemOrList: TList;
	end;

	TPointerSet = class
	private
		FHashSize: Longword;
		FHash: array of TPointerSetHashItem;
		function GetHashIndex(anItem: Pointer): Longword;
	public
		constructor Create(aHashSize: Longword = 4095);
		destructor Destroy; override;

		procedure Clear;
		function Include(anItem: Pointer): Boolean;
		function Exclude(anItem: Pointer): Boolean;
		function Contains(anItem: Pointer): Boolean;
		procedure GetItems(anItems: TList);
	end;

	TRefObjectSet = class
	private
		FHashSize: Longword;
		FHash: array of TObject;
		function GetHashIndex(anItem: TObject): Longword;
	public
		constructor Create(aHashSize: Longword = 4095);
		destructor Destroy; override;

		procedure Clear;
		function Include(anItem: TRefObject): Boolean;
		function Exclude(anItem: TRefObject): Boolean;
		function Contains(anItem: TRefObject): Boolean;
		procedure GetItems(anItems: TRefObjectList);
	end;

	procedure SpecialMove(aSrc, aDst: Pointer; aSize: Longint);

implementation

uses
	Math, TypInfo, InSysUtils, InControlUtils;

{ TCriticalSection }

constructor TCriticalSection.Create;
begin
	inherited Create;
	InitializeCriticalSection(FCriticalSection);
end;

destructor TCriticalSection.Destroy;
begin
	DeleteCriticalSection(FCriticalSection);
	inherited Destroy;
end;

procedure TCriticalSection.Enter;
begin
	EnterCriticalSection(FCriticalSection);
end;

procedure TCriticalSection.Leave;
begin
	LeaveCriticalSection(FCriticalSection);
end;

{ TFileVersionInfo }

constructor TFileVersionInfo.Create(const aFileName: string);
var
	aSize: Integer;
	aDummy: DWORD;
begin
	inherited Create;
	FFileName := aFileName;

	aSize := GetFileVersionInfoSize(PChar(aFileName), aDummy);
	if aSize = 0 then
		raise Exception.Create('Ошибка при получении версии файла '+aFileName);
	FVerInfo := AllocMem(aSize);
	if not GetFileVersionInfo(PChar(aFileName), 0, aSize, FVerInfo) then
		raise Exception.Create('Ошибка при получении версии файла '+aFileName);
end;

destructor TFileVersionInfo.Destroy;
begin
	if Assigned(FVerInfo) then
		FreeMem(FVerInfo);
	inherited Destroy;
end;

function TFileVersionInfo.GetAutoLangCharset: string;
var
	p: Pointer;
	aLen: UINT;
	aPChar: PAnsiChar;
begin
	if FAutoLangCharset = '' then begin
		if not VerQueryValue(FVerInfo, '\VarFileInfo\Translation', p, aLen) then
			FAutoLangCharset := '041904e3' //!!! Windows,Russian
		else begin
			aPChar := p;
			FAutoLangCharset := LowerCase(Format('%.2x%.2x%.2x%.2x', [Integer((aPChar+1)^),
					Integer(aPChar^), Integer((aPChar+3)^), Integer((aPChar+2)^)]));
		end;
	end;
	Result := FAutoLangCharset;
end;

function TFileVersionInfo.FixedInfo: PVSFixedFileInfo;
var
	p: Pointer;
	aLen: UINT;
begin
	if not VerQueryValue(FVerInfo, '\', p, aLen) then
		raise Exception.Create('Ошибка при получении информации (FixedInfo) о версии файла '+
				FileName);
	Result := p;
end;

function TFileVersionInfo.StringInfo(const aKey: string): string;
var
	aLangCharset, s: string;
	p: Pointer;
	aLen: UINT;
begin
	aLangCharset := LangCharset;
	if aLangCharset = '' then
		aLangCharset := AutoLangCharset;
	s := '\StringFileInfo\'+aLangCharset+'\'+aKey;

	if not VerQueryValue(FVerInfo, PChar(s), p, aLen) then
		raise Exception.Create('Ошибка при получении информации ('+s+') о версии файла '+
				FileName);

	if Unicode then
		Result := PWideChar(p)
	else
		Result := PAnsiChar(p);
end;

function TFileVersionInfo.CompanyName: string;
begin
	Result := StringInfo('CompanyName');
end;

function TFileVersionInfo.FileDescription: string;
begin
  Result := StringInfo('FileDescription');
end;

function TFileVersionInfo.FileVersion: string;
begin
	Result := StringInfo('FileVersion');
end;

function TFileVersionInfo.InternalName: string;
begin
	Result := StringInfo('InternalName');
end;

function TFileVersionInfo.LegalCopyright: string;
begin
	Result := StringInfo('LegalCopyright');
end;

function TFileVersionInfo.OriginalFilename: string;
begin
	Result := StringInfo('OriginalFilename');
end;

function TFileVersionInfo.ProductName: string;
begin
  Result := StringInfo('ProductName');
end;

function TFileVersionInfo.ProductVersion: string;
begin
  Result := StringInfo('ProductVersion');
end;

function TFileVersionInfo.Comments: string;
begin
	Result := StringInfo('Comments');
end;

function TFileVersionInfo.LegalTrademarks: string;
begin
	Result := StringInfo('LegalTrademarks');
end;

function TFileVersionInfo.PrivateBuild: string;
begin
	Result := StringInfo('PrivateBuild');
end;

function TFileVersionInfo.SpecialBuild: string;
begin
	Result := StringInfo('SpecialBuild');
end;

{ TMemCache }

type
	PMemBuf = ^TMemBuf;
	TMemBuf = record
		Busy: Boolean;
		Size: Integer;
		Ptr: Pointer;
	end;

constructor TMemCache.Create(aCount: Integer);
begin
	inherited Create;
	FCount := aCount;
	FBufs := AllocMem(aCount*sizeof(TMemBuf));
end;

destructor TMemCache.Destroy;
var
	aBuf: PMemBuf;
	i: Integer;
begin
	if Assigned(FBufs) then begin
		aBuf := FBufs;
		for i := 0 to Count-1 do begin
			ReallocMem(aBuf.Ptr, 0);
			Inc(aBuf);
		end;
		FreeMem(FBufs);
	end;
	inherited Destroy;
end;

function TMemCache.MemAlloc(aSize: Integer): Pointer;
var
	aBuf, aFoundBuf: PMemBuf;
	i: Integer;
begin
	aFoundBuf := nil;
	aBuf := FBufs;
	for i := 0 to Count-1 do begin
		if not aBuf.Busy then begin
			aFoundBuf := aBuf;
			break;
		end;
		Inc(aBuf);
	end;

	if Assigned(aFoundBuf) then begin
		if aFoundBuf.Size < aSize then begin
			ReallocMem(aFoundBuf.Ptr, 0);
			aFoundBuf.Size := 0;

			ReallocMem(aFoundBuf.Ptr, aSize);
			aFoundBuf.Size := aSize;
		end;
		Result := aFoundBuf.Ptr;
		aFoundBuf.Busy := True;
	end
	else
		GetMem(Result, aSize);
end;

procedure TMemCache.MemFree(aPtr: Pointer);
var
	aBuf: PMemBuf;
	i: Integer;
begin
	aBuf := FBufs;
	for i := 0 to Count-1 do begin
		if aBuf.Busy and (aBuf.Ptr = aPtr) then begin
			aBuf.Busy := False;
			exit;
		end;
		Inc(aBuf);
	end;
	FreeMem(aPtr);
end;

{ TAggregatedInterface }

constructor TAggregatedInterface.Create(const anUnkOuter: IUnknown);
begin
	inherited Create;
	FUnkOuter := Pointer(anUnkOuter);
end;

function TAggregatedInterface.GetUnkOuter: IUnknown;
begin
	Result := IUnknown(FUnkOuter);
end;

function TAggregatedInterface.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
	if FUnkOuter <> nil then
		Result := IUnknown(FUnkOuter).QueryInterface(IID, Obj)
	else begin
		if GetInterface(IID, Obj) then
			Result := S_OK
		else
			Result := E_NOINTERFACE;
	end;
end;

function TAggregatedInterface._AddRef: Integer;
begin
	if FUnkOuter <> nil then
		Result := IUnknown(FUnkOuter)._AddRef
	else begin
		Inc(FRefCount);
		Result := FRefCount;
	end;
end;

function TAggregatedInterface._Release: Integer;
begin
	if FUnkOuter <> nil then
		Result := IUnknown(FUnkOuter)._Release
	else begin
		Dec(FRefCount);
		Result := FRefCount;
		if FRefCount < 1 then
			DoFree(FRefCount);
	end;
end;

procedure TAggregatedInterface.DoFree(var aRefCount: Integer);
begin
	Destroy;
end;

{ TInterface }

constructor TInterface.Create;
begin
	inherited Create(nil);
end;

{ TShamInterface }

procedure TShamInterface.DoFree(var aRefCount: Integer);
begin
//	aRefCount := 1;
end;

{ TControlledInterface }

constructor TControlledInterface.Create(aController: TObject);
begin
	inherited Create;
	FController := aController;
end;

procedure TControlledInterface.DoFree(var aRefCount: Integer);
begin
	if Assigned(FController) then
		FController.Free
	else
		inherited DoFree(aRefCount);
end;

{ IEnumFormatEtcImp }

constructor IEnumFormatEtcImp.Create(aFormats: PFormatEtc; aCount: Longint);
begin
	inherited Create;
	FCount := aCount;
	FFormats := AllocFormatEtcArray(aFormats, FCount);
end;

destructor IEnumFormatEtcImp.Destroy;
begin
	FreeFormatEtcArray(FFormats, FCount);
	inherited Destroy;
end;

function IEnumFormatEtcImp.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
type
	PFormatEtcArray = ^TFormatEtcArray;
	TFormatEtcArray = array [0..1024] of TFormatEtc;
var
	acelt: Longint;
begin
	if FCur+celt > FCount then
		acelt := FCount-FCur
	else
		acelt := celt;
	Move(PFormatEtcArray(FFormats)^[FCur], elt, acelt*sizeof(TFormatEtc));
	Inc(FCur, acelt);
	if pceltFetched <> nil then
		pceltFetched^ := acelt;
	if acelt <> celt then
		Result := S_FALSE
	else
		Result := S_OK;
end;

function IEnumFormatEtcImp.Skip(celt: Longint): HResult;
begin
	Inc(FCur, celt);
	if FCur > FCount then begin
		FCur := FCount;
		Result := S_FALSE;
	end
	else
		Result := S_OK;
end;

function IEnumFormatEtcImp.Reset: HResult;
begin
	FCur := 0;
	Result := S_OK;
end;

function IEnumFormatEtcImp.Clone(out enum: IEnumFormatEtc): HResult;
var
	anEnum: IEnumFormatEtcImp;
begin
	try
		anEnum := IEnumFormatEtcImp.Create(FFormats, FCount);
		anEnum.FCur := FCur;
		enum := anEnum;
		Result := S_OK;
	except
		enum := nil;
		Result := E_OUTOFMEMORY;
	end;
end;

{ IDataObjectImp }

constructor IDataObjectImp.Create(aFormatsGet: PFormatEtc; aCountGet: Longint;
		aFormatsSet: PFormatEtc; aCountSet: Longint);
begin
	inherited Create;
	FCountGet := aCountGet;
	FFormatsGet := AllocFormatEtcArray(aFormatsGet, FCountGet);
	FCountSet := aCountSet;
	FFormatsSet := AllocFormatEtcArray(aFormatsSet, FCountSet);
end;

destructor IDataObjectImp.Destroy;
begin
	FreeFormatEtcArray(FFormatsGet, FCountGet);
	FreeFormatEtcArray(FFormatsSet, FCountSet);
	inherited Destroy;
end;

function IDataObjectImp.GetData(const aFormat: TFormatEtc; out aMedium: TStgMedium): HResult;
begin
	Result := QueryGetData(aFormat);
	if Result <> S_OK then begin
		if Succeeded(Result) then
			Result := DV_E_FORMATETC;
		exit;
	end;

	try
		OnGetData(aFormat, aMedium, Result);
	except
		Result := E_UNEXPECTED;
	end;
end;

function IDataObjectImp.GetDataHere(const aFormat: TFormatEtc; out aMedium: TStgMedium): HResult;
begin
	Result := QueryGetData(aFormat);
	if Result <> S_OK then begin
		if Succeeded(Result) then
			Result := DV_E_FORMATETC;
		exit;
	end;

	try
		OnGetDataHere(aFormat, aMedium, Result);
	except
		Result := E_UNEXPECTED;
	end;
end;

function IDataObjectImp.QueryGetData(const aFormat: TFormatEtc): HResult;
var
	aFe: PFormatEtc;
	i: Integer;
begin
	Result := S_FALSE;
	aFe := FFormatsGet;
	for i := 0 to FCountGet-1 do begin
		if CompareFormatEtc(aFe^, aFormat, False) <= 0 then begin
			Result := S_OK;
			exit;
		end;
		Inc(aFe);
	end;
end;

function IDataObjectImp.GetCanonicalFormatEtc(const aFormat: TFormatEtc;
		out aFormatOut: TFormatEtc): HResult;
var
	aCmpFormat: TFormatEtc;
begin
	aFormatOut.ptd := nil; //Выходной параметр обнуляем
	aCmpFormat := aFormat;
	aCmpFormat.tymed := -1; //Чтобы medium не оказывал влияния - устанавливаем все медиумы
	Result := QueryGetData(aCmpFormat);
	if Result <> S_OK then begin
		Result := DV_E_FORMATETC;
		exit;
	end;

	aFormatOut := aFormat;
	if aFormat.ptd = nil then
		Result := DATA_S_SAMEFORMATETC
	else
		aFormatOut.ptd := nil;
end;

function IDataObjectImp.SetData(const aFormat: TFormatEtc; var aMedium: TStgMedium;
		aRelease: BOOL): HResult;
begin
	Result := E_NOTIMPL;
end;

function IDataObjectImp.EnumFormatEtc(aDirection: Longint; out anEnum: IEnumFormatEtc): HResult;
begin
	try
		if aDirection = DATADIR_GET then
			anEnum := IEnumFormatEtcImp.Create(FFormatsGet, FCountGet)
		else if aDirection = DATADIR_SET then
			anEnum := IEnumFormatEtcImp.Create(FFormatsSet, FCountSet)
		else
			anEnum := nil;

		if not Assigned(anEnum) then
			Result := E_INVALIDARG
		else
			Result := S_OK;
	except
		anEnum := nil;
		Result := E_UNEXPECTED;
	end;
end;

function IDataObjectImp.DAdvise(const aFormat: TFormatEtc; advf: Longint; const aSink: IAdviseSink;
		out aConnection: Longint): HResult;
begin
	if not Assigned(FAdviseHolder) then begin
		Result := CreateDataAdviseHolder(FAdviseHolder);
		if Failed(Result) then begin
			aConnection := 0;
			Result := E_OUTOFMEMORY;
			exit;
		end;
	end;
	Result := FAdviseHolder.Advise(Self, aFormat, advf, aSink, aConnection);
end;

function IDataObjectImp.DUnadvise(aConnection: Longint): HResult;
begin
	if not Assigned(FAdviseHolder) then
		Result := E_FAIL
	else
		Result := FAdviseHolder.Unadvise(aConnection);
end;

function IDataObjectImp.EnumDAdvise(out anEnum: IEnumStatData): HResult;
begin
	anEnum := nil;
	if not Assigned(FAdviseHolder) then
		Result := E_FAIL
	else
		Result := FAdviseHolder.EnumAdvise(anEnum);
end;

procedure IDataObjectImp.OnGetData(const aFormat: TFormatEtc; out aMedium: TStgMedium; var aResult: HResult);
begin
	aResult := E_NOTIMPL;
end;

procedure IDataObjectImp.OnGetDataHere(const aFormat: TFormatEtc; out aMedium: TStgMedium; var aResult: HResult);
begin
	aResult := E_NOTIMPL;
end;

function IDataObjectImp.SendOnDataChange(advf: Longint): HResult;
begin
	if not Assigned(FAdviseHolder) then
		Result := S_OK
	else
		Result := FAdviseHolder.SendOnDataChange(Self, 0, advf);
end;

procedure DecodeTargetDevice(aTD: PDVTargetDevice; var aDriver, aDevice: PAnsiChar;
		var aDevMode: PDevMode);
var
	aNamesBase: PAnsiChar;

	function DoOffset(anOffset: Word): PAnsiChar;
	begin
		if anOffset = 0 then
			Result := nil
		else
			Result := aNamesBase+anOffset;
	end;

begin
	aNamesBase := PAnsiChar(aTD);
	aDriver := DoOffset(aTD.tdDriverNameOffset);
	aDevice := DoOffset(aTD.tdDeviceNameOffset);
	aDevMode := PDevMode(DoOffset(aTD.tdExtDevmodeOffset));
end;

function CreateTargetDevice(aDevice, aDriver, aPort: PAnsiChar;
		aDevMode: PDevMode): PDVTargetDevice;
var
	aTargetDevice: PDVTargetDevice;

	function Append(var aP: Pointer; aData: Pointer; aDataSize: Word): Word;
	begin
		Result := longint(aP)-longint(aTargetDevice);
		Move(aData^, aP^, aDataSize);
		Inc(PByte(aP), aDataSize);
	end;

var
	aSize: longint;
	aP: Pointer;
begin
	aSize := SizeOf(TDVTargetDevice)+StrLen(ADriver)+1+StrLen(ADevice)+1+
			StrLen(APort)+1+SizeOf(TDevMode);
	aTargetDevice := AllocMem(aSize);
	aP := aTargetDevice;
	Inc(PByte(aP), SizeOf(TDVTargetDevice));
	with aTargetDevice^ do begin
		tdSize := aSize;
		tdDriverNameOffset := Append(aP, ADriver, StrLen(ADriver)+1);
		tdDeviceNameOffset := Append(aP, ADevice, StrLen(ADevice)+1);
		tdPortNameOffset   := Append(aP, APort, StrLen(APort)+1);
		tdExtDevmodeOffset := Append(aP, ADevMode, SizeOf(TDevMode));
	end;
	Result := aTargetDevice;
end;

function CreateDCFromTargetDevice(aTD: PDVTargetDevice): HDC;
var
	aDriver, aDevice: PAnsiChar;
	aDevMode: PDevMode;
begin
	if aTD = nil then
		Result := CreateDC('DISPLAY', nil, nil, nil)
	else begin
		DecodeTargetDevice(aTD, aDriver, aDevice, aDevMode);
		Result := CreateDC(aDriver, aDevice, nil, aDevMode);
	end;

	if Result = 0 then
		raise Exception.Create('Ошибка при создании контекста устройства (DC) для TargetDevice');
end;

function CreateICFromTargetDevice(aTD: PDVTargetDevice): HDC;
var
	aDriver, aDevice: PAnsiChar;
	aDevMode: PDevMode;
begin
	if aTD = nil then
		Result := CreateIC('DISPLAY', nil, nil, nil)
	else begin
		DecodeTargetDevice(aTD, aDriver, aDevice, aDevMode);
		Result := CreateIC(aDriver, aDevice, nil, aDevMode);
	end;

	if Result = 0 then
		raise Exception.Create('Ошибка при создании контекста устройства (IC) для TargetDevice');
end;

function AllocTargetDevice(aTD: PDVTargetDevice): PDVTargetDevice;
begin
	if Assigned(aTD) then begin
		Result := AllocMem(aTD^.tdSize);
		Move(aTD^, Result^, aTD^.tdSize);
	end
	else
		Result := nil;
end;

procedure FreeTargetDevice(var aTD: PDVTargetDevice);
begin
	if Assigned(aTD) then
		FreeMem(aTD);
	aTD := nil;
end;

procedure CopyFormatEtc(const aSrc: TFormatEtc; var aDst: TFormatEtc);
begin
	Move(aSrc, aDst, sizeof(TFormatEtc));
	aDst.ptd := AllocTargetDevice(aSrc.ptd);
end;

procedure ClearFormatEtc(var aSrc: TFormatEtc);
begin
	FreeTargetDevice(aSrc.ptd);
end;

function AllocFormatEtcArray(aSrc: PFormatEtc; aCount: Longint): PFormatEtc;
var
	aDst: PFormatEtc;
	i: Integer;
begin
	if aCount > 0 then begin
		Result := AllocMem(aCount*sizeof(TFormatEtc));
		aDst := Result;
		for i := 0 to aCount-1 do begin
			CopyFormatEtc(aSrc^, aDst^);
			Inc(aSrc);
			Inc(aDst);
		end;
	end
	else
		Result := nil;
end;

procedure FreeFormatEtcArray(var aSrc: PFormatEtc; aCount: Longint);
var
	aDst: PFormatEtc;
	i: Integer;
begin
	if Assigned(aSrc) then begin
		aDst := aSrc;
		for i := 0 to aCount-1 do begin
			ClearFormatEtc(aDst^);
			Inc(aDst);
		end;
		FreeMem(aSrc);
		aSrc := nil;
	end;
end;

procedure SetFormatEtc(var fe: TFormatEtc; cf: TClipFormat; asp: Longint;
		td: PDVTargetDevice; med: Longint; li: Longint);
begin
	fe.cfFormat := cf;
	fe.dwAspect := asp;
	fe.ptd := td;
	fe.tymed := med;
	fe.lindex := li;
end;

procedure SetDefFormatEtc(var fe: TFormatEtc; cf: TClipFormat; med: Longint);
begin
	fe.cfFormat := cf;
	fe.dwAspect := DVASPECT_CONTENT;
	fe.ptd := nil;
	fe.tymed := med;
	fe.lindex := -1;
end;

function IsEqualTargetDevice(aLeft, aRight: PDVTargetDevice): Boolean;
begin
	if aLeft = aRight then //Same address of td; must be same (handles NULL case)
		Result := True
	else if not Assigned(aRight) or not Assigned(aLeft) then
		Result := False
	else if aLeft^.tdSize <> aRight^.tdSize then //Different sizes, not equal
		Result := False
	else
		Result := CompareMem(aLeft, aRight, aLeft^.tdSize);
end;

function CompareFormatEtc(const aLeft, aRight: TFormatEtc; aConsiderTD: Boolean): Integer;
var
	anExact: Boolean;
begin
	anExact := True;

	if (aLeft.cfFormat <> aRight.cfFormat) or (aConsiderTD and
			not IsEqualTargetDevice(aLeft.ptd, aRight.ptd)) then begin
		Result := 1;
		exit;
	end;
	
	if aLeft.dwAspect = aRight.dwAspect then
		//Same aspects; equal
	else if (aLeft.dwAspect and not aRight.dwAspect) <> 0 then begin
		//Left not subset of aspects of right; not equal
		Result := 1;
		exit;
	end
	else //Left subset of right
		anExact := False;

	if aLeft.tymed = aRight.tymed then
		//Same medium flags; equal
	else if (aLeft.tymed and not aRight.tymed) <> 0 then begin
		//Left not subset of medium flags of right; not equal
		Result := 1;
		exit;
	end
	else //Left subset of right
		anExact := False;

	if anExact then
		Result := 0
	else
		Result := -1;
end;

function RaiseDispException(ACode: HResult; const AMsg, ASrc: string;
		const iid: TIID; AnExceptInfo: PExcepInfo): HResult;
var
	aSource, aDescription: POleStr;
	crErrInfo: ICreateErrorInfo;
	errInfo: IErrorInfo;
begin
	Result := ACode;
	try
		aSource := StringToOleStr(ASrc);
		aDescription := StringToOleStr(AMsg);
		if Succeeded(CreateErrorInfo(crErrInfo)) then begin
			crErrInfo.SetGUID(iid);
			if aSource <> nil then
				crErrInfo.SetSource(aSource);
			if aDescription <> nil then
				crErrInfo.SetDescription(aDescription);
			if Succeeded(crErrInfo.QueryInterface(IErrorInfo, errInfo)) and
					Succeeded(SetErrorInfo(0, errInfo)) then
				Result := DISP_E_EXCEPTION;
		end;

		if Assigned(AnExceptInfo) then begin
			FillChar(AnExceptInfo^, sizeof(TExcepInfo), #0);
			AnExceptInfo^.scode := ACode;
			AnExceptInfo^.bstrSource := aSource;
			AnExceptInfo^.bstrDescription := aDescription;
		end
		else begin
			SysFreeString(aSource);
			SysFreeString(aDescription);
		end;
	except
	end;
end;

function GetDispResultText(aResult: HResult): string;
var
	errInfo: IErrorInfo;
	aSrc, aDesc: WideString;
begin
	Result := '';
	if (AResult = DISP_E_EXCEPTION) and (GetErrorInfo(0, errInfo) = S_OK) then begin
		if Succeeded(errInfo.GetSource(aSrc)) then
			Result := Result+aSrc;
		if Succeeded(errInfo.GetDescription(aDesc)) then
			Result := Result+': '+aDesc;
	end;
	if Result = '' then
		FmtStr(Result, 'Произошла OLE-ошибка 0x%x', [Longint(AResult)]);
end;

function CheckDispResult(aResult: HResult): HResult;
begin
	Result := AResult;
	if FAILED(AResult) then
		raise EHResultError.Create(GetDispResultText(AResult));
end;

function ShowDispResult(aResult: HResult): HResult;
begin
	Result := aResult;
	if FAILED(aResult) then
		ShowMessageBox(GetDispResultText(aResult), MB_OK or MB_ICONSTOP);
end;

var
	gVersionInfo: TFileVersionInfo = nil;

function FileVersionInfo: TFileVersionInfo;
begin
	if not Assigned(gVersionInfo) then
		gVersionInfo := TFileVersionInfo.Create(ParamStr(0));
	Result := gVersionInfo;
end;

//******************************************************************************
//	TControlGroup
//
constructor TControlGroup.CreateFromControls(const aControls: array of TComponent);
begin
	inherited Create;
	AddControls(aControls);
end;


procedure TControlGroup.AddControls(const aControls: array of TComponent);
var
	i: Integer;
begin
	for i := Low(aControls) to High(aControls) do
		Add(aControls[i])
end;

procedure TControlGroup.AddGroup(aSrc: TControlGroup);
var
	i: Integer;
begin
	for i := 0 to aSrc.Count - 1 do
		Add(aSrc[i])
end;

procedure TControlGroup.SetEnabled(aValue: Boolean);
var
	i: Integer;
	aPropInfo: PPropInfo;
	aComponent: TComponent;
begin
	for i := 0 to Count - 1 do begin
		aComponent := inherited Items[i];
		aPropInfo := GetPropInfo(aComponent.ClassInfo, 'Enabled');
		if Assigned(aPropInfo) then
			SetOrdProp(aComponent, aPropInfo, Ord(aValue));
	end;
end;

procedure TControlGroup.SetVisible(aValue: Boolean);
var
	i: Integer;
	aPropInfo: PPropInfo;
	aComponent: TComponent;
begin
	for i := 0 to Count - 1 do begin
		aComponent := inherited Items[i];
		aPropInfo := GetPropInfo(aComponent.ClassInfo, 'Visible');
		if Assigned(aPropInfo) then
			SetOrdProp(aComponent, aPropInfo, Ord(aValue));
	end;
end;

procedure TControlGroup.Disable;
begin
	SetEnabled(False);
end;

procedure TControlGroup.Enable;
begin
	SetEnabled(True);
end;

procedure TControlGroup.Hide;
begin
	SetVisible(False);
end;

procedure TControlGroup.Show;
begin
	SetVisible(True);
end;

{ [Власов] }
constructor TReadMemoryStream.Create(aMemory: Pointer; aSize: Longint);
begin
	inherited Create;
	SetPointer(aMemory, aSize);
end;

function TReadMemoryStream.Write(const Buffer; Count: Longint): Longint;
begin
	{ переписан только для того, чтобы компилятор не ругался, что создается
		объект, содержащий абстрактные методы }
	Result := 0;
end;

procedure SpecialMove(aSrc, aDst: Pointer; aSize: Longint);
begin
	Longint(aDst^) := aSize;
	Move(aSrc^, Pointer(Longint(aDst) + sizeof(Longint))^, aSize);
end;


{	TNotifyClient }

constructor TNotifyClient.Create(aNotifyClientType: TNotifyClientType);
begin
	inherited Create;
	FOwners := TList.Create;
	FClientType := aNotifyClientType;
end;

procedure TNotifyClient.RemoveFromLists;
var
	i: Integer;
	aList: TNotifyList;
begin
	for i := 0 to FOwners.Count - 1 do begin
		aList := FOwners[i];
		FOwners[i] := nil;
		aList.Remove(Self);
	end;
	FOwners.Clear;
end;

destructor TNotifyClient.Destroy;
begin
	RemoveFromLists;
	FOwners.Free;
	inherited Destroy;
end;

{	TNotifyList }

constructor TNotifyList.Create;
begin
	inherited Create;
	FList := TList.Create;
	FAdding := TList.Create;
end;

destructor TNotifyList.Destroy;
var
	i: Integer;
begin
	Assert(FEnumCount <= 0);

	for i := 0 to FAdding.Count - 1 do
		DetachClient(FAdding[i]);
	for i := 0 to FList.Count - 1 do
		DetachClient(FList[i]);

	FAdding.Free;
	FList.Free;
	inherited Destroy;
end;

procedure TNotifyList.AttachClient(aClient: TNotifyClient);
begin
	if Assigned(aClient) then
		aClient.FOwners.Add(Self);
end;

procedure TNotifyList.DetachClient(aClient: TNotifyClient);
begin
	if Assigned(aClient) then
		aClient.FOwners.Remove(Self);
end;

procedure TNotifyList.AddClient(aList: TList; aClient: TNotifyClient);

	function CompareNotifyClients(A, B: TNotifyClient): Integer;
	begin
		if A.ClientType = B.ClientType then
			Result := 0
		else if A.ClientType = nctModel then
			Result := -1
		else
			Result := 1;
	end;

var
	anItem: TNotifyClient;
	i, j: Integer;
begin
	if not Assigned(aClient) then
		Exit;

	j := -1;
	for i := aList.Count - 1 downto 0 do begin
		anItem := aList[i];
		if Assigned(anItem) and (CompareNotifyClients(anItem, aClient) <= 0) then begin
			j := i;
			break;
		end;
	end;

	aList.Insert(j + 1, aClient);
end;

function TNotifyList.BeginEnum: TList;
begin
	Result := FList;
	Inc(FEnumCount);
end;

procedure TNotifyList.EndEnum;
var
	i: Integer;
begin
	Dec(FEnumCount);
	if FEnumCount = 0 then begin
		FList.Pack;
		for i := 0 to FAdding.Count - 1 do
			AddClient(FList, FAdding[i]);
		FAdding.Clear;
	end;
end;

procedure TNotifyList.Add(aClient: TNotifyClient);
begin
	if FEnumCount = 0 then
		AddClient(FList, aClient)
	else
		FAdding.Add(aClient);
	AttachClient(aClient);
end;

procedure TNotifyList.Remove(aClient: TNotifyClient);
var
	i: Integer;
begin
	if FEnumCount = 0 then
		FList.Remove(aClient)
	else begin
		i := FList.IndexOf(aClient);
		if i <> -1 then
			FList[i] := nil;
		FAdding.Remove(aClient);
	end;
	DetachClient(aClient);
end;

procedure TNotifyList.RemoveAll;
var
	i: Integer;
begin
	if FEnumCount = 0 then begin
		for i := 0 to FList.Count - 1 do
			DetachClient(FList[i]);
		FList.Clear
	end
	else
		for i := 0 to FList.Count - 1 do begin
			FAdding.Remove(FList[i]);
			DetachClient(FList[i]);
			FList[i] := nil;
		end;
end;

{ TContentNotifyClient }

constructor TContentNotifyClient.Create(aNotifyClientType: TNotifyClientType;
	anOnNotification: TContentNotification);
begin
	inherited Create(aNotifyClientType);
	OnNotification := anOnNotification;
end;

procedure TContentNotifyClient.Notification(anOperation: TContentOperation;
	aSrc, aDst: TObject; anInsertion: TInsertionPos);
begin
	if Assigned(OnNotification) then
		OnNotification(anOperation, aSrc, aDst, anInsertion);
end;

procedure TContentNotifyList.Add(aClient: TContentNotifyClient);
begin
	inherited Add(aClient);
end;

procedure TContentNotifyList.Publish(anOperation: TContentOperation;
	aSrc, aDst: TObject; anInsertion: TInsertionPos);
var
	aClients: TList;
	aClient: TContentNotifyClient;
	i: Integer;
begin
	aClients := BeginEnum;
	try
		for i := 0 to aClients.Count - 1 do begin
			aClient := aClients[i];
			if Assigned(aClient) then
				aClient.Notification(anOperation, aSrc, aDst, anInsertion);
		end
	finally
		EndEnum
	end
end;

function IsNumber(c: Char): Boolean;
begin
	Result := c in ['0'..'9'];
end;

function IsLetter(c: Char): Boolean;
begin
	Result := IsCharAlpha(c);
end;

function IsFloatChar(c: Char): Boolean;
begin
	Result := c in ['0'..'9', '.', ','];
end;

function IsNonBlank(c: Char): Boolean;
begin
	Result := not (c in [#0..' ']);
end;

procedure TStrScan.Init(const aStr: String);
begin
	S := aStr;
	Pos := 1;
end;

procedure TStrScan.Reset;
begin
	Pos := 1;
end;

function TStrScan.Eoln: Boolean;
begin
	Result := Pos > Length(S);
end;

procedure TStrScan.Skip(aLen: Integer);
begin
	while (Pos <= Length(S)) and (aLen > 0) do begin
		Inc(Pos);
		Dec(aLen);
	end;
end;

procedure TStrScan.SkipBlanks;
begin
	while (Pos <= Length(S)) and (S[Pos] in [#0..' ']) do
		Inc(Pos);
end;

procedure TStrScan.FetchRest;
begin
	Token := Copy(S, Pos, Length(S) - Pos + 1);
	Pos := Length(S) + 1;
end;

function TStrScan.FetchWhile(aCond: TCondProc): Boolean;
var
	i: Integer;
begin
	i := Pos;
	while (i <= Length(S)) and aCond(S[i]) do
		Inc(i);
	Result := i > Pos;
	if Result then begin
		Token := Copy(S, Pos, i - Pos);
		Pos := i;
	end;
end;

function TStrScan.FetchLen(aLen: Integer): Boolean;
begin
	Result := Pos + aLen <= Length(S) + 1;
	if Result then begin
		Token := Copy(S, Pos, aLen);
		Inc(Pos, aLen); 
	end;
end;

function TStrScan.FetchLetters: Boolean;
begin
	SkipBlanks;
	Result := FetchWhile(IsLetter);
end;

function TStrScan.FetchNumbers: Boolean;
begin
	SkipBlanks;
	Result := FetchWhile(IsNumber);
end;

function TStrScan.FetchFloat: Boolean;
var
	aLen, i: Integer;
begin
	SkipBlanks;
	i := Pos;
	aLen := Length(S);
	if (i <= aLen) and (S[i] in ['-', '+']) then
		Inc(i);
	while (i <= aLen) and (S[i] in ['0'..'9']) do
		Inc(i);
	if (i <= aLen) and (S[i] in ['.', ',']) then
		Inc(i);
	while (i <= aLen) and (S[i] in ['0'..'9']) do
		Inc(i);
	if (i <= aLen) and (S[i] in ['e', 'E']) then begin
		Inc(i);
		if (i <= aLen) and (S[i] in ['-', '+']) then
			Inc(i);
		while (i <= aLen) and (S[i] in ['0'..'9']) do
			Inc(i);
	end;

	Result := (i > Pos) and IsNumeric(Copy(S, Pos, i - Pos));
	if Result then begin
		Token := Copy(S, Pos, i - Pos);
		Pos := i;
	end;
end;

function TStrScan.FetchQuoted(c1, c2: Char): Boolean;
var
	i: Integer;
begin
	SkipBlanks;
	i := Pos;
	if (i <= Length(S)) and (S[i] = c1) then begin
		Inc(i);
		while (i <= Length(S)) and (S[i] <> c2) do Inc(i);
		if i <= Length(S) then begin
			Result := True;
			Token := Copy(S, Pos + 1, i - Pos - 1);
			Pos := i + 1;
			Exit;
		end
	end;
	Result := False;
end;

function TStrScan.FetchTo(c: Char): Boolean;
var
	i: Integer;
begin
	SkipBlanks;
	i := Pos;
	while (i <= Length(S)) and (S[i] <> c) do
		Inc(i);
	if i <= Length(S) then begin
		Token := Copy(S, Pos, i - Pos);
		Pos := i;
		Result := True
	end
	else
		Result := False;
end;

{ TNameSpace }

function TNameSpace.ObjectFromName(const aName: String; aClass: TClass): Pointer;
var
	i: Integer;
begin
	InternalCheck(Find(aName, i), 'TNameSpace.GetObject', 'Не найден объект "' + aName + '"');
	InternalCheck(Objects[i].InheritsFrom(aClass), 'TNameSpace.GetObject',
		'Не совпадает тип объекта "' + aName + '"');
	Result := Objects[i];
end;

function TNameSpace.FindObject(const aName: String; aClass: TClass): Pointer;
var
	i: Integer;
begin
	Result := nil;
	if Find(aName, i) then begin
		Assert(Assigned(Objects[i]));
		if Assigned(Objects[i]) and Objects[i].InheritsFrom(aClass) then
			Result := Objects[i];
	end;
end;

function TNameSpace.RemoveName(const aName: String): Pointer;
var
	i: Integer;
begin
	if Find(aName, i) then begin
		Result := Objects[i];
		Delete(i)
	end
	else
		Result := nil
end;

procedure TNameSpace.AddFrom(aSrc: TNameSpace);
var
	i: Integer;
begin
	for i := 0 to aSrc.Count - 1 do
		AddObject(aSrc[i], aSrc.Objects[i]);
end;

{ TTempFileStream }

constructor TTempFileStream.Create(const aFileName: string; aShareMode: DWORD);
var
	hFile: THandle;
begin
	FFileName := aFileName;
	hFile := CreateFile(PChar(aFileName), GENERIC_READ or GENERIC_WRITE,
			aShareMode, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_DELETE_ON_CLOSE, 0);
	Win32Check(hFile <> INVALID_HANDLE_VALUE);

	inherited Create(hFile);
end;

destructor TTempFileStream.Destroy;
begin
	if THandle(Handle) <> INVALID_HANDLE_VALUE then
		CloseHandle(Handle);
	inherited Destroy;
end;

{ TInsideStreamAllocator }

type
	TStreamAllocatorBlock = class
	public
		Offset, Size: Integer;

		constructor Create(anOffset, aSize: Integer);
	end;

constructor TStreamAllocatorBlock.Create(anOffset, aSize: Integer);
begin
	inherited Create;
	Offset := anOffset;
	Size := aSize;
end;

constructor TInsideStreamAllocator.Create(aStream: TStream);
begin
	inherited Create;
	FEmptyBlocks := TObjectList.Create(True);
	FStream := aStream;
end;

destructor TInsideStreamAllocator.Destroy;
begin
	FEmptyBlocks.Free;
	inherited Destroy;
end;

procedure TInsideStreamAllocator.Clear;
begin
	Stream.Position := 0;
	Stream.Size := 0;
	FEmptyBlocks.Clear;
end;

function TInsideStreamAllocator.AllocateMem(aSize: Integer;
	anUpdateFileSize: Boolean = True): Integer;
var
	aBlock: TStreamAllocatorBlock;
	i: Integer;
	buf: Byte;
begin
	for i := 0 to FEmptyBlocks.Count - 1 do begin
		aBlock := TStreamAllocatorBlock(FEmptyBlocks[i]);
		if aBlock.Size >= aSize then begin
			Result := aBlock.Offset;
			Inc(aBlock.Offset, aSize);
			Dec(aBlock.Size, aSize);
			if aBlock.Size = 0 then begin
				FEmptyBlocks.Delete(i);
			end;
			Exit;
		end;
	end;

	Result := FStream.Size;
	if anUpdateFileSize then begin
		FStream.Position := Result;
		buf := 0;
		for i := 1 to aSize do
			FStream.WriteBuffer(buf, 1);
	end;
end;

procedure TInsideStreamAllocator.FreeMem(anOffset, aSize: Integer);
var
	aBlock, aBlock2: TStreamAllocatorBlock;
	i, j: Integer;
begin
	aBlock := TStreamAllocatorBlock.Create(anOffset, aSize);
	
	j := FEmptyBlocks.Add(aBlock);
	for i := 0 to FEmptyBlocks.Count - 1 do begin
		aBlock2 := TStreamAllocatorBlock(FEmptyBlocks[i]);
		if aBlock2.Offset + aBlock2.Size = aBlock.Offset then begin
			Inc(aBlock2.Size, aBlock.Size);
			FEmptyBlocks.Delete(j);
			aBlock := aBlock2;
			Break;
		end;
	end;

	for i := 0 to FEmptyBlocks.Count - 1 do begin
		aBlock2 := TStreamAllocatorBlock(FEmptyBlocks[i]);
		if aBlock.Offset + aBlock.Size = aBlock2.Offset then begin
			Inc(aBlock.Size, aBlock2.Size);
			FEmptyBlocks.Delete(i);
			Break;
		end;
	end;
end;

{ TVariantCacheElem }

constructor TVariantCacheElem.Create(const aValue: Variant);
begin
	inherited Create;
	Value := aValue;
end;

{ TVariantCache }

constructor TVariantCache.Create(aMaxCount: Integer);
begin
	inherited Create;
	FMaxCount := aMaxCount;
	FHeader := TVariantCacheElem.Create(Unassigned);
	FHeader.Prev := FHeader;
	FHeader.Next := FHeader;
	FKeys := TStringList.Create;
	FKeys.Sorted := True;
	FKeys.Duplicates := dupError;
end;

destructor TVariantCache.Destroy;
begin
	if Assigned(FHeader) then
		Clear;
	FKeys.Free;
	FHeader.Free;
	inherited Destroy;
end;

function TVariantCache.Add(const aKey: String; const aValue: Variant): TVariantCacheElem;
begin
	Result := TVariantCacheElem.Create(aValue);
	Result.Prev := FHeader.Prev;
	Result.Next := FHeader;
	Result.Prev.Next := Result;
	Result.Next.Prev := Result;
	FKeys.AddObject(aKey, Result);

	if FKeys.Count > MaxCount then
		Delete(FHeader.Next);
end;

procedure TVariantCache.Delete(anElem: TVariantCacheElem);
var
	i: Integer;
begin
	i := FKeys.IndexOfObject(anElem);
	if i >= 0 then
		FKeys.Delete(i);
	anElem.Prev.Next := anElem.Next;
	anElem.Next.Prev := anElem.Prev;
	anElem.Free;
end;

procedure TVariantCache.Delete(const aKey: String);
var
	anElem: TVariantCacheElem;
	i: Integer;
begin
	if FKeys.Find(aKey, i) then begin
		anElem := TVariantCacheElem(FKeys.Objects[i]);

		FKeys.Delete(i);
		anElem.Prev.Next := anElem.Next;
		anElem.Next.Prev := anElem.Prev;
		anElem.Free;
	end;
end;

procedure TVariantCache.Clear;
begin
	while FHeader.Next <> FHeader do
		Delete(FHeader.Next);
	FKeys.Clear;
end;

function TVariantCache.Find(const aKey: String): TVariantCacheElem;
var
	i: Integer;
begin
	if FKeys.Find(aKey, i) then begin
		Result := TVariantCacheElem(FKeys.Objects[i]);
		MakeLRU(Result);
	end
	else
		Result := nil;
end;

procedure TVariantCache.MakeLRU(anElem: TVariantCacheElem);
begin
	anElem.Prev.Next := anElem.Next;
	anElem.Next.Prev := anElem.Prev;

	anElem.Prev := FHeader.Prev;
	anElem.Next := FHeader;
	anElem.Prev.Next := anElem;
	anElem.Next.Prev := anElem;
end;

function TVariantCache.GetCount: Integer;
begin
	Result := FKeys.Count;
end;

function TVariantCache.GetKey(Index: Integer): String;
begin
	Result := FKeys[Index];
end;

{ TDestroyNotifier }

constructor TDestroyNotifier.CreateFor(anOnDestroy: TNotifyEvent;
	const aComponents: array of TComponent);
var
	i: Integer;
begin
	Create(nil);
	FOnDestroy := anOnDestroy;
	for i := Low(aComponents) to High(aComponents) do
		if Assigned(aComponents[i]) then
			Add(aComponents[i]);
end;

procedure TDestroyNotifier.Add(aComponent: TComponent);
begin
	aComponent.FreeNotification(Self);
end;

procedure TDestroyNotifier.Notification(aComponent: TComponent; anOperation: TOperation);
begin
	inherited;
	if (anOperation = opRemove) and Assigned(FOnDestroy) then
		FOnDestroy(aComponent);
end;

{ TWordsFilter }

function TWordsFilter.Check(const s: String): Boolean;
var
	i: Integer;
	us: String;
begin
	Result := True;
	if FFilterWords.Count > 0 then begin
		us := AnsiUpperCase(s);
		for i := 0 to FFilterWords.Count - 1 do
			if not FindWord(FFilterWords[i], us) then begin
				Result := False;
				break
			end
	end;
end;

constructor TWordsFilter.Create(const aFilter: string);
begin
	inherited Create;
	FFilterWords := TStringList.Create;
	FFilter := '';
	if aFilter <> '' then
		SetFilter(aFilter);
end;

destructor TWordsFilter.Destroy;
begin
	FFilterWords.Free;
	inherited;
end;

function TWordsFilter.GetFilterWord(Index: Integer): String;
begin
	Result := FFilterWords[Index];
end;

function TWordsFilter.GetWordCount: Integer;
begin
	Result := FFilterWords.Count
end;

procedure TWordsFilter.SetFilter(const aValue: String);
var
	s: String;
	i1, i2: Integer;
begin
	if aValue <> FFilter then begin
		FFilter := aValue;
		FFilterWords.Clear;
		s := AnsiUpperCase(aValue);
		i1 := 1;
		while i1 <= Length(s) do begin
			while (i1 <= Length(s)) and (s[i1] <= ' ') do
				Inc(i1);
			if i1 <= Length(s) then begin
				i2 := i1 + 1;
				while (i2 <= Length(s)) and (s[i2] > ' ') do
					Inc(i2);
				FFilterWords.Add(Copy(s, i1, i2 - i1));
				i1 := i2;
			end
		end;
	end;
end;

{ TPointerSet }

constructor TPointerSet.Create(aHashSize: Longword);
begin
	inherited Create;
	FHashSize := aHashSize;
	SetLength(FHash, aHashSize);
end;

destructor TPointerSet.Destroy;
begin
	Clear;
	inherited;
end;

procedure TPointerSet.Clear;
var
	i: Integer;
begin
	for i := 0 to FHashSize - 1 do
		with FHash[i] do
			case ItemKind of
				ikItem:
					ItemKind := ikEmpty;
				ikList: begin
					ItemKind := ikEmpty;
					ItemOrList.Free;
				end;
			end;
end;

function TPointerSet.GetHashIndex(anItem: Pointer): Longword;
begin
	Result := Longword(anItem) mod FHashSize;
end;

function TPointerSet.Contains(anItem: Pointer): Boolean;
begin
	with FHash[GetHashIndex(anItem)] do
		case ItemKind of
			ikItem: Result := ItemOrList = anItem;
			ikList: Result := ItemOrList.IndexOf(anItem) <> -1;
			else
				Result := False;
		end;
end;

function TPointerSet.Include(anItem: Pointer): Boolean;
var
	aSaveItem: Pointer;
begin
	with FHash[GetHashIndex(anItem)] do
		case ItemKind of
			ikEmpty: begin
				ItemOrList := anItem;
				ItemKind := ikItem;
				Result := True;
			end;
			ikItem: begin
				Result := ItemOrList <> anItem;
				if Result then begin
					aSaveItem := ItemOrList;
					ItemOrList := TList.Create;
					ItemOrList.Add(aSaveItem);
					ItemOrList.Add(anItem);
					ItemKind := ikList;
				end;
			end;
			ikList: begin
				Result := ItemOrList.IndexOf(anItem) = -1;
				if Result then
					ItemOrList.Add(anItem)
			end;
			else
				Result := False
		end;
end;

function TPointerSet.Exclude(anItem: Pointer): Boolean;
begin
	with FHash[GetHashIndex(anItem)] do
		case ItemKind of
			ikEmpty:
				Result := False;
			ikItem: begin
				Result := ItemOrList = anItem;
				if Result then
					ItemKind := ikEmpty;
			end;
			ikList: begin
				Result := ItemOrList.Remove(anItem) <> -1;
			end
			else
				Result := False;
		end;
end;

procedure TPointerSet.GetItems(anItems: TList);
var
	i, j: Integer;
begin
	for i := 0 to FHashSize - 1 do
		with FHash[i] do
			case ItemKind of
				ikItem: anItems.Add(ItemOrList);
				ikList: begin
					anItems.Capacity := anItems.Count + ItemOrList.Count;
					for j := 0 to ItemOrList.Count - 1 do
						anItems.Add(ItemOrList[j])
				end;
			end;
end;

{ TRefObjectSet }

type
	TRefObjectSetHashItem = class(TRefObjectList)
	end;

constructor TRefObjectSet.Create(aHashSize: Longword);
begin
	inherited Create;
	FHashSize := aHashSize;
	SetLength(FHash, aHashSize);
end;

destructor TRefObjectSet.Destroy;
begin
  Clear;
	inherited;
end;

procedure TRefObjectSet.Clear;
var
	i: Integer;
	p: ^TRefObject;
begin
	p := @FHash[0];
	for i := 0 to FHashSize - 1 do begin
		if Assigned(p^) then begin
			if p^.ClassType = TRefObjectSetHashItem then 
				TRefObjectSetHashItem(p^).Free
			else
				p^.Release;
			p^ := nil;
		end;
		Inc(p);
	end;
end;

function TRefObjectSet.GetHashIndex(anItem: TObject): Longword;
begin
	Result := Longword(anItem) mod FHashSize;
end;

function TRefObjectSet.Contains(anItem: TRefObject): Boolean;
var
	p: ^TRefObject;
begin
	p := @FHash[GetHashIndex(anItem)];
	if Assigned(p^) then
		if p^.ClassType = TRefObjectSetHashItem then
			Result := TRefObjectSetHashItem(p^).IndexOf(anItem) <> -1
		else
			Result := p^ = anItem
	else
		Result := False;
end;

function TRefObjectSet.Include(anItem: TRefObject): Boolean;
var
	p: ^TRefObject;
	aHashItem: TRefObjectSetHashItem;
begin
	p := @FHash[GetHashIndex(anItem)];
	if Assigned(p^) then
		if p^.ClassType = TRefObjectSetHashItem then begin
			if TRefObjectSetHashItem(p^).IndexOf(anItem) = -1 then begin
				TRefObjectSetHashItem(p^).Add(anItem);
				Result := True;
				Exit;
			end
		end
		else begin
			if p^ <> anItem then begin
				aHashItem := TRefObjectSetHashItem.Create;
				aHashItem.Add(p^);
				p^.Release;
				aHashItem.Add(anItem);
				TObject(p^) := aHashItem;
				Result := True;
				Exit;
			end;
		end
	else begin
		p^ := anItem;
		anItem.AddRef;
		Result := True;
		Exit
	end;
	Result := False;
end;

function TRefObjectSet.Exclude(anItem: TRefObject): Boolean;
var
	p: ^TRefObject;
begin
	p := @FHash[GetHashIndex(anItem)];
	if Assigned(p^) then
		if p^.ClassType = TRefObjectSetHashItem then begin
			if TRefObjectSetHashItem(p^).Remove(anItem) <> -1 then begin
				if TRefObjectSetHashItem(p^).Count = 1 then begin
					anItem := TRefObjectSetHashItem(p^)[0];
					anItem.AddRef;
					TRefObjectSetHashItem(p^).Free;
					p^ := anItem;
				end;
				Result := True;
				Exit;
			end
		end
		else if p^ = anItem then begin
			p^ := nil;
			anItem.Release;
			Result := True;
			Exit
		end;
	Result := False;
end;


procedure TRefObjectSet.GetItems(anItems: TRefObjectList);
var
	i, j: Integer;
	p: ^TRefObject;
begin
	p := @FHash[0];
	for i := 0 to FHashSize - 1 do begin
		if Assigned(p^) then
			if p^.ClassType = TRefObjectSetHashItem then
				for j := 0 to TRefObjectSetHashItem(p^).Count - 1 do
					anItems.Add(TRefObjectSetHashItem(p^)[j])
			else
				anItems.Add(p^);
		Inc(p);
	end;
end;


initialization
	;
finalization
	gVersionInfo.Free;
end.
