KOLadd.pas

   1 //[START OF KOL.pas]
   2 {****************************************************************
   3                                                                     d       d
   4         KKKKK    KKKKK    OOOOOOOOO    LLLLL                        d       d
   5         KKKKK    KKKKK  OOOOOOOOOOOOO  LLLLL                        d       d
   6         KKKKK    KKKKK  OOOOO   OOOOO  LLLLL          aaaa          d       d
   7         KKKKK  KKKKK    OOOOO   OOOOO  LLLLL              a         d       d
   8         KKKKKKKKKK      OOOOO   OOOOO  LLLLL              a         d       d
   9         KKKKK  KKKKK    OOOOO   OOOOO  LLLLL          aaaaa    dddddd  dddddd
  10         KKKKK    KKKKK  OOOOO   OOOOO  LLLLL         a     a  d     d d     d
  11         KKKKK    KKKKK  OOOOOOOOOOOOO  LLLLLLLLLLLLL a     a  d     d d     d
  12         KKKKK    KKKKK    OOOOOOOOO    LLLLLLLLLLLLL  aaaaa aa dddddd  dddddd
  13
  14   Key Objects Library (C) 2000 by Kladov Vladimir.
  15
  16 //[VERSION]
  17 ****************************************************************
  18 * VERSION 2.04
  19 ****************************************************************
  20 //[END OF VERSION]
  21
  22 The only reason why this part of KOL separated into another unit is that
  23 Delphi has a restriction to DCU size exceeding which it is failed to debug
  24 it normally and in attempt to execute code step by step an internal error
  25 is occur which stops Delphi from working at all.
  26
  27 Version indicated above is a version of KOL, having place when KOLadd.pas was
  28 modified last time, this is not a version of KOLadd itself.
  29 }
  30
  31 unit KOLadd;
  32
  33 interface
  34
  35 {$I KOLDEF.INC}
  36
  37 uses Windows, KOL;
  38
  39 {------------------------------------------------------------------------------)
  40 |                                                                              |
  41 |                                  T L i s t E x                               |
  42 |                                                                              |
  43 (------------------------------------------------------------------------------}
  44 type
  45
  46 //[TListEx DEFINITION]
  47   {++}(*TListEx = class;*){--}
  48   PListEx = {-}^{+}TListEx;
  49   TListEx = object( TObj )
  50   {* Extended list, with Objects[ ] property. Created calling NewListEx function. }
  51   protected
  52     fList: PList;
  53     fObjects: PList;
  54     function GetEx(Idx: Integer): Pointer;
  55     procedure PutEx(Idx: Integer; const Value: Pointer);
  56     function GetCount: Integer;
  57     function GetAddBy: Integer;
  58     procedure Set_AddBy(const Value: Integer);
  59   public
  60     destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
  61     {* }
  62     property AddBy: Integer read GetAddBy write Set_AddBy;
  63     {* }
  64     property Items[ Idx: Integer ]: Pointer read GetEx write PutEx;
  65     {* }
  66     property Count: Integer read GetCount;
  67     {* }
  68     procedure Clear;
  69     {* }
  70     procedure Add( Value: Pointer );
  71     {* }
  72     procedure AddObj( Value, Obj: Pointer );
  73     {* }
  74     procedure Insert( Idx: Integer; Value: Pointer );
  75     {* }
  76     procedure InsertObj( Idx: Integer; Value, Obj: Pointer );
  77     {* }
  78     procedure Delete( Idx: Integer );
  79     {* }
  80     procedure DeleteRange( Idx, Len: Integer );
  81     {* }
  82     function IndexOf( Value: Pointer ): Integer;
  83     {* }
  84     function IndexOfObj( Obj: Pointer ): Integer;
  85     {* }
  86     procedure Swap( Idx1, Idx2: Integer );
  87     {* }
  88     procedure MoveItem( OldIdx, NewIdx: Integer );
  89     {* }
  90     property ItemsList: PList read fList;
  91     {* }
  92     property ObjList: PList read fObjects;
  93     {* }
  94     function Last: Pointer;
  95     {* }
  96     function LastObj: Pointer;
  97     {* }
  98   end;
  99 //[END OF TListEx DEFINITION]
 100
 101 //[NewListEx DECLARATION]
 102 function NewListEx: PListEx;
 103 {* Creates extended list. }
 104
 105 {------------------------------------------------------------------------------)
 106 |                                                                              |
 107 |                                  T B i t s                                   |
 108 |                                                                              |
 109 (------------------------------------------------------------------------------}
 110 type
 111 //[TBits DEFINITION]
 112   {++}(*TBits = class;*){--}
 113   PBits = {-}^{+}TBits;
 114   TBits = object( TObj )
 115   {* Variable-length bits array object. Created using function NewBits. See also
 116      |<a href="kol_pas.htm#Small bit arrays (max 32 bits in array)">
 117      Small bit arrays (max 32 bits in array)
 118      |</a>. }
 119   protected
 120     fList: PList;
 121     fCount: Integer;
 122     function GetBit(Idx: Integer): Boolean;
 123     procedure SetBit(Idx: Integer; const Value: Boolean);
 124     function GetCapacity: Integer;
 125     function GetSize: Integer;
 126     procedure SetCapacity(const Value: Integer);
 127   public
 128     destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
 129     {* }
 130     property Bits[ Idx: Integer ]: Boolean read GetBit write SetBit;
 131     {* }
 132     property Size: Integer read GetSize;
 133     {* Size in bytes of the array. To get know number of bits, use property Count. }
 134     property Count: Integer read fCount;
 135     {* Number of bits an the array. }
 136     property Capacity: Integer read GetCapacity write SetCapacity;
 137     {* Number of bytes allocated. Can be set before assigning bit values
 138        to improve performance (minimizing amount of memory allocation
 139        operations).  }
 140     function Copy( From, BitsCount: Integer ): PBits;
 141     {* Use this property to get a sub-range of bits starting from given bit
 142        and of BitsCount bits count. }
 143     function IndexOf( Value: Boolean ): Integer;
 144     {* Returns index of first bit with given value (True or False). }
 145     function OpenBit: Integer;
 146     {* Returns index of the first bit not set to true. }
 147     procedure Clear;
 148     {* Clears bits array. Count, Size and Capacity become 0. }
 149     function LoadFromStream( strm: PStream ): Integer;
 150     {* Loads bits from the stream. Data should be stored in the stream
 151        earlier using SaveToStream method. While loading, previous bits
 152        data are discarded and replaced with new one totally. In part,
 153        Count of bits also is changed. Count of bytes read from the stream
 154        while loading data is returned. }
 155     function SaveToStream( strm: PStream ): Integer;
 156     {* Saves entire array of bits to the stream. First, Count of bits
 157        in the array is saved, then all bytes containing bits data. }
 158     function Range( Idx, N: Integer ): PBits;
 159     {* Creates and returns new TBits object instance containing N bits
 160        starting from index Idx. If you call this method, you are responsible
 161        for destroying returned object when it become not neccessary. }
 162     procedure AssignBits( ToIdx: Integer; FromBits: PBits; FromIdx, N: Integer );
 163     {* Assigns bits from another bits array object. N bits are assigned
 164        starting at index ToIdx. }
 165   end;
 166 //[END OF TBits DEFINITION]
 167
 168 //[NewBits DECLARATION]
 169 function NewBits: PBits;
 170 {* Creates variable-length bits array object. }
 171
 172 {------------------------------------------------------------------------------)
 173 |                                                                              |
 174 |                         T F a s t S t r L i s t                              |
 175 |                                                                              |
 176 (------------------------------------------------------------------------------}
 177 type
 178   PFastStrListEx = ^TFastStrListEx;
 179   TFastStrListEx = object( TObj )
 180   private
 181     function GetItemLen(Idx: Integer): Integer;
 182     function GetObject(Idx: Integer): DWORD;
 183     procedure SetObject(Idx: Integer; const Value: DWORD);
 184     function GetValues(AName: PChar): PChar;
 185   protected
 186     procedure Init; virtual;
 187   protected
 188     fList: PList;
 189     fCount: Integer;
 190     fCaseSensitiveSort: Boolean;
 191     fTextBuf: PChar;
 192     fTextSiz: DWORD;
 193     fUsedSiz: DWORD;
 194   protected
 195     procedure ProvideSpace( AddSize: DWORD );
 196     function Get(Idx: integer): string;
 197     function GetTextStr: string;
 198     procedure Put(Idx: integer; const Value: string);
 199     procedure SetTextStr(const Value: string);
 200     function GetPChars( Idx: Integer ): PChar;
 201   {++}(*public*){--}
 202     destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
 203   public
 204     function AddAnsi( const S: String ): Integer;
 205     {* Adds Ansi String to a list. }
 206     function AddAnsiObject( const S: String; Obj: DWORD ): Integer;
 207     {* Adds Ansi String and correspondent object to a list. }
 208     function Add(S: PChar): integer;
 209     {* Adds a string to list. }
 210     function AddLen(S: PChar; Len: Integer): integer;
 211     {* Adds a string to list. The string can contain #0 characters. }
 212   public
 213     FastClear: Boolean;
 214     {* }
 215     procedure Clear;
 216     {* Makes string list empty. }
 217     procedure Delete(Idx: integer);
 218     {* Deletes string with given index (it *must* exist). }
 219     function IndexOf(const S: string): integer;
 220     {* Returns index of first string, equal to given one. }
 221     function IndexOf_NoCase(const S: string): integer;
 222     {* Returns index of first string, equal to given one (while comparing it
 223        without case sensitivity). }
 224     function IndexOfStrL_NoCase( Str: PChar; L: Integer ): integer;
 225     {* Returns index of first string, equal to given one (while comparing it
 226        without case sensitivity). }
 227     function Find(const S: String; var Index: Integer): Boolean;
 228     {* Returns Index of the first string, equal or greater to given pattern, but
 229        works only for sorted TFastStrListEx object. Returns TRUE if exact string found,
 230        otherwise nearest (greater then a pattern) string index is returned,
 231        and the result is FALSE. }
 232     procedure InsertAnsi(Idx: integer; const S: String);
 233     {* Inserts ANSI string before one with given index. }
 234     procedure InsertAnsiObject(Idx: integer; const S: String; Obj: DWORD);
 235     {* Inserts ANSI string before one with given index. }
 236     procedure Insert(Idx: integer; S: PChar);
 237     {* Inserts string before one with given index. }
 238     procedure InsertLen( Idx: Integer; S: PChar; Len: Integer );
 239     {* Inserts string from given PChar. It can contain #0 characters. }
 240     function LoadFromFile(const FileName: string): Boolean;
 241     {* Loads string list from a file. (If file does not exist, nothing
 242        happens). Very fast even for huge text files. }
 243     procedure LoadFromStream(Stream: PStream; Append2List: boolean);
 244     {* Loads string list from a stream (from current position to the end of
 245        a stream). Very fast even for huge text. }
 246     procedure MergeFromFile(const FileName: string);
 247     {* Merges string list with strings in a file. Fast. }
 248     procedure Move(CurIndex, NewIndex: integer);
 249     {* Moves string to another location. }
 250     procedure SetText(const S: string; Append2List: boolean);
 251     {* Allows to set strings of string list from given string (in which
 252        strings are separated by $0D,$0A or $0D characters). Text can
 253        contain #0 characters. Works very fast. This method is used in
 254        all others, working with text arrays (LoadFromFile, MergeFromFile,
 255        Assign, AddStrings). }
 256     function SaveToFile(const FileName: string): Boolean;
 257     {* Stores string list to a file. }
 258     procedure SaveToStream(Stream: PStream);
 259     {* Saves string list to a stream (from current position). }
 260     function AppendToFile(const FileName: string): Boolean;
 261     {* Appends strings of string list to the end of a file. }
 262     property Count: integer read fCount;
 263     {* Number of strings in a string list. }
 264     property Items[Idx: integer]: string read Get write Put; default;
 265     {* Strings array items. If item does not exist, empty string is returned.
 266        But for assign to property, string with given index *must* exist. }
 267     property ItemPtrs[ Idx: Integer ]: PChar read GetPChars;
 268     {* Fast access to item strings as PChars. }
 269     property ItemLen[ Idx: Integer ]: Integer read GetItemLen;
 270     {* Length of string item. }
 271     function Last: String;
 272     {* Last item (or '', if string list is empty). }
 273     property Text: string read GetTextStr write SetTextStr;
 274     {* Content of string list as a single string (where strings are separated
 275        by characters $0D,$0A). }
 276     procedure Swap( Idx1, Idx2 : Integer );
 277     {* Swaps to strings with given indeces. }
 278     procedure Sort( CaseSensitive: Boolean );
 279     {* Call it to sort string list. }
 280   public
 281     function AddObject( S: PChar; Obj: DWORD ): Integer;
 282     {* Adds string S (null-terminated) with associated object Obj. }
 283     function AddObjectLen( S: PChar; Len: Integer; Obj: DWORD ): Integer;
 284     {* Adds string S of length Len with associated object Obj. }
 285     procedure InsertObject( Idx: Integer; S: PChar; Obj: DWORD );
 286     {* Inserts string S (null-terminated) at position Idx in the list,
 287        associating it with object Obj. }
 288     procedure InsertObjectLen( Idx: Integer; S: PChar; Len: Integer; Obj: DWORD );
 289     {* Inserts string S of length Len at position Idx in the list,
 290        associating it with object Obj. }
 291     property Objects[ Idx: Integer ]: DWORD read GetObject write SetObject;
 292     {* Access to objects associated with strings in the list. }
 293   public
 294     procedure Append( S: PChar );
 295     {* Appends S (null-terminated) to the last string in FastStrListEx object, very fast. }
 296     procedure AppendLen( S: PChar; Len: Integer );
 297     {* Appends S of length Len to the last string in FastStrListEx object, very fast. }
 298     procedure AppendInt2Hex( N: DWORD; MinDigits: Integer );
 299     {* Converts N to hexadecimal and appends resulting string to the last
 300        string, very fast. }
 301   public
 302     property Values[ Name: PChar ]: PChar read GetValues;
 303     {* Returns a value correspondent to the Name an ini-file-like string list
 304        (having Name1=Value1 Name2=Value2 etc. in each string). }
 305     function IndexOfName( AName: PChar ): Integer;
 306     {* Searches string starting from 'AName=' in string list like ini-file. }
 307   end;
 308
 309 function NewFastStrListEx: PFastStrListEx;
 310          {* Creates FastStrListEx object. }
 311
 312 var Upper: array[ Char ] of Char;
 313     {* An table to convert char to uppercase very fast. First call InitUpper. }
 314
 315     Upper_Initialized: Boolean;
 316 procedure InitUpper;
 317           {* Call this fuction ones to fill Upper[ ] table before using it. }
 318
 319 //[TWStrList]
 320
 321 {-}
 322 {$IFNDEF _FPC}
 323 procedure WStrCopy( Dest, Src: PWideChar );
 324 {* Copies null-terminated Unicode string (terminated null also copied). }
 325 function WStrCmp( W1, W2: PWideChar ): Integer;
 326 {* Compares two null-terminated Unicode strings. }
 327 {$ENDIF _FPC}
 328
 329 {$IFNDEF _D2} //------------------ WideString is not supported in D2 -----------
 330
 331 type
 332   PWStrList = ^TWstrList;
 333   {* }
 334 //[TWstrList DEFINITION]
 335   TWStrList = object( TObj )
 336   {* String list to store Unicode (null-terminated) strings. }
 337   protected
 338     function GetCount: Integer;
 339     function GetItems(Idx: Integer): WideString;
 340     procedure SetItems(Idx: Integer; const Value: WideString);
 341     function GetPtrs(Idx: Integer): PWideChar;
 342     function GetText: WideString;
 343   protected
 344     fList: PList;
 345     fText: PWideChar;
 346     fTextBufSz: Integer;
 347     fTmp1, fTmp2: WideString;
 348     procedure Init; virtual;
 349   public
 350     procedure SetText(const Value: WideString);
 351     {* See also TStrList.SetText }
 352     destructor Destroy; virtual;
 353     {* }
 354     procedure Clear;
 355     {* See also TStrList.Clear }
 356     property Items[ Idx: Integer ]: WideString read GetItems write SetItems;
 357     {* See also TStrList.Items }
 358     property ItemPtrs[ Idx: Integer ]: PWideChar read GetPtrs;
 359     {* See also TStrList.ItemPtrs }
 360     property Count: Integer read GetCount;
 361     {* See also TStrList.Count }
 362     function Add( const W: WideString ): Integer;
 363     {* See also TStrList.Add }
 364     procedure Insert( Idx: Integer; const W: WideString );
 365     {* See also TStrList.Insert }
 366     procedure Delete( Idx: Integer );
 367     {* See also TStrList.Delete }
 368     property Text: WideString read GetText write SetText;
 369     {* See also TStrList.Text }
 370     procedure AddWStrings( WL: PWStrList );
 371     {* See also TStrList.AddStrings }
 372     procedure Assign( WL: PWStrList );
 373     {* See also TStrList.Assign }
 374     function LoadFromFile( const Filename: String ): Boolean;
 375     {* See also TStrList.LoadFromFile }
 376     procedure LoadFromStream( Strm: PStream );
 377     {* See also TStrList.LoadFromStream }
 378     function MergeFromFile( const Filename: String ): Boolean;
 379     {* See also TStrList.MergeFromFile }
 380     procedure MergeFromStream( Strm: PStream );
 381     {* See also TStrList.MergeFromStream }
 382     function SaveToFile( const Filename: String ): Boolean;
 383     {* See also TStrList.SaveToFile }
 384     procedure SaveToStream( Strm: PStream );
 385     {* See also TStrList.SaveToStream }
 386     function AppendToFile( const Filename: String ): Boolean;
 387     {* See also TStrList.AppendToFile }
 388     procedure Swap( Idx1, Idx2: Integer );
 389     {* See also TStrList.Swap }
 390     procedure Sort( CaseSensitive: Boolean );
 391     {* See also TStrList.Sort }
 392     procedure Move( IdxOld, IdxNew: Integer );
 393     {* See also TStrList.Move }
 394   end;
 395 //[END OF TWStrList DEFINITION]
 396
 397 //[TWStrListEx]
 398   PWStrListEx = ^TWStrListEx;
 399
 400 //[TWStrListEx DEFINITION]
 401   TWStrListEx = object( TWStrList )
 402   {* Extended Unicode string list (with Objects). }
 403   protected
 404     function GetObjects(Idx: Integer): DWORD;
 405     procedure SetObjects(Idx: Integer; const Value: DWORD);
 406     procedure ProvideObjectsCapacity( NewCap: Integer );
 407   protected
 408     fObjects: PList;
 409     procedure Init; virtual;
 410   public
 411     destructor Destroy; virtual;
 412     {* }
 413     property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects;
 414     {* }
 415     procedure AddWStrings( WL: PWStrListEx );
 416     {* }
 417     procedure Assign( WL: PWStrListEx );
 418     {* }
 419     procedure Clear;
 420     {* }
 421     procedure Delete( Idx: Integer );
 422     {* }
 423     procedure Move( IdxOld, IdxNew: Integer );
 424     {* }
 425     function AddObject( const S: WideString; Obj: DWORD ): Integer;
 426     {* Adds a string and associates given number with it. Index of the item added
 427        is returned. }
 428     procedure InsertObject( Before: Integer; const S: WideString; Obj: DWORD );
 429     {* Inserts a string together with object associated. }
 430     function IndexOfObj( Obj: Pointer ): Integer;
 431     {* Returns an index of a string associated with the object passed as a
 432        parameter. If there are no such strings, -1 is returned. }
 433   end;
 434 //[END OF TWStrListEx DEFINITION]
 435
 436 //[NewWStrList DECLARATION]
 437 function NewWStrList: PWStrList;
 438 {* Creates new TWStrList object and returns a pointer to it. }
 439
 440 //[NewWStrListEx DECLARATION]
 441 function NewWStrListEx: PWStrListEx;
 442 {* Creates new TWStrListEx objects and returns a pointer to it. }
 443
 444 {$ENDIF}
 445
 446 //[CABINET FILES OBJECT]
 447 type
 448   {++}(*TCabFile = class;*){--}
 449   PCABFile = {-}^{+}TCABFile;
 450
 451   TOnNextCAB = function( Sender: PCABFile ): String of object;
 452   TOnCABFile = function( Sender: PCABFile; var FileName: String ): Boolean of object;
 453
 454 { ----------------------------------------------------------------------
 455
 456                 TCabFile - windows cabinet files
 457
 458 ----------------------------------------------------------------------- }
 459 //[TCabFile DEFINITION]
 460   TCABFile = object( TObj )
 461   {* An object to simplify extracting files from a cabinet (.CAB) files.
 462      The only what need to use this object, setupapi.dll. It is provided
 463      with all latest versions of Windows. }
 464   protected
 465     FPaths: PStrList;
 466     FNames: PStrList;
 467     FOnNextCAB: TOnNextCAB;
 468     FOnFile: TOnCABFile;
 469     FTargetPath: String;
 470     FSetupapi: THandle;
 471     function GetNames(Idx: Integer): String;
 472     function GetCount: Integer;
 473     function GetPaths(Idx: Integer): String;
 474     function GetTargetPath: String;
 475   protected
 476     FGettingNames: Boolean;
 477     FCurCAB: Integer;
 478   public
 479     destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
 480     {* }
 481     property Paths[ Idx: Integer ]: String read GetPaths;
 482     {* A list of CAB-files. It is stored, when constructing function
 483        OpenCABFile called. }
 484     property Names[ Idx: Integer ]: String read GetNames;
 485     {* A list of file names, stored in a sequence of CAB files. To get know,
 486        how many files are there, check Count property. }
 487     property Count: Integer read GetCount;
 488     {* Number of files stored in a sequence of CAB files. }
 489     function Execute: Boolean;
 490     {* Call this method to extract or enumerate files in CAB. For every
 491        file, found during executing, event OnFile is alled (if assigned).
 492        If the event handler (if any) does not provide full target path for
 493        a file to extract to, property TargetPath is applyed (also if it
 494        is assigned), or file is extracted to the default directory (usually
 495        the same directory there CAB file is located, or current directory
 496        - by a decision of the system).
 497        |<br>
 498        If a sequence of CAB files is used, and not all names for CAB files
 499        are provided (absent or represented by a string '?' ), an event
 500        OnNextCAB is called to obtain the name of the next CAB file.}
 501     property CurCAB: Integer read FCurCAB;
 502     {* Index of current CAB file in a sequence of CAB files. When OnNextCAB
 503        event is called (if any), CurCAB property is already set to the
 504        index of path, what should be provided. }
 505     property OnNextCAB: TOnNextCAB read FOnNextCAB write FOnNextCAB;
 506     {* This event is called, when a series of CAB files is needed and not
 507        all CAB file names are provided (absent or represented by '?' string).
 508        If this event is not assigned, the user is prompted to browse file. }
 509     property OnFile: TOnCABFile read FOnFile write FOnFile;
 510     {* This event is called for every file found during Execute method.
 511        In an event handler (if any assigned), it is possible to return
 512        False to skip file, or to provide another full target path for
 513        file to extract it to, then default. If the event is not assigned,
 514        all files are extracted either to default directory, or to the
 515        directory TargetPath, if it is provided. }
 516     property TargetPath: String read GetTargetPath write FTargetPath;
 517     {* Optional target directory to place there extracted files. }
 518   end;
 519 //[END OF TCABFile DEFINITION]
 520
 521 //[OpenCABFile DECLARATION]
 522 function OpenCABFile( const APaths: array of String ): PCABFile;
 523 {* This function creates TCABFile object, passing a sequence of CAB file names
 524    (fully qualified). It is possible not to provide all names here, or pass '?'
 525    string in place of some of those. For such files, either an event OnNextCAB
 526    will be called, or (and) user will be prompted to browse file during
 527    executing (i.e. Extracting). }
 528
 529 //[DIRCHANGE]
 530 type
 531   {++}(*TDirChange = class;*){--}
 532   PDirChange = {-}^{+}TDirChange;
 533   {* }
 534
 535   TOnDirChange = procedure (Sender: PDirChange; const Path: string) of object;
 536   {* Event type to define OnChange event for folder monitoring objects. }
 537
 538   TFileChangeFilters = (fncFileName, fncDirName, fncAttributes, fncSize,
 539       fncLastWrite, fncLastAccess, fncCreation, fncSecurity);
 540   {* Possible change monitor filters. }
 541   TFileChangeFilter = set of TFileChangeFilters;
 542   {* Set of filters to pass to a constructor of TDirChange object. }
 543
 544 { ----------------------------------------------------------------------
 545
 546                           TDirChange object
 547
 548 ----------------------------------------------------------------------- }
 549 //[TDirChange DEFINITION]
 550   TDirChange = object(TObj)
 551   {* Object type to monitor changes in certain folder. }
 552   protected
 553     FOnChange: TOnDirChange;
 554     FHandle: THandle;
 555     FPath: string;
 556     FMonitor: PThread;
 557     function Execute( Sender: PThread ): Integer;
 558     procedure Changed;
 559   protected
 560   {++}(*public*){--}
 561     destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
 562     {*}
 563   public
 564     property Handle: THandle read FHandle;
 565     {* Handle of file change notification object. *}
 566     property Path: String read FPath; //write SetPath;
 567     {* Path to monitored folder (to a root, if tree of folders
 568        is under monitoring). }
 569   end;
 570 //[END OF TDirChange DEFINITION]
 571
 572 //[NewDirChangeNotifier DECLARATION]
 573 function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;
 574                                WatchSubtree: Boolean; ChangeProc: TOnDirChange ): PDirChange;
 575 {* Creates notification object TDirChangeNotifier. If something wrong (e.g.,
 576    passed directory does not exist), nil is returned as a result. When change
 577    is notified, ChangeProc is called always in main thread context.
 578    (Please note, that ChangeProc can not be nil).
 579    If empty filter is passed, default filter is used:
 580    [fncFileName..fncLastWrite]. }
 581
 582 //[METAFILES]
 583
 584 type
 585   {++}(*TMetafile = class;*){--}
 586   PMetafile = {-}^{+}TMetafile;
 587 { ----------------------------------------------------------------------
 588
 589       TMetafile - Windows metafile and Enchanced Metafile image
 590
 591 ----------------------------------------------------------------------- }
 592 //[TMetafile DEFINITION]
 593   TMetafile = object( TObj )
 594   {* Object type to incapsulate metafile image. }
 595   protected
 596     function GetHeight: Integer;
 597     function GetWidth: Integer;
 598     procedure SetHandle(const Value: THandle);
 599   protected
 600     fHandle: THandle;
 601     fHeader: PEnhMetaHeader;
 602     procedure RetrieveHeader;
 603   public
 604     destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
 605     {* }
 606     procedure Clear;
 607     {* }
 608     function Empty: Boolean;
 609     {* Returns TRUE if empty}
 610     property Handle: THandle read fHandle write SetHandle;
 611     {* Returns handle of enchanced metafile. }
 612     function LoadFromStream( Strm: PStream ): Boolean;
 613     {* Loads emf or wmf file format from stream. }
 614     function LoadFromFile( const Filename: String ): Boolean;
 615     {* Loads emf or wmf from stream. }
 616     procedure Draw( DC: HDC; X, Y: Integer );
 617     {* Draws enchanced metafile on DC. }
 618     procedure StretchDraw( DC: HDC; const R: TRect );
 619     {* Draws enchanced metafile stretched. }
 620     property Width: Integer read GetWidth;
 621     {* Native width of the metafile. }
 622     property Height: Integer read GetHeight;
 623     {* Native height of the metafile. }
 624   end;
 625 //[END OF TMetafile DEFINITION]
 626
 627 //[NewMetafile DECLARATION]
 628 function NewMetafile: PMetafile;
 629 {* Creates metafile object. }
 630
 631 //[Metafile CONSTANTS, STRUCTURES, ETC.]
 632 const
 633   WMFKey = Integer($9AC6CDD7);
 634   WMFWord = $CDD7;
 635 type
 636   TMetafileHeader = packed record
 637     Key: Longint;
 638     Handle: SmallInt;
 639     Box: TSmallRect;
 640     Inch: Word;
 641     Reserved: Longint;
 642     CheckSum: Word;
 643   end;
 644
 645 function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
 646
 647 {++}(*
 648 function SetEnhMetaFileBits(p1: UINT; p2: PChar): HENHMETAFILE; stdcall;
 649 function PlayEnhMetaFile(DC: HDC; p2: HENHMETAFILE; const p3: TRect): BOOL; stdcall;
 650 *){--}
 651
 652 // NewActionList, TAction - by Yury Sidorov
 653 //[ACTIONS OBJECT]
 654 { ----------------------------------------------------------------------
 655
 656                 TAction and TActionList
 657
 658 ----------------------------------------------------------------------- }
 659 type
 660   PControlRec = ^TControlRec;
 661   TOnUpdateCtrlEvent = procedure(Sender: PControlRec) of object;
 662
 663   TCtrlKind = (ckControl, ckMenu, ckToolbar);
 664   TControlRec = record
 665     Ctrl: PObj;
 666     CtrlKind: TCtrlKind;
 667     ItemID: integer;
 668     UpdateProc: TOnUpdateCtrlEvent;
 669   end;
 670
 671   {++}(* TAction = class;*){--}
 672   PAction = {-}^{+}TAction;
 673
 674   {++}(* TActionList = class;*){--}
 675   PActionList = {-}^{+}TActionList;
 676
 677 //[TAction DEFINITION]
 678   TAction = {-} object( TObj ) {+}{++}(*class*){--}
 679   {*! Use action objects, in conjunction with action lists, to centralize the response
 680       to user commands (actions).
 681       Use AddControl, AddMenuItem, AddToolbarButton methods to link controls to an action.
 682       See also TActionList.
 683       }
 684   protected
 685     FControls: PList;
 686     FCaption: string;
 687     FChecked: boolean;
 688     FVisible: boolean;
 689     FEnabled: boolean;
 690     FHelpContext: integer;
 691     FHint: string;
 692     FOnExecute: TOnEvent;
 693     FAccelerator: TMenuAccelerator;
 694     FShortCut: string;
 695     procedure DoOnMenuItem(Sender: PMenu; Item: Integer);
 696     procedure DoOnToolbarButtonClick(Sender: PControl; BtnID: Integer);
 697     procedure DoOnControlClick(Sender: PObj);
 698
 699     procedure SetCaption(const Value: string);
 700     procedure SetChecked(const Value: boolean);
 701     procedure SetEnabled(const Value: boolean);
 702     procedure SetHelpContext(const Value: integer);
 703     procedure SetHint(const Value: string);
 704     procedure SetVisible(const Value: boolean);
 705     procedure SetAccelerator(const Value: TMenuAccelerator);
 706     procedure UpdateControls;
 707
 708     procedure LinkCtrl(ACtrl: PObj; ACtrlKind: TCtrlKind; AItemID: integer; AUpdateProc: TOnUpdateCtrlEvent);
 709     procedure SetOnExecute(const Value: TOnEvent);
 710
 711     procedure UpdateCtrl(Sender: PControlRec);
 712     procedure UpdateMenu(Sender: PControlRec);
 713     procedure UpdateToolbar(Sender: PControlRec);
 714
 715   public
 716     destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
 717     procedure LinkControl(Ctrl: PControl);
 718     {* Add a link to a TControl or descendant control. }
 719     procedure LinkMenuItem(Menu: PMenu; MenuItemIdx: integer);
 720     {* Add a link to a menu item. }
 721     procedure LinkToolbarButton(Toolbar: PControl; ButtonIdx: integer);
 722     {* Add a link to a toolbar button. }
 723     procedure Execute;
 724     {* Executes a OnExecute event handler. }
 725     property Caption: string read FCaption write SetCaption;
 726     {* Text caption. }
 727     property Hint: string read FHint write SetHint;
 728     {* Hint (tooltip). Currently used for toolbar buttons only. }
 729     property Checked: boolean read FChecked write SetChecked;
 730     {* Checked state. }
 731     property Enabled: boolean read FEnabled write SetEnabled;
 732     {* Enabled state. }
 733     property Visible: boolean read FVisible write SetVisible;
 734     {* Visible state. }
 735     property HelpContext: integer read FHelpContext write SetHelpContext;
 736     {* Help context. }
 737     property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator;
 738     {* Accelerator for menu items. }
 739     property OnExecute: TOnEvent read FOnExecute write SetOnExecute;
 740     {* This event is executed when user clicks on a linked object or Execute method was called. }
 741   end;
 742 //[END OF TAction DEFINITION]
 743
 744 //[TActionList DEFINITION]
 745   TActionList = {-} object( TObj ) {+}{++}(*class*){--}
 746   {*! TActionList maintains a list of actions used with components and controls,
 747      such as menu items and buttons.
 748      Action lists are used, in conjunction with actions, to centralize the response
 749      to user commands (actions).
 750      Write an OnUpdateActions handler to update actions state.
 751      Created using function NewActionList.
 752      See also TAction.
 753   }
 754   protected
 755     FOwner: PControl;
 756     FActions: PList;
 757     FOnUpdateActions: TOnEvent;
 758     function GetActions(Idx: integer): PAction;
 759     function GetCount: integer;
 760   protected
 761     procedure DoUpdateActions(Sender: PObj);
 762   public
 763     destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
 764     function Add(const ACaption, AHint: string; OnExecute: TOnEvent): PAction;
 765     {* Add a new action to the list. Returns pointer to action object. }
 766     procedure Delete(Idx: integer);
 767     {* Delete action by index from list. }
 768     procedure Clear;
 769     {* Clear all actions in the list. }
 770     property Actions[Idx: integer]: PAction read GetActions;
 771     {* Access to actions in the list. }
 772     property Count: integer read GetCount;
 773     {* Number of actions in the list.. }
 774     property OnUpdateActions: TOnEvent read FOnUpdateActions write FOnUpdateActions;
 775     {* Event handler to update actions state. This event is called each time when application
 776       goes in the idle state (no messages in the queue). }
 777   end;
 778 //[END OF TActionList DEFINITION]
 779
 780 //[NewActionList DECLARATION]
 781 function NewActionList(AOwner: PControl): PActionList;
 782 {* Action list constructor. AOwner - owner form. }
 783
 784
 785 implementation
 786
 787 type
 788   PCrackList = ^TCrackList;
 789   TCrackList = object( TList )
 790   end;
 791
 792 {------------------------------------------------------------------------------)
 793 |                                                                              |
 794 |                                  T L i s t E x                               |
 795 |                                                                              |
 796 (------------------------------------------------------------------------------}
 797 { TListEx }
 798
 799 //[function NewListEx]
 800 function NewListEx: PListEx;
 801 begin
 802   {-}
 803   new( Result, Create );
 804   {+}{++}(*Result := PListEx.Create;*){--}
 805   Result.fList := NewList;
 806   Result.fObjects := NewList;
 807 end;
 808 //[END NewListEx]
 809
 810 //[procedure TListEx.Add]
 811 procedure TListEx.Add(Value: Pointer);
 812 begin
 813   AddObj( Value, nil );
 814 end;
 815
 816 //[procedure TListEx.AddObj]
 817 procedure TListEx.AddObj(Value, Obj: Pointer);
 818 var C: Integer;
 819 begin
 820   C := Count;
 821   fList.Add( Value );
 822   fObjects.Insert( C, Obj );
 823 end;
 824
 825 //[procedure TListEx.Clear]
 826 procedure TListEx.Clear;
 827 begin
 828   fList.Clear;
 829   fObjects.Clear;
 830 end;
 831
 832 //[procedure TListEx.Delete]
 833 procedure TListEx.Delete(Idx: Integer);
 834 begin
 835   DeleteRange( Idx, 1 );
 836 end;
 837
 838 //[procedure TListEx.DeleteRange]
 839 procedure TListEx.DeleteRange(Idx, Len: Integer);
 840 begin
 841   fList.DeleteRange( Idx, Len );
 842   fObjects.DeleteRange( Idx, Len );
 843 end;
 844
 845 //[destructor TListEx.Destroy]
 846 destructor TListEx.Destroy;
 847 begin
 848   fList.Free;
 849   fObjects.Free;
 850   inherited;
 851 end;
 852
 853 //[function TListEx.GetAddBy]
 854 function TListEx.GetAddBy: Integer;
 855 begin
 856   Result := fList.AddBy;
 857 end;
 858
 859 //[function TListEx.GetCount]
 860 function TListEx.GetCount: Integer;
 861 begin
 862   Result := fList.Count;
 863 end;
 864
 865 //[function TListEx.GetEx]
 866 function TListEx.GetEx(Idx: Integer): Pointer;
 867 begin
 868   Result := fList.Items[ Idx ];
 869 end;
 870
 871 //[function TListEx.IndexOf]
 872 function TListEx.IndexOf(Value: Pointer): Integer;
 873 begin
 874   Result := fList.IndexOf( Value );
 875 end;
 876
 877 //[function TListEx.IndexOfObj]
 878 function TListEx.IndexOfObj(Obj: Pointer): Integer;
 879 begin
 880   Result := fObjects.IndexOf( Obj );
 881 end;
 882
 883 //[procedure TListEx.Insert]
 884 procedure TListEx.Insert(Idx: Integer; Value: Pointer);
 885 begin
 886   InsertObj( Idx, Value, nil );
 887 end;
 888
 889 //[procedure TListEx.InsertObj]
 890 procedure TListEx.InsertObj(Idx: Integer; Value, Obj: Pointer);
 891 begin
 892   fList.Insert( Idx, Value );
 893   fObjects.Insert( Idx, Obj );
 894 end;
 895
 896 //[function TListEx.Last]
 897 function TListEx.Last: Pointer;
 898 begin
 899   Result := fList.Last;
 900 end;
 901
 902 //[function TListEx.LastObj]
 903 function TListEx.LastObj: Pointer;
 904 begin
 905   Result := fObjects.Last;
 906 end;
 907
 908 //[procedure TListEx.MoveItem]
 909 procedure TListEx.MoveItem(OldIdx, NewIdx: Integer);
 910 begin
 911   fList.MoveItem( OldIdx, NewIdx );
 912   fObjects.MoveItem( OldIdx, NewIdx );
 913 end;
 914
 915 //[procedure TListEx.PutEx]
 916 procedure TListEx.PutEx(Idx: Integer; const Value: Pointer);
 917 begin
 918   fList.Items[ Idx ] := Value;
 919 end;
 920
 921 //[procedure TListEx.Set_AddBy]
 922 procedure TListEx.Set_AddBy(const Value: Integer);
 923 begin
 924   fList.AddBy := Value;
 925   fObjects.AddBy := Value;
 926 end;
 927
 928 //[procedure TListEx.Swap]
 929 procedure TListEx.Swap(Idx1, Idx2: Integer);
 930 begin
 931   fList.Swap( Idx1, Idx2 );
 932   fObjects.Swap( Idx1, Idx2 );
 933 end;
 934
 935 {------------------------------------------------------------------------------)
 936 |                                                                              |
 937 |                                  T B i t s                                   |
 938 |                                                                              |
 939 (------------------------------------------------------------------------------}
 940 { TBits }
 941
 942 //[function NewBits]
 943 function NewBits: PBits;
 944 begin
 945   {-}
 946   new( Result, Create );
 947   {+}{++}(*Result := PBits.Create;*){--}
 948   Result.fList := NewList;
 949   //Result.fList.fAddBy := 1;
 950 end;
 951
 952 //[procedure TBits.AssignBits]
 953 procedure TBits.AssignBits(ToIdx: Integer; FromBits: PBits; FromIdx,
 954   N: Integer);
 955 var i: Integer;
 956     NewCount: Integer;
 957 begin
 958   if FromIdx >= FromBits.Count then Exit;
 959   if FromIdx + N > FromBits.Count then
 960     N := FromBits.Count - FromIdx;
 961   Capacity := (ToIdx + N + 8) div 8;
 962   NewCount := Max( Count, ToIdx + N - 1 );
 963   fCount := Max( NewCount, fCount );
 964   PCrackList( fList ).fCount := (Capacity + 3) div 4;
 965   while ToIdx and $1F <> 0 do
 966   begin
 967     Bits[ ToIdx ] := FromBits.Bits[ FromIdx ];
 968     Inc( ToIdx );
 969     Inc( FromIdx );
 970     Dec( N );
 971     if N = 0 then Exit;
 972   end;
 973   Move( PByte( Integer( PCrackList( FromBits.fList ).fItems ) + (FromIdx + 31) div 32 )^,
 974         PByte( Integer( PCrackList( fList ).fItems ) + ToIdx div 32 )^, (N + 31) div 32 );
 975   FromIdx := FromIdx and $1F;
 976   if FromIdx <> 0 then
 977   begin // shift data by (Idx and $1F) bits right
 978     for i := ToIdx div 32 to fList.Count-2 do
 979       fList.Items[ i ] := Pointer(
 980         (DWORD( fList.Items[ i ] ) shr FromIdx) or
 981         (DWORD( fList.Items[ i+1 ] ) shl (32 - FromIdx))
 982         );
 983     fList.Items[ fList.Count-1 ] := Pointer(
 984       DWORD( fList.Items[ fList.Count-1 ] ) shr FromIdx
 985       );
 986   end;
 987 end;
 988
 989 //[function TBits.Copy]
 990 procedure TBits.Clear;
 991 begin
 992   fCount := 0;
 993   fList.Clear;
 994 end;
 995
 996 function TBits.Copy(From, BitsCount: Integer): PBits;
 997 var Shift, N: Integer;
 998     FirstItemPtr: Pointer;
 999 begin
1000   Result := NewBits;
1001   if BitsCount = 0 then Exit;
1002   Result.Capacity := BitsCount + 32;
1003   Result.fCount := BitsCount;
1004   Move( PCrackList( fList ).fItems[ From shr 5 ],
1005         PCrackList( Result.fList ).fItems[ 0 ], (Count + 31) div 32 );
1006   Shift := From and $1F;
1007   if Shift <> 1 then
1008   begin
1009     N := (BitsCount + 31) div 32;
1010     FirstItemPtr := @ PCrackList( Result.fList ).fItems[ N - 1 ];
1011     asm
1012           PUSH  ESI
1013           PUSH  EDI
1014           MOV   ESI, FirstItemPtr
1015           MOV   EDI, ESI
1016           STD
1017           MOV   ECX, N
1018           XOR   EAX, EAX
1019           CDQ
1020     @@1:
1021           PUSH  ECX
1022           LODSD
1023           MOV   ECX, Shift
1024           SHRD  EAX, EDX, CL
1025           STOSD
1026           SUB   ECX, 32
1027           NEG   ECX
1028           SHR   EDX, CL
1029           POP   ECX
1030
1031           LOOP  @@1
1032
1033           CLD
1034           POP   EDI
1035           POP   ESI
1036     end {$IFDEF F_P} ['EAX','EDX','ECX'] {$ENDIF};
1037   end;
1038 end;
1039
1040 //[destructor TBits.Destroy]
1041 destructor TBits.Destroy;
1042 begin
1043   fList.Free;
1044   inherited;
1045 end;
1046
1047 //[function TBits.GetBit]
1048 {$IFDEF ASM_VERSION}
1049 function TBits.GetBit(Idx: Integer): Boolean;
1050 asm
1051   CMP  EDX, [EAX].FCount
1052   JL   @@1
1053   XOR  EAX, EAX
1054   RET
1055 @@1:
1056   MOV  EAX, [EAX].fList
1057   {TEST EAX, EAX
1058   JZ   @@exit}
1059   MOV  EAX, [EAX].TList.fItems
1060   BT   [EAX], EDX
1061   SETC AL
1062 @@exit:
1063 end;
1064 {$ELSE}
1065 function TBits.GetBit(Idx: Integer): Boolean;
1066 begin
1067   if (Idx >= Count) {or (PCrackList( fList ).fItems = nil)} then Result := FALSE else
1068   Result := ( ( DWORD( PCrackList( fList ).fItems[ Idx shr 5 ] ) shr (Idx and $1F)) and 1 ) <> 0;
1069 end;
1070 {$ENDIF}
1071
1072 //[function TBits.GetCapacity]
1073 function TBits.GetCapacity: Integer;
1074 begin
1075   Result := fList.Capacity * 32;
1076 end;
1077
1078 //[function TBits.GetSize]
1079 function TBits.GetSize: Integer;
1080 begin
1081   Result := ( PCrackList( fList ).fCount + 3) div 4;
1082 end;
1083
1084 {$IFDEF ASM_noVERSION}
1085 //[function TBits.IndexOf]
1086 function TBits.IndexOf(Value: Boolean): Integer;
1087 asm     //cmd    //opd
1088         PUSH     EDI
1089         MOV      EDI, [EAX].fList
1090         MOV      ECX, [EDI].TList.fCount
1091 @@ret_1:
1092         OR       EAX, -1
1093         JECXZ    @@ret_EAX
1094         MOV      EDI, [EDI].TList.fItems
1095         TEST     DL, DL
1096         MOV      EDX, EDI
1097         JE       @@of_false
1098         INC      EAX
1099         REPZ     SCASD
1100         JE       @@ret_1
1101         MOV      EAX, [EDI-4]
1102         NOT      EAX
1103         JMP      @@calc_offset
1104         BSF      EAX, EAX
1105         SUB      EDI, EDX
1106         SHR      EDI, 2
1107         ADD      EAX, EDI
1108         JMP      @@ret_EAX
1109 @@of_false:
1110         REPE     SCASD
1111         JE       @@ret_1
1112         MOV      EAX, [EDI-4]
1113 @@calc_offset:
1114         BSF      EAX, EAX
1115         DEC      EAX
1116         SUB      EDI, 4
1117         SUB      EDI, EDX
1118         SHL      EDI, 3
1119         ADD      EAX, EDI
1120 @@ret_EAX:
1121         POP      EDI
1122 end;
1123 {$ELSE ASM_VERSION} //Pascal
1124 function TBits.IndexOf(Value: Boolean): Integer;
1125 var I: Integer;
1126     D: DWORD;
1127 begin
1128   Result := -1;
1129   if Value then
1130   begin
1131     for I := 0 to fList.Count-1 do
1132     begin
1133       D := DWORD( PCrackList( fList ).fItems[ I ] );
1134       if D <> 0 then
1135       begin
1136         asm
1137           MOV  EAX, D
1138           BSF  EAX, EAX
1139           MOV  D, EAX
1140         end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};
1141         Result := I * 32 + Integer( D );
1142         break;
1143       end;
1144     end;
1145   end
1146     else
1147   begin
1148     for I := 0 to PCrackList( fList ).fCount-1 do
1149     begin
1150       D := DWORD( PCrackList( fList ).fItems[ I ] );
1151       if D <> $FFFFFFFF then
1152       begin
1153         asm
1154           MOV  EAX, D
1155           NOT  EAX
1156           BSF  EAX, EAX
1157           MOV  D, EAX
1158         end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};
1159         Result := I * 32 + Integer( D );
1160         break;
1161       end;
1162     end;
1163   end;
1164 end;
1165 {$ENDIF ASM_VERSION}
1166
1167 //[function TBits.LoadFromStream]
1168 function TBits.LoadFromStream(strm: PStream): Integer;
1169 var
1170  i: Integer;
1171 begin
1172  Result := strm.Read( i, 4 );
1173  if Result < 4 then Exit;
1174
1175  bits[ i]:= false; //by miek
1176  fcount:= i;
1177
1178  i := (i + 7) div 8;
1179  Inc( Result, strm.Read( PCrackList( fList ).fItems^, i ) );
1180 end;
1181
1182 //[function TBits.OpenBit]
1183 function TBits.OpenBit: Integer;
1184 begin
1185   Result := IndexOf( FALSE );
1186   if Result < 0 then Result := Count;
1187 end;
1188
1189 //[function TBits.Range]
1190 function TBits.Range(Idx, N: Integer): PBits;
1191 begin
1192   Result := NewBits;
1193   Result.AssignBits( 0, @ Self, Idx, N );
1194 end;
1195
1196 //[function TBits.SaveToStream]
1197 function TBits.SaveToStream(strm: PStream): Integer;
1198 begin
1199   Result := strm.Write( fCount, 4 );
1200   if fCount = 0 then Exit;
1201   Inc( Result, strm.Write( PCrackList( fList ).fItems^, (fCount + 7) div 8 ) );
1202 end;
1203
1204 //[procedure TBits.SetBit]
1205 {$IFDEF ASM_VERSION}
1206 procedure TBits.SetBit(Idx: Integer; const Value: Boolean);
1207 asm
1208   PUSH ECX
1209   MOV  ECX, [EAX].fList
1210   MOV  ECX, [ECX].TList.fCapacity
1211   SHL  ECX, 5
1212   CMP  EDX, ECX
1213   JLE  @@1
1214
1215   PUSH EDX
1216   INC  EDX
1217   PUSH EAX
1218   CALL SetCapacity
1219   POP  EAX
1220   POP  EDX
1221
1222 @@1:
1223   CMP  EDX, [EAX].FCount
1224   JL   @@2
1225   INC  EDX
1226   MOV  [EAX].fCount, EDX
1227   DEC  EDX
1228 @@2:
1229   POP  ECX
1230   MOV  EAX, [EAX].fList
1231   MOV  EAX, [EAX].TList.fItems
1232   SHR  ECX, 1
1233   JC   @@2set
1234   BTR  [EAX], EDX
1235   JMP  @@exit
1236 @@2set:
1237   BTS  [EAX], EDX
1238 @@exit:
1239 end;
1240 {$ELSE}
1241 procedure TBits.SetBit(Idx: Integer; const Value: Boolean);
1242 var Msk: DWORD;
1243 begin
1244   if Idx >= Capacity then
1245     Capacity := Idx + 1;
1246   Msk := 1 shl (Idx and $1F);
1247   if Value then
1248     PCrackList( fList ).fItems[ Idx shr 5 ] := Pointer(
1249                   DWORD(PCrackList( fList ).fItems[ Idx shr 5 ]) or Msk)
1250   else
1251     PCrackList( fList ).fItems[ Idx shr 5 ] := Pointer(
1252                   DWORD(PCrackList( fList ).fItems[ Idx shr 5 ]) and not Msk);
1253   if Idx >= fCount then
1254     fCount := Idx + 1;
1255 end;
1256 {$ENDIF}
1257
1258 //[procedure TBits.SetCapacity]
1259 procedure TBits.SetCapacity(const Value: Integer);
1260 var OldCap: Integer;
1261 begin
1262   OldCap := fList.Capacity;
1263   fList.Capacity := (Value + 31) div 32;
1264   if OldCap < fList.Capacity then
1265     FillChar( PChar( Integer( PCrackList( fList ).fItems ) + OldCap * Sizeof( Pointer ) )^,
1266               (fList.Capacity - OldCap) * sizeof( Pointer ), 0 );
1267 end;
1268
1269 {------------------------------------------------------------------------------)
1270 |                                                                              |
1271 |                         T F a s t S t r L i s t                              |
1272 |                                                                              |
1273 (------------------------------------------------------------------------------}
1274
1275 function NewFastStrListEx: PFastStrListEx;
1276 begin
1277   new( Result, Create );
1278 end;
1279
1280 procedure InitUpper;
1281 var c: Char;
1282 begin
1283   for c := #0 to #255 do
1284     Upper[ c ] := AnsiUpperCase( c + #0 )[ 1 ];
1285   Upper_Initialized := TRUE;
1286 end;
1287
1288 { TFastStrListEx }
1289
1290 function TFastStrListEx.AddAnsi(const S: String): Integer;
1291 begin
1292   Result := AddObjectLen( PChar( S ), Length( S ), 0 );
1293 end;
1294
1295 function TFastStrListEx.AddAnsiObject(const S: String; Obj: DWORD): Integer;
1296 begin
1297   Result := AddObjectLen( PChar( S ), Length( S ), Obj );
1298 end;
1299
1300 function TFastStrListEx.Add(S: PChar): integer;
1301 begin
1302   Result := AddObjectLen( S, StrLen( S ), 0 )
1303 end;
1304
1305 function TFastStrListEx.AddLen(S: PChar; Len: Integer): integer;
1306 begin
1307   Result := AddObjectLen( S, Len, 0 )
1308 end;
1309
1310 function TFastStrListEx.AddObject(S: PChar; Obj: DWORD): Integer;
1311 begin
1312   Result := AddObjectLen( S, StrLen( S ), Obj )
1313 end;
1314
1315 function TFastStrListEx.AddObjectLen(S: PChar; Len: Integer; Obj: DWORD): Integer;
1316 var Dest: PChar;
1317 begin
1318   ProvideSpace( Len + 9 );
1319   Dest := PChar( DWORD( fTextBuf ) + fUsedSiz );
1320   Result := fCount;
1321   Inc( fCount );
1322   fList.Add( Pointer( DWORD(Dest)-DWORD(fTextBuf) ) );
1323   PDWORD( Dest )^ := Obj;
1324   Inc( Dest, 4 );
1325   PDWORD( Dest )^ := Len;
1326   Inc( Dest, 4 );
1327   if S <> nil then
1328     System.Move( S^, Dest^, Len );
1329   Inc( Dest, Len );
1330   Dest^ := #0;
1331   Inc( fUsedSiz, Len+9 );
1332 end;
1333
1334 function TFastStrListEx.AppendToFile(const FileName: string): Boolean;
1335 var F: HFile;
1336     Txt: String;
1337 begin
1338   Txt := Text;
1339   F := FileCreate( FileName, ofOpenAlways or ofOpenReadWrite or ofShareDenyWrite );
1340   if F = INVALID_HANDLE_VALUE then Result := FALSE
1341   else begin
1342          FileSeek( F, 0, spEnd );
1343          Result := FileWrite( F, PChar( Txt )^, Length( Txt ) ) = DWORD( Length( Txt ) );
1344          FileClose( F );
1345        end;
1346 end;
1347
1348 procedure TFastStrListEx.Clear;
1349 begin
1350   if FastClear then
1351   begin
1352     if fList.Count > 0 then
1353       PCrackList(fList).FCount := 0;
1354   end
1355     else
1356   begin
1357     fList.Clear;
1358     if fTextBuf <> nil then
1359       FreeMem( fTextBuf );
1360     fTextBuf := nil;
1361   end;
1362   fTextSiz := 0;
1363   fUsedSiz := 0;
1364   fCount := 0;
1365 end;
1366
1367 procedure TFastStrListEx.Delete(Idx: integer);
1368 begin
1369   if (Idx < 0) or (Idx >= Count) then Exit;
1370   if Idx = Count-1 then
1371     Dec( fUsedSiz, ItemLen[ Idx ]+9 );
1372   fList.Delete( Idx );
1373   Dec( fCount );
1374 end;
1375
1376 destructor TFastStrListEx.Destroy;
1377 begin
1378   FastClear := FALSE;
1379   Clear;
1380   fList.Free;
1381   inherited;
1382 end;
1383
1384 function TFastStrListEx.Find(const S: String; var Index: Integer): Boolean;
1385 var i: Integer;
1386 begin
1387   for i := 0 to Count-1 do
1388     if (ItemLen[ i ] = Length( S )) and
1389        ((S = '') or CompareMem( ItemPtrs[ i ], @ S[ 1 ], Length( S ) )) then
1390        begin
1391          Index := i;
1392          Result := TRUE;
1393          Exit;
1394        end;
1395   Result := FALSE;
1396 end;
1397
1398 function TFastStrListEx.Get(Idx: integer): string;
1399 begin
1400   if (Idx >= 0) and (Idx <= Count) then
1401     SetString( Result, PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 8 ),
1402                ItemLen[ Idx ] )
1403   else
1404     Result := '';
1405 end;
1406
1407 function TFastStrListEx.GetItemLen(Idx: Integer): Integer;
1408 var Src: PDWORD;
1409 begin
1410   if (Idx >= 0) and (Idx <= Count) then
1411   begin
1412     Src := PDWORD( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 4 );
1413     Result := Src^
1414   end
1415     else Result := 0;
1416 end;
1417
1418 function TFastStrListEx.GetObject(Idx: Integer): DWORD;
1419 var Src: PDWORD;
1420 begin
1421   if (Idx >= 0) and (Idx <= Count) then
1422   begin
1423     Src := PDWORD( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) );
1424     Result := Src^
1425   end
1426     else Result := 0;
1427 end;
1428
1429 function TFastStrListEx.GetPChars(Idx: Integer): PChar;
1430 begin
1431   if (Idx >= 0) and (Idx <= Count) then
1432     Result := PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 8 )
1433   else Result := nil;
1434 end;
1435
1436 function TFastStrListEx.GetTextStr: string;
1437 var L, i: Integer;
1438     p: PChar;
1439 begin
1440   L := 0;
1441   for i := 0 to Count-1 do
1442     Inc( L, ItemLen[ i ] + 2 );
1443   SetLength( Result, L );
1444   p := PChar( Result );
1445   for i := 0 to Count-1 do
1446   begin
1447     L := ItemLen[ i ];
1448     if L > 0 then
1449     begin
1450       System.Move( ItemPtrs[ i ]^, p^, L );
1451       Inc( p, L );
1452     end;
1453     p^ := #13; Inc( p );
1454     p^ := #10; Inc( p );
1455   end;
1456 end;
1457
1458 function TFastStrListEx.IndexOf(const S: string): integer;
1459 begin
1460   if not Find( S, Result ) then Result := -1;
1461 end;
1462
1463 function TFastStrListEx.IndexOf_NoCase(const S: string): integer;
1464 begin
1465   Result := IndexOfStrL_NoCase( PChar( S ), Length( S ) );
1466 end;
1467
1468 function TFastStrListEx.IndexOfStrL_NoCase(Str: PChar;
1469   L: Integer): integer;
1470 var i: Integer;
1471 begin
1472   for i := 0 to Count-1 do
1473     if (ItemLen[ i ] = L) and
1474        ((L = 0) or (StrLComp_NoCase( ItemPtrs[ i ], Str, L ) = 0)) then
1475        begin
1476          Result := i;
1477          Exit;
1478        end;
1479   Result := -1;
1480 end;
1481
1482 procedure TFastStrListEx.Init;
1483 begin
1484   fList := NewList;
1485   FastClear := TRUE;
1486 end;
1487
1488 procedure TFastStrListEx.InsertAnsi(Idx: integer; const S: String);
1489 begin
1490   InsertObjectLen( Idx, PChar( S ), Length( S ), 0 );
1491 end;
1492
1493 procedure TFastStrListEx.InsertAnsiObject(Idx: integer; const S: String;
1494   Obj: DWORD);
1495 begin
1496   InsertObjectLen( Idx, PChar( S ), Length( S ), Obj );
1497 end;
1498
1499 procedure TFastStrListEx.Insert(Idx: integer; S: PChar);
1500 begin
1501   InsertObjectLen( Idx, S, StrLen( S ), 0 )
1502 end;
1503
1504 procedure TFastStrListEx.InsertLen(Idx: Integer; S: PChar; Len: Integer);
1505 begin
1506   InsertObjectLen( Idx, S, Len, 0 )
1507 end;
1508
1509 procedure TFastStrListEx.InsertObject(Idx: Integer; S: PChar; Obj: DWORD);
1510 begin
1511   InsertObjectLen( Idx, S, StrLen( S ), Obj );
1512 end;
1513
1514 procedure TFastStrListEx.InsertObjectLen(Idx: Integer; S: PChar;
1515   Len: Integer; Obj: DWORD);
1516 var Dest: PChar;
1517 begin
1518   ProvideSpace( Len+9 );
1519   Dest := PChar( DWORD( fTextBuf ) + fUsedSiz );
1520   fList.Insert( Idx, Pointer( DWORD(Dest)-DWORD(fTextBuf) ) );
1521   PDWORD( Dest )^ := Obj;
1522   Inc( Dest, 4 );
1523   PDWORD( Dest )^ := Len;
1524   Inc( Dest, 4 );
1525   if S <> nil then
1526     System.Move( S^, Dest^, Len );
1527   Inc( Dest, Len );
1528   Dest^ := #0;
1529   Inc( fUsedSiz, Len+9 );
1530   Inc( fCount );
1531 end;
1532
1533 function TFastStrListEx.Last: String;
1534 begin
1535   if Count > 0 then
1536     Result := Items[ Count-1 ]
1537   else
1538     Result := '';
1539 end;
1540
1541 function TFastStrListEx.LoadFromFile(const FileName: string): Boolean;
1542 var Strm: PStream;
1543 begin
1544   Strm := NewReadFileStream( FileName );
1545   TRY
1546     Result := Strm.Handle <> INVALID_HANDLE_VALUE;
1547     if Result then
1548       LoadFromStream( Strm, FALSE )
1549     else
1550       Clear;
1551   FINALLY
1552     Strm.Free;
1553   END;
1554 end;
1555
1556 procedure TFastStrListEx.LoadFromStream(Stream: PStream;
1557   Append2List: boolean);
1558 var Txt: String;
1559 begin
1560   SetLength( Txt, Stream.Size - Stream.Position );
1561   Stream.Read( Txt[ 1 ], Stream.Size - Stream.Position );
1562   SetText( Txt, Append2List );
1563 end;
1564
1565 procedure TFastStrListEx.MergeFromFile(const FileName: string);
1566 var Strm: PStream;
1567 begin
1568   Strm := NewReadFileStream( FileName );
1569   TRY
1570     LoadFromStream( Strm, TRUE );
1571   FINALLY
1572     Strm.Free;
1573   END;
1574 end;
1575
1576 procedure TFastStrListEx.Move(CurIndex, NewIndex: integer);
1577 begin
1578   Assert( (CurIndex >= 0) and (CurIndex < Count) and (NewIndex >= 0) and
1579           (NewIndex < Count), 'Item indexes violates TFastStrListEx range' );
1580   fList.MoveItem( CurIndex, NewIndex );
1581 end;
1582
1583 procedure TFastStrListEx.ProvideSpace(AddSize: DWORD);
1584 var OldTextBuf: PChar;
1585 begin
1586   Inc( AddSize, 9 );
1587   if AddSize > fTextSiz - fUsedSiz then
1588   begin // óâåëè÷åíèå ðàçìåðà áóôåðà
1589     fTextSiz := Max( 1024, (fUsedSiz + AddSize) * 2 );
1590     OldTextBuf := fTextBuf;
1591     GetMem( fTextBuf, fTextSiz );
1592     if OldTextBuf <> nil then
1593     begin
1594       System.Move( OldTextBuf^, fTextBuf^, fUsedSiz );
1595       FreeMem( OldTextBuf );
1596     end;
1597   end;
1598   if fList.Count >= fList.Capacity then
1599     fList.Capacity := Max( 100, fList.Count * 2 );
1600 end;
1601
1602 procedure TFastStrListEx.Put(Idx: integer; const Value: string);
1603 var Dest: PChar;
1604     OldLen: Integer;
1605     OldObj: DWORD;
1606 begin
1607   OldLen := ItemLen[ Idx ];
1608   if Length( Value ) <= OldLen then
1609   begin
1610     Dest := PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 4 );
1611     PDWORD( Dest )^ := Length( Value );
1612     Inc( Dest, 4 );
1613     if Value <> '' then
1614       System.Move( Value[ 1 ], Dest^, Length( Value ) );
1615     Inc( Dest, Length( Value ) );
1616     Dest^ := #0;
1617     if Idx = Count-1 then
1618       Dec( fUsedSiz, OldLen - Length( Value ) );
1619   end
1620     else
1621   begin
1622     OldObj := 0;
1623     while Idx > Count do
1624       AddObjectLen( nil, 0, 0 );
1625     if Idx = Count-1 then
1626     begin
1627       OldObj := Objects[ Idx ];
1628       Delete( Idx );
1629     end;
1630     if Idx = Count then
1631       AddObjectLen( PChar( Value ), Length( Value ), OldObj )
1632     else
1633     begin
1634       ProvideSpace( Length( Value ) + 9 );
1635       Dest := PChar( DWORD( fTextBuf ) + fUsedSiz );
1636       fList.Items[ Idx ] := Pointer( DWORD(Dest)-DWORD(fTextBuf) );
1637       Inc( Dest, 4 );
1638       PDWORD( Dest )^ := Length( Value );
1639       Inc( Dest, 4 );
1640       if Value <> '' then
1641         System.Move( Value[ 1 ], Dest^, Length( Value ) );
1642       Inc( Dest, Length( Value ) );
1643       Dest^ := #0;
1644       Inc( fUsedSiz, Length( Value )+9 );
1645     end;
1646   end;
1647 end;
1648
1649 function TFastStrListEx.SaveToFile(const FileName: string): Boolean;
1650 var Strm: PStream;
1651 begin
1652   Strm := NewWriteFileStream( FileName );
1653   TRY
1654     if Strm.Handle <> INVALID_HANDLE_VALUE then
1655     SaveToStream( Strm );
1656     Result := TRUE;
1657   FINALLY
1658     Strm.Free;
1659   END;
1660 end;
1661
1662 procedure TFastStrListEx.SaveToStream(Stream: PStream);
1663 var Txt: String;
1664 begin
1665   Txt := Text;
1666   Stream.Write( PChar( Txt )^, Length( Txt ) );
1667 end;
1668
1669 procedure TFastStrListEx.SetObject(Idx: Integer; const Value: DWORD);
1670 var Dest: PDWORD;
1671 begin
1672   if Idx < 0 then Exit;
1673   while Idx >= Count do
1674     AddObjectLen( nil, 0, 0 );
1675   Dest := PDWORD( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) );
1676   Dest^ := Value;
1677 end;
1678
1679 procedure TFastStrListEx.SetText(const S: string; Append2List: boolean);
1680 var Len2Add, NLines, L: Integer;
1681     p0, p: PChar;
1682 begin
1683   if not Append2List then Clear;
1684   // ïîäñ÷åò òðåáóåìîãî ïðîñòðàíñòâà
1685   Len2Add := 0;
1686   NLines := 0;
1687   p := Pchar( S );
1688   p0 := p;
1689   L := Length( S );
1690   while L > 0 do
1691   begin
1692     if p^ = #13 then
1693     begin
1694       Inc( NLines );
1695       Inc( Len2Add, 9 + DWORD(p)-DWORD(p0) );
1696       REPEAT Inc( p ); Dec( L );
1697       UNTIL  (p^ <> #10) or (L = 0);
1698       p0 := p;
1699     end
1700       else
1701     begin
1702       Inc( p ); Dec( L );
1703     end;
1704   end;
1705   if DWORD(p) > DWORD(p0) then
1706   begin
1707     Inc( NLines );
1708     Inc( Len2Add, 9 + DWORD(p)-DWORD(p0) );
1709   end;
1710   if Len2Add = 0 then Exit;
1711   // äîáàâëåíèå
1712   ProvideSpace( Len2Add - 9 );
1713   if fList.Capacity <= fList.Count + NLines then
1714     fList.Capacity := Max( (fList.Count + NLines) * 2, 100 );
1715   p := PChar( S );
1716   p0 := p;
1717   L := Length( S );
1718   while L > 0 do
1719   begin
1720     if p^ = #13 then
1721     begin
1722       AddObjectLen( p0, DWORD(p)-DWORD(p0), 0 );
1723       REPEAT Inc( p ); Dec( L );
1724       UNTIL  (p^ <> #10) or (L = 0);
1725       p0 := p;
1726     end
1727       else
1728     begin
1729       Inc( p ); Dec( L );
1730     end;
1731   end;
1732   if DWORD(p) > DWORD(p0) then
1733     AddObjectLen( p0, DWORD(p)-DWORD(p0), 0 );
1734 end;
1735
1736 procedure TFastStrListEx.SetTextStr(const Value: string);
1737 begin
1738   SetText( Value, FALSE );
1739 end;
1740
1741 function CompareFast(const Data: Pointer; const e1,e2 : Dword) : Integer;
1742 var FSL: PFastStrListEx;
1743     L1, L2: Integer;
1744     S1, S2: PChar;
1745 begin
1746   FSL := Data;
1747   S1 := FSL.ItemPtrs[ e1 ];
1748   S2 := FSL.ItemPtrs[ e2 ];
1749   L1 := FSL.ItemLen[ e1 ];
1750   L2 := FSL.ItemLen[ e2 ];
1751   if FSL.fCaseSensitiveSort then
1752     Result := StrLComp( S1, S2, Min( L1, L2 ) )
1753   else
1754     Result := StrLComp_NoCase( S1, S2, Min( L1, L2 ) );
1755   if Result = 0 then
1756     Result := L1 - L2;
1757   if Result = 0 then
1758     Result := e1 - e2;
1759 end;
1760
1761 procedure SwapFast(const Data : Pointer; const e1,e2 : Dword);
1762 var FSL: PFastStrListEx;
1763 begin
1764   FSL := Data;
1765   FSL.Swap( e1, e2 );
1766 end;
1767
1768 procedure TFastStrListEx.Sort(CaseSensitive: Boolean);
1769 begin
1770   fCaseSensitiveSort := CaseSensitive;
1771   SortData( @ Self, Count, CompareFast, SwapFast );
1772 end;
1773
1774 procedure TFastStrListEx.Swap(Idx1, Idx2: Integer);
1775 begin
1776   Assert( (Idx1 >= 0) and (Idx1 <= Count-1) and (Idx2 >= 0) and (Idx2 <= Count-1),
1777           'Item indexes violates TFastStrListEx range' );
1778   fList.Swap( Idx1, Idx2 );
1779 end;
1780
1781 function TFastStrListEx.GetValues(AName: PChar): PChar;
1782 var i: Integer;
1783     s, n: PChar;
1784 begin
1785   if not Upper_Initialized then
1786     InitUpper;
1787   for i := 0 to Count-1 do
1788   begin
1789     s := ItemPtrs[ i ];
1790     n := AName;
1791     while (Upper[ s^ ] = Upper[ n^ ]) and (s^ <> '=') and (s^ <> #0) and (n^ <> #0) do
1792     begin
1793       Inc( s );
1794       Inc( n );
1795     end;
1796     if (s^ = '=') and (n^ = #0) then
1797     begin
1798       Result := s;
1799       Inc( Result );
1800       Exit;
1801     end;
1802   end;
1803   Result := nil;
1804 end;
1805
1806 function TFastStrListEx.IndexOfName(AName: PChar): Integer;
1807 var i: Integer;
1808     s, n: PChar;
1809 begin
1810   if not Upper_Initialized then
1811     InitUpper;
1812   for i := 0 to Count-1 do
1813   begin
1814     s := ItemPtrs[ i ];
1815     n := AName;
1816     while (Upper[ s^ ] = Upper[ n^ ]) and (s^ <> '=') and (s^ <> #0) and (n^ <> #0) do
1817     begin
1818       Inc( s );
1819       Inc( n );
1820     end;
1821     if (s^ = '=') and (n^ = #0) then
1822     begin
1823       Result := i;
1824       Exit;
1825     end;
1826   end;
1827   Result := -1;
1828 end;
1829
1830 procedure TFastStrListEx.Append(S: PChar);
1831 begin
1832   AppendLen( S, StrLen( S ) );
1833 end;
1834
1835 procedure TFastStrListEx.AppendInt2Hex(N: DWORD; MinDigits: Integer);
1836 var Buffer: array[ 0..9 ] of Char;
1837     Mask: DWORD;
1838     i, Len: Integer;
1839     B: Byte;
1840 begin
1841   if MinDigits > 8 then
1842     MinDigits := 8;
1843   if MinDigits <= 0 then
1844     MinDigits := 1;
1845   Mask := $F0000000;
1846   for i := 8 downto MinDigits do
1847   begin
1848     if Mask and N <> 0 then
1849     begin
1850       MinDigits := i;
1851       break;
1852     end;
1853     Mask := Mask shr 4;
1854   end;
1855   i := 0;
1856   Len := MinDigits;
1857   Mask := $F shl ((Len - 1)*4);
1858   while MinDigits > 0 do
1859   begin
1860     Dec( MinDigits );
1861     B := (N and Mask) shr (MinDigits * 4);
1862     Mask := Mask shr 4;
1863     if B <= 9 then
1864       Buffer[ i ] := Char( B + Ord( '0' ) )
1865     else
1866       Buffer[ i ] := Char( B + Ord( 'A' ) - 10 );
1867     Inc( i );
1868   end;
1869   Buffer[ i ] := #0;
1870   AppendLen( @ Buffer[ 0 ], Len );
1871 end;
1872
1873 procedure TFastStrListEx.AppendLen(S: PChar; Len: Integer);
1874 var Dest: PChar;
1875 begin
1876   if Count = 0 then
1877     AddLen( S, Len )
1878   else
1879   begin
1880     ProvideSpace( Len );
1881     Dest := PChar( DWORD( fTextBuf ) + fUsedSiz - 1 );
1882     System.Move( S^, Dest^, Len );
1883     Inc( Dest, Len );
1884     Dest^ := #0;
1885     Inc( fUsedSiz, Len );
1886     Dest := PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Count-1 ] ) );
1887     Inc( Dest, 4 );
1888     PDWORD( Dest )^ := PDWORD( Dest )^ + DWORD( Len );
1889   end;
1890 end;
1891
1892 {-}
1893 //[procedure WStrCopy]
1894 procedure WStrCopy( Dest, Src: PWideChar );
1895 asm
1896         PUSH    EDI
1897         PUSH    ESI
1898         MOV     ESI,EAX
1899         MOV     EDI,EDX
1900         OR      ECX, -1
1901         XOR     EAX, EAX
1902         REPNE   SCASW
1903         NOT     ECX
1904         MOV     EDI,ESI
1905         MOV     ESI,EDX
1906         REP     MOVSW
1907         POP     ESI
1908         POP     EDI
1909 end;
1910
1911 //[function WStrCmp]
1912 function WStrCmp( W1, W2: PWideChar ): Integer;
1913 asm
1914          PUSH     ESI
1915          PUSH     EDI
1916          XCHG     ESI, EAX
1917          MOV      EDI, EDX
1918          XOR      EAX, EAX
1919          CWDE
1920 @@loop:  LODSW
1921          MOV      DX, [EDI]
1922          INC      EDI
1923          INC      EDI
1924          CMP      EAX, EDX
1925          JNE      @@exit
1926          TEST     EAX, EAX
1927          JNZ      @@loop
1928 @@exit:  SUB      EAX, EDX
1929          POP      EDI
1930          POP      ESI
1931 end;
1932
1933 {------------------------------------------------------------------------------)
1934 |                                                                              |
1935 |                         T W S t r L i s t                                    |
1936 |                                                                              |
1937 (------------------------------------------------------------------------------}
1938
1939 {$IFNDEF _D2}
1940
1941 //[function NewWStrList]
1942 function NewWStrList: PWStrList;
1943 begin
1944   new( Result, Create );
1945 end;
1946
1947 { TWStrList }
1948
1949 //[function TWStrList.Add]
1950 function TWStrList.Add(const W: WideString): Integer;
1951 begin
1952   Result := Count;
1953   Insert( Result, W );
1954 end;
1955
1956 //[procedure TWStrList.AddWStrings]
1957 procedure TWStrList.AddWStrings(WL: PWStrList);
1958 begin
1959   Text := Text + WL.Text;
1960 end;
1961
1962 //[function TWStrList.AppendToFile]
1963 function TWStrList.AppendToFile(const Filename: String): Boolean;
1964 var Strm: PStream;
1965 begin
1966   Strm := NewReadWriteFileStream( Filename );
1967   Result := Strm.Handle <> INVALID_HANDLE_VALUE;
1968   if Result then
1969   begin
1970     Strm.Position := Strm.Size;
1971     SaveToStream( Strm );
1972   end;
1973   Strm.Free;
1974 end;
1975
1976 //[procedure TWStrList.Assign]
1977 procedure TWStrList.Assign(WL: PWStrList);
1978 begin
1979   Text := WL.Text;
1980 end;
1981
1982 //[procedure TWStrList.Clear]
1983 procedure TWStrList.Clear;
1984 var I: Integer;
1985     P: Pointer;
1986 begin
1987   for I := 0 to Count-1 do
1988   begin
1989     P := fList.Items[ I ];
1990     if P <> nil then
1991     if not( (P >= fText) and (P <= fText + fTextBufSz) ) then
1992       FreeMem( P );
1993   end;
1994   if fText <> nil then
1995     FreeMem( fText );
1996   fText := nil;
1997   fTextBufSz := 0;
1998   fList.Clear;
1999 end;
2000
2001 //[procedure TWStrList.Delete]
2002 procedure TWStrList.Delete(Idx: Integer);
2003 var P: Pointer;
2004 begin
2005   P := fList.Items[ Idx ];
2006   if P <> nil then
2007   if not( (P >= fText) and (P <= fText + fTextBufSz) ) then
2008     FreeMem( P );
2009   fList.Delete( Idx );
2010 end;
2011
2012 //[destructor TWStrList.Destroy]
2013 destructor TWStrList.Destroy;
2014 begin
2015   Clear;
2016   fList.Free;
2017   inherited;
2018 end;
2019
2020 //[function TWStrList.GetCount]
2021 function TWStrList.GetCount: Integer;
2022 begin
2023   Result := fList.Count;
2024 end;
2025
2026 //[function TWStrList.GetItems]
2027 function TWStrList.GetItems(Idx: Integer): WideString;
2028 begin
2029   Result := PWideChar( fList.Items[ Idx ] );
2030 end;
2031
2032 //[function TWStrList.GetPtrs]
2033 function TWStrList.GetPtrs(Idx: Integer): PWideChar;
2034 begin
2035   Result := fList.Items[ Idx ];
2036 end;
2037
2038 //[function TWStrList.GetText]
2039 function TWStrList.GetText: WideString;
2040 const
2041     EoL: array[ 0..5 ] of Char = ( #13, #0, #10, #0, #0, #0 );
2042 var L, I: Integer;
2043     P, Dest: Pointer;
2044 begin
2045   L := 0;
2046   for I := 0 to Count-1 do
2047   begin
2048     P := fList.Items[ I ];
2049     if P <> nil then
2050       L := L + WStrLen( P ) + 2
2051     else
2052       L := L + 2;
2053   end;
2054   SetLength( Result, L );
2055   Dest := PWideChar( Result );
2056   for I := 0 to Count-1 do
2057   begin
2058     P := fList.Items[ I ];
2059     if P <> nil then
2060     begin
2061       WStrCopy( Dest, P );
2062       Dest := Pointer( Integer( Dest ) + WStrLen( P ) * 2 );
2063     end;
2064     WStrCopy( Dest, Pointer( @ EoL[ 0 ] ) );
2065     Dest := Pointer( Integer( Dest ) + 4 );
2066   end;
2067 end;
2068
2069 //[procedure TWStrList.Init]
2070 procedure TWStrList.Init;
2071 begin
2072   fList := NewList;
2073 end;
2074
2075 //[procedure TWStrList.Insert]
2076 procedure TWStrList.Insert(Idx: Integer; const W: WideString);
2077 var P: Pointer;
2078 begin
2079   while Idx < Count-2 do
2080     fList.Add( nil );
2081   GetMem( P, (Length( W ) + 1) * 2 );
2082   fList.Insert( Idx, P );
2083   WStrCopy( P, PWideChar( W ) );
2084 end;
2085
2086 //[function TWStrList.LoadFromFile]
2087 function TWStrList.LoadFromFile(const Filename: String): Boolean;
2088 begin
2089   Clear;
2090   Result := MergeFromFile( Filename );
2091 end;
2092
2093 //[procedure TWStrList.LoadFromStream]
2094 procedure TWStrList.LoadFromStream(Strm: PStream);
2095 begin
2096   Clear;
2097   MergeFromStream( Strm );
2098 end;
2099
2100 //[function TWStrList.MergeFromFile]
2101 function TWStrList.MergeFromFile(const Filename: String): Boolean;
2102 var Strm: PStream;
2103 begin
2104   Strm := NewReadFileStream( Filename );
2105   Result := Strm.Handle <> INVALID_HANDLE_VALUE;
2106   if Result then
2107     MergeFromStream( Strm );
2108   Strm.Free;
2109 end;
2110
2111 //[procedure TWStrList.MergeFromStream]
2112 procedure TWStrList.MergeFromStream(Strm: PStream);
2113 var Buf: WideString;
2114     L: Integer;
2115 begin
2116   L := Strm.Size - Strm.Position;
2117   Assert( L mod 1 = 0, 'Wide strings streams must be of even length in bytes.' );
2118   if L = 0 then Exit;
2119   SetLength( Buf, L div 2 );
2120   Strm.Read( Buf[ 1 ], L );
2121   Text := Text + Buf;
2122 end;
2123
2124 //[procedure TWStrList.Move]
2125 procedure TWStrList.Move(IdxOld, IdxNew: Integer);
2126 begin
2127   fList.MoveItem( IdxOld, IdxNew );
2128 end;
2129
2130 //[function TWStrList.SaveToFile]
2131 function TWStrList.SaveToFile(const Filename: String): Boolean;
2132 var Strm: PStream;
2133 begin
2134   Strm := NewWriteFileStream( Filename );
2135   Result := Strm.Handle <> INVALID_HANDLE_VALUE;
2136   if Result then
2137     SaveToStream( Strm );
2138   Strm.Free;
2139 end;
2140
2141 //[procedure TWStrList.SaveToStream]
2142 procedure TWStrList.SaveToStream(Strm: PStream);
2143 var Buf, Dest: PWideChar;
2144     I, L, Sz: Integer;
2145     P: Pointer;
2146 begin
2147   Sz := 0;
2148   for I := 0 to Count-1 do
2149   begin
2150     P := fList.Items[ I ];
2151     if P <> nil then
2152       Sz := Sz + WStrLen( P ) * 2 + 4
2153     else
2154       Sz := Sz + 4;
2155   end;
2156   GetMem( Buf, Sz );
2157   Dest := Buf;
2158   for I := 0 to Count-1 do
2159   begin
2160     P := fList.Items[ I ];
2161     if P <> nil then
2162     begin
2163       L := WStrLen( P );
2164       System.Move( P^, Dest^, L * 2 );
2165       Inc( Dest, L );
2166     end;
2167     Dest^ := #13;
2168     Inc( Dest );
2169     Dest^ := #10;
2170     Inc( Dest );
2171   end;
2172   Strm.Write( Buf^, Sz );
2173   FreeMem( Buf );
2174 end;
2175
2176 //[procedure TWStrList.SetItems]
2177 procedure TWStrList.SetItems(Idx: Integer; const Value: WideString);
2178 var P: Pointer;
2179 begin
2180   while Idx > Count-1 do
2181     fList.Add( nil );
2182   if WStrLen( ItemPtrs[ Idx ] ) <= Length( Value ) then
2183     WStrCopy( ItemPtrs[ Idx ], PWideChar( Value ) )
2184   else
2185   begin
2186     P := fList.Items[ Idx ];
2187     if P <> nil then
2188     if not ((P >= fText) and (P <= fText + fTextBufSz)) then
2189       FreeMem( P );
2190     GetMem( P, (Length( Value ) + 1) * 2 );
2191     fList.Items[ Idx ] := P;
2192     WStrCopy( P, PWideChar( Value ) );
2193   end;
2194 end;
2195
2196 //[procedure TWStrList.SetText]
2197 procedure TWStrList.SetText(const Value: WideString);
2198 var L, N: Integer;
2199     P: PWideChar;
2200 begin
2201   Clear;
2202   if Value = '' then Exit;
2203   L := (Length( Value ) + 1) * 2;
2204   GetMem( fText, L );
2205   System.Move( Value[ 1 ], fText^, L );
2206   fTextBufSz := Length( Value );
2207   N := 0;
2208   P := fText;
2209   while Word( P^ ) <> 0 do
2210   begin
2211     if (Word( P^ ) = 13) then
2212     begin
2213       Inc( N );
2214       PWord( P )^ := 0;
2215       if Word( P[ 1 ] ) = 10 then
2216         Inc( P );
2217     end
2218       else
2219     if (Word( P^ ) = 10) and ((P = fText) or (Word( P[ -1 ] ) <> 0)) then
2220     begin
2221       Inc( N );
2222       PWord( P )^ := 0;
2223     end;
2224     Inc( P );
2225   end;
2226   fList.Capacity := N;
2227   P := fText;
2228   while P < fText + fTextBufSz do
2229   begin
2230     fList.Add( P );
2231     while Word( P^ ) <> 0 do Inc( P );
2232     Inc( P );
2233     if Word( P^ ) = 10 then Inc( P );
2234   end;
2235 end;
2236
2237 //[function CompareWStrListItems]
2238 function CompareWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;
2239 var WL: PWStrList;
2240 begin
2241   WL := Sender;
2242   Result := WStrCmp( WL.fList.Items[ Idx1 ], WL.fList.Items[ Idx2 ] );
2243 end;
2244
2245 //[function CompareWStrListItems_UpperCase]
2246 function CompareWStrListItems_UpperCase( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;
2247 var WL: PWStrList;
2248     L1, L2: Integer;
2249 begin
2250   WL := Sender;
2251   L1 := WStrLen( WL.fList.Items[ Idx1 ] );
2252   L2 := WStrLen( WL.fList.Items[ Idx2 ] );
2253   if Length( WL.fTmp1 ) < L1 then
2254     SetLength( WL.fTmp1, L1 + 1 );
2255   if Length( WL.fTmp2 ) < L2 then
2256     SetLength( WL.fTmp2, L2 + 1 );
2257   if L1 > 0 then
2258     Move( WL.fList.Items[ Idx1 ]^, WL.fTmp1[ 1 ], (L1 + 1) * 2 )
2259   else
2260     WL.fTmp1[ 1 ] := #0;
2261   if L2 > 0 then
2262     Move( WL.fList.Items[ Idx2 ]^, WL.fTmp2[ 1 ], (L2 + 1) * 2 )
2263   else
2264     WL.fTmp2[ 1 ] := #0;
2265   CharUpperBuffW( PWideChar( WL.fTmp1 ), L1 );
2266   CharUpperBuffW( PWideChar( WL.fTmp2 ), L2 );
2267   Result := WStrCmp( PWideChar( WL.fTmp1 ), PWideChar( WL.fTmp2 ) );
2268 end;
2269
2270 //[procedure SwapWStrListItems]
2271 procedure SwapWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD );
2272 var WL: PWStrList;
2273 begin
2274   WL := Sender;
2275   WL.Swap( Idx1, Idx2 );
2276 end;
2277
2278 //[procedure TWStrList.Sort]
2279 procedure TWStrList.Sort( CaseSensitive: Boolean );
2280 begin
2281   if CaseSensitive then
2282     SortData( @ Self, Count, @CompareWStrListItems, @SwapWStrListItems )
2283   else
2284   begin
2285     SortData( @ Self, Count, @CompareWStrListItems_UpperCase, @SwapWStrListItems );
2286     fTmp1 := '';
2287     fTmp2 := '';
2288   end;
2289 end;
2290
2291 //[procedure TWStrList.Swap]
2292 procedure TWStrList.Swap(Idx1, Idx2: Integer);
2293 begin
2294   fList.Swap( Idx1, Idx2 );
2295 end;
2296
2297 //[function NewWStrListEx]
2298 function NewWStrListEx: PWStrListEx;
2299 begin
2300   new( Result, Create );
2301 end;
2302
2303 { TWStrListEx }
2304
2305 //[function TWStrListEx.AddObject]
2306 function TWStrListEx.AddObject(const S: WideString; Obj: DWORD): Integer;
2307 begin
2308   Result := Count;
2309   InsertObject( Count, S, Obj );
2310 end;
2311
2312 //[procedure TWStrListEx.AddWStrings]
2313 procedure TWStrListEx.AddWStrings(WL: PWStrListEx);
2314 var I: Integer;
2315 begin
2316   I := Count;
2317   if WL.FObjects.Count > 0 then
2318     ProvideObjectsCapacity( Count );
2319   inherited AddWStrings( WL );
2320   if WL.FObjects.Count > 0 then
2321   begin
2322     ProvideObjectsCapacity( I + WL.FObjects.Count );
2323     System.Move( PCrackList( WL.FObjects ).FItems[ 0 ],
2324                  PCrackList( FObjects ).FItems[ I ],
2325                  Sizeof( Pointer ) * WL.FObjects.Count );
2326   end;
2327 end;
2328
2329 //[procedure TWStrListEx.Assign]
2330 procedure TWStrListEx.Assign(WL: PWStrListEx);
2331 begin
2332   inherited Assign( WL );
2333   FObjects.Assign( WL.FObjects );
2334 end;
2335
2336 //[procedure TWStrListEx.Clear]
2337 procedure TWStrListEx.Clear;
2338 begin
2339   inherited Clear;
2340   FObjects.Clear;
2341 end;
2342
2343 //[procedure TWStrListEx.Delete]
2344 procedure TWStrListEx.Delete(Idx: Integer);
2345 begin
2346   inherited Delete( Idx );
2347   if PCrackList( FObjects ).FCount >= Idx then
2348     FObjects.Delete( Idx );
2349 end;
2350
2351 //[destructor TWStrListEx.Destroy]
2352 destructor TWStrListEx.Destroy;
2353 begin
2354   fObjects.Free;
2355   inherited;
2356 end;
2357
2358 //[function TWStrListEx.GetObjects]
2359 function TWStrListEx.GetObjects(Idx: Integer): DWORD;
2360 begin
2361   Result := DWORD( fObjects.Items[ Idx ] );
2362 end;
2363
2364 //[function TWStrListEx.IndexOfObj]
2365 function TWStrListEx.IndexOfObj(Obj: Pointer): Integer;
2366 begin
2367   Result := FObjects.IndexOf( Obj );
2368 end;
2369
2370 //[procedure TWStrListEx.Init]
2371 procedure TWStrListEx.Init;
2372 begin
2373   inherited;
2374   fObjects := NewList;
2375 end;
2376
2377 //[procedure TWStrListEx.InsertObject]
2378 procedure TWStrListEx.InsertObject(Before: Integer; const S: WideString;
2379   Obj: DWORD);
2380 begin
2381   Insert( Before, S );
2382   FObjects.Insert( Before, Pointer( Obj ) );
2383 end;
2384
2385 //[procedure TWStrListEx.Move]
2386 procedure TWStrListEx.Move(IdxOld, IdxNew: Integer);
2387 begin
2388   fList.MoveItem( IdxOld, IdxNew );
2389   if PCrackList( FObjects ).FCount >= Min( IdxOld, IdxNew ) then
2390   begin
2391     ProvideObjectsCapacity( Max( IdxOld, IdxNew ) + 1 );
2392     FObjects.MoveItem( IdxOld, IdxNew );
2393   end;
2394 end;
2395
2396 //[procedure TWStrListEx.ProvideObjectsCapacity]
2397 procedure TWStrListEx.ProvideObjectsCapacity(NewCap: Integer);
2398 begin
2399   if fObjects.Capacity >= NewCap then Exit;
2400   fObjects.Capacity := NewCap;
2401   FillChar( PCrackList( FObjects ).FItems[ FObjects.Count ],
2402             (FObjects.Capacity - FObjects.Count) * Sizeof( Pointer ), 0 );
2403   PCrackList( FObjects ).FCount := NewCap;
2404 end;
2405
2406 //[procedure TWStrListEx.SetObjects]
2407 procedure TWStrListEx.SetObjects(Idx: Integer; const Value: DWORD);
2408 begin
2409   ProvideObjectsCapacity( Idx + 1 );
2410   fObjects.Items[ Idx ] := Pointer( Value );
2411 end;
2412
2413 {$ENDIF}
2414 {+}
2415
2416 { TCABFile }
2417
2418 //[function OpenCABFile]
2419 function OpenCABFile( const APaths: array of String ): PCABFile;
2420 var I: Integer;
2421 begin
2422   {-}
2423   New( Result, Create );
2424   {+}{++}(*Result := PCABFile.Create;*){--}
2425   Result.FSetupapi := LoadLibrary( 'setupapi.dll' );
2426   Result.FNames := NewStrList;
2427   Result.FPaths := NewStrList;
2428   for I := 0 to High( APaths ) do
2429     Result.FPaths.Add( APaths[ I ] );
2430 end;
2431
2432 //[destructor TCABFile.Destroy]
2433 destructor TCABFile.Destroy;
2434 begin
2435   FNames.Free;
2436   FPaths.Free;
2437   FTargetPath := '';
2438   if FSetupapi <> 0 then
2439     FreeLibrary( FSetupapi );
2440   inherited;
2441 end;
2442
2443 const
2444   SPFILENOTIFY_FILEINCABINET  = $11;
2445   SPFILENOTIFY_NEEDNEWCABINET = $12;
2446
2447 type
2448   PSP_FILE_CALLBACK = function( Context: Pointer; Notification, Param1, Param2: DWORD ): DWORD;
2449   stdcall;
2450
2451   TSetupIterateCabinet = function ( CabinetFile: PChar; Reserved: DWORD;
2452          MsgHandler: PSP_FILE_CALLBACK; Context: Pointer ): Boolean; stdcall;
2453          //external 'setupapi.dll' name 'SetupIterateCabinetA';
2454
2455   TSetupPromptDisk = function (
2456     hwndParent: HWND;   // parent window of the dialog box
2457     DialogTitle: PChar; // optional, title of the dialog box
2458     DiskName: PChar;    // optional, name of disk to insert
2459     PathToSource: PChar;// optional, expected source path
2460     FileSought: PChar;  // name of file needed
2461     TagFile: PChar;     // optional, source media tag file
2462     DiskPromptStyle: DWORD;     // specifies dialog box behavior
2463     PathBuffer: PChar;  // receives the source location
2464     PathBufferSize: DWORD;      // size of the supplied buffer
2465     PathRequiredSize: PDWORD    // optional, buffer size needed
2466    ): DWORD; stdcall;
2467    //external 'setupapi.dll' name 'SetupPromptForDiskA';
2468
2469 type
2470   TCabinetInfo = packed record
2471     CabinetPath: PChar;
2472     CabinetFile: PChar;
2473     DiskName: PChar;
2474     SetId: WORD;
2475     CabinetNumber: WORD;
2476   end;
2477   PCabinetInfo = ^TCabinetInfo;
2478
2479   TFileInCabinetInfo = packed record
2480     NameInCabinet: PChar;
2481     FileSize: DWORD;
2482     Win32Error: DWORD;
2483     DosDate: WORD;
2484     DosTime: WORD;
2485     DosAttribs: WORD;
2486     FullTargetName: array[0..MAX_PATH-1] of Char;
2487   end;
2488   PFileInCabinetInfo = ^TFileInCabinetInfo;
2489
2490 //[function CABCallback]
2491 function CABCallback( Context: Pointer; Notification, Param1, Param2: DWORD ): DWORD;
2492 stdcall;
2493 var CAB: PCABFile;
2494     CABPath, OldPath: String;
2495     CABInfo: PCabinetInfo;
2496     CABFileInfo: PFileInCabinetInfo;
2497     hr: Integer;
2498     SetupPromptProc: TSetupPromptDisk;
2499 begin
2500   Result := 0;
2501   CAB := Context;
2502   case Notification of
2503   SPFILENOTIFY_NEEDNEWCABINET:
2504     begin
2505       OldPath := CAB.FPaths.Items[ CAB.FCurCAB ];
2506       Inc( CAB.FCurCAB );
2507       if CAB.FCurCAB = CAB.FPaths.Count then
2508         CAB.FPaths.Add( '?' );
2509       CABPath := CAB.FPaths.Items[ CAB.FCurCAB ];
2510       if CABPath = '?' then
2511       begin
2512         if Assigned( CAB.FOnNextCAB ) then
2513           CAB.FPaths.Items[CAB.FCurCAB ] := CAB.FOnNextCAB( CAB );
2514         CABPath := CAB.FPaths.Items[ CAB.FCurCAB ];
2515         if CABPath = '?' then
2516         begin
2517           SetLength( CABPath, MAX_PATH );
2518           CABInfo := Pointer( Param1 );
2519           if CAB.FSetupapi <> 0 then
2520             SetupPromptProc := GetProcAddress( CAB.FSetupapi, 'SetupPromptForDiskA' )
2521           else
2522             SetupPromptProc := nil;
2523           if Assigned( SetupPromptProc ) then
2524           begin
2525             hr := SetupPromptProc( 0, nil, nil, PChar( ExtractFilePath( OldPath ) ),
2526                  CABInfo.CabinetFile, nil, 2 {IDF_NOSKIP}, @CabPath[ 1 ], MAX_PATH, nil );
2527             case hr of
2528             0: // success
2529               begin
2530                 StrCopy( PChar( Param2 ), PChar( CABPath ) );
2531                 Result := 0;
2532               end;
2533             2: // skip file
2534               Result := 0;
2535             else // cancel
2536               Result := ERROR_FILE_NOT_FOUND;
2537             end;
2538           end;
2539         end
2540           else
2541         begin
2542           StrCopy( PChar( Param2 ), PChar( CABPath ) );
2543           Result := 0;
2544         end;
2545       end;
2546     end;
2547   SPFILENOTIFY_FILEINCABINET:
2548     begin
2549       CABFileInfo := Pointer( Param1 );
2550       if CAB.FGettingNames then
2551       begin
2552         CAB.FNames.Add( CABFileInfo.NameInCabinet );
2553         Result := 2; // FILEOP_SKIP
2554       end
2555         else
2556       begin
2557         CABPath := CABFileInfo.NameInCabinet;
2558         if Assigned( CAB.FOnFile ) then
2559         begin
2560           if CAB.FOnFile( CAB, CABPath ) then
2561           begin
2562             if ExtractFilePath( CABPath ) = '' then
2563             if CAB.FTargetPath <> '' then
2564               CABPath := CAB.TargetPath + CABPath;
2565             StrCopy( @CABFileInfo.FullTargetName[ 0 ], PChar( CABPath ) );
2566             Result := 1; // FILEOP_DOIT
2567           end
2568           else
2569             Result := 2
2570         end
2571         else
2572         begin
2573           if CAB.FTargetPath <> '' then
2574             StrCopy( @CABFileInfo.FullTargetName[ 0 ], PChar( CAB.TargetPath + CABPath ) );
2575           Result := 1;
2576         end;
2577       end;
2578     end;
2579   end;
2580 end;
2581
2582 //[function TCABFile.Execute]
2583 function TCABFile.Execute: Boolean;
2584 var SetupIterateProc: TSetupIterateCabinet;
2585 begin
2586   FCurCAB := 0;
2587   Result := FALSE;
2588   if FSetupapi = 0 then Exit;
2589   SetupIterateProc := GetProcAddress( FSetupapi, 'SetupIterateCabinetA' );
2590   if not Assigned( SetupIterateProc ) then Exit;
2591   Result := SetupIterateProc( PChar( FPaths.Items[ 0 ] ), 0, CABCallback, @Self );
2592 end;
2593
2594 //[function TCABFile.GetCount]
2595 function TCABFile.GetCount: Integer;
2596 begin
2597   GetNames( 0 );
2598   Result := FNames.Count;
2599 end;
2600
2601 //[function TCABFile.GetNames]
2602 function TCABFile.GetNames(Idx: Integer): String;
2603 begin
2604   if FNames.Count = 0 then
2605   begin
2606     FGettingNames := TRUE;
2607     Execute;
2608     FGettingNames := FALSE;
2609   end;
2610   Result := '';
2611   if Idx < FNames.Count then
2612     Result := FNames.Items[ Idx ];
2613 end;
2614
2615 //[function TCABFile.GetPaths]
2616 function TCABFile.GetPaths(Idx: Integer): String;
2617 begin
2618   Result := FPaths.Items[ Idx ];
2619 end;
2620
2621 //[function TCABFile.GetTargetPath]
2622 function TCABFile.GetTargetPath: String;
2623 begin
2624   Result := FTargetPath;
2625   if Result <> '' then
2626   if Result[ Length( Result ) ] <> '\' then
2627     Result := Result + '\';
2628 end;
2629
2630 { -- TDirChange -- }
2631
2632 const FilterFlags: array[ TFileChangeFilters ] of Integer = (
2633       FILE_NOTIFY_CHANGE_FILE_NAME, FILE_NOTIFY_CHANGE_DIR_NAME,
2634       FILE_NOTIFY_CHANGE_ATTRIBUTES, FILE_NOTIFY_CHANGE_SIZE,
2635       FILE_NOTIFY_CHANGE_LAST_WRITE, $20 {FILE_NOTIFY_CHANGE_LAST_ACCESS},
2636       $40 {FILE_NOTIFY_CHANGE_CREATION}, FILE_NOTIFY_CHANGE_SECURITY );
2637
2638 //[FUNCTION _NewDirChgNotifier]
2639 {$IFDEF ASM_VERSION}
2640 function _NewDirChgNotifier: PDirChange;
2641 begin
2642   New( Result, Create );
2643 end;
2644 //[function NewDirChangeNotifier]
2645 function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;
2646                                WatchSubtree: Boolean; ChangeProc: TOnDirChange )
2647                                : PDirChange;
2648 const Dflt_Flags = FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or
2649       FILE_NOTIFY_CHANGE_ATTRIBUTES or FILE_NOTIFY_CHANGE_SIZE or
2650       FILE_NOTIFY_CHANGE_LAST_WRITE;
2651 asm
2652         PUSH     EBX
2653         PUSH     ECX // [EBP-8] = WatchSubtree
2654         PUSH     EDX // [EBP-12] = Filter
2655         PUSH     EAX // [EBP-16] = Path
2656         CALL     _NewDirChgNotifier
2657         XCHG     EBX, EAX
2658         LEA      EAX, [EBX].TDirChange.FPath
2659         POP      EDX
2660         CALL     System.@LStrAsg
2661         MOV      EAX, [ChangeProc].TMethod.Code
2662         MOV      [EBX].TDirChange.FOnChange.TMethod.Code, EAX
2663         MOV      EAX, [ChangeProc].TMethod.Data
2664         MOV      [EBX].TDirChange.FOnChange.TMethod.Data, EAX
2665         POP      ECX
2666         MOV      EAX, Dflt_Flags
2667         MOVZX    ECX, CL
2668         JECXZ    @@flags_ready
2669         PUSH     ECX
2670         MOV      EAX, ESP
2671         MOV      EDX, offset[FilterFlags]
2672         XOR      ECX, ECX
2673         MOV      CL, 7
2674         CALL     MakeFlags
2675         POP      ECX
2676 @@flags_ready:           // EAX = Flags
2677         POP      EDX
2678         MOVZX    EDX, DL // EDX = WatchSubtree
2679         PUSH     EAX
2680         PUSH     EDX
2681         PUSH     [EBX].TDirChange.FPath
2682         CALL     FindFirstChangeNotification
2683         MOV      [EBX].TDirChange.FHandle, EAX
2684         INC      EAX
2685         JZ       @@fault
2686         PUSH     EBX
2687         PUSH     offset[TDirChange.Execute]
2688         CALL     NewThreadEx
2689         MOV      [EBX].TDirChange.FMonitor, EAX
2690         JMP      @@exit
2691 @@fault:
2692         XCHG     EAX, EBX
2693         CALL     TObj.Free
2694 @@exit:
2695         XCHG     EAX, EBX
2696         POP      EBX
2697 end;
2698 {$ELSE ASM_VERSION} //Pascal
2699 function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;
2700                                WatchSubtree: Boolean; ChangeProc: TOnDirChange )
2701                                : PDirChange;
2702 var Flags: DWORD;
2703 begin
2704   {-}
2705   New( Result, Create );
2706   {+}{++}(*Result := PDirChange.Create;*){--}
2707
2708   Result.FPath := Path;
2709   Result.FOnChange := ChangeProc;
2710   if Filter = [ ] then
2711     Flags := FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or
2712       FILE_NOTIFY_CHANGE_ATTRIBUTES or FILE_NOTIFY_CHANGE_SIZE or
2713       FILE_NOTIFY_CHANGE_LAST_WRITE
2714   else
2715     Flags := MakeFlags( @Filter, FilterFlags );
2716   Result.FHandle := FindFirstChangeNotification(PChar(Result.FPath),
2717                     Bool( Integer( WatchSubtree ) ), Flags);
2718   if Result.FHandle <> INVALID_HANDLE_VALUE then
2719     Result.FMonitor := NewThreadEx( Result.Execute )
2720   else //MsgOK( 'Can not monitor ' + Result.FPath + #13'Error ' + Int2Str( GetLastError ) );
2721   begin
2722     Result.Free;
2723     Result := nil;
2724   end;
2725 end;
2726 {$ENDIF ASM_VERSION}
2727 //[END _NewDirChgNotifier]
2728
2729 { TDirChange }
2730
2731 {$IFDEF ASM_VERSION}
2732 //[procedure TDirChange.Changed]
2733 procedure TDirChange.Changed;
2734 asm
2735         MOV      ECX, [EAX].FPath
2736         XCHG     EDX, EAX
2737         MOV      EAX, [EDX].FOnChange.TMethod.Data
2738         CALL     [EDX].FOnChange.TMethod.Code
2739 end;
2740 {$ELSE ASM_VERSION} //Pascal
2741 procedure TDirChange.Changed;
2742 begin
2743   FOnChange(@Self, FPath); // must be assigned always!!!
2744 end;
2745 {$ENDIF ASM_VERSION}
2746
2747 {$IFDEF ASM_VERSION}
2748 //[destructor TDirChange.Destroy]
2749 destructor TDirChange.Destroy;
2750 asm
2751         PUSH     EBX
2752         XCHG     EBX, EAX
2753         MOV      ECX, [EBX].FMonitor
2754         JECXZ    @@no_monitor
2755         XCHG     EAX, ECX
2756         CALL     TObj.Free
2757 @@no_monitor:
2758         MOV      ECX, [EBX].FHandle
2759         JECXZ    @@exit
2760         PUSH     ECX
2761         CALL     FindCloseChangeNotification
2762 @@exit:
2763         LEA      EAX, [EBX].FPath
2764         CALL     System.@LStrClr
2765         XCHG     EAX, EBX
2766         CALL     TObj.Destroy
2767         POP      EBX
2768 end;
2769 {$ELSE ASM_VERSION} //Pascal
2770 destructor TDirChange.Destroy;
2771 begin
2772   if FMonitor <> nil then
2773      FMonitor.Free;
2774   if FHandle > 0 then // FHandle <> INVALID_HANDLE_VALUE AND FHandle <> 0
2775      FindCloseChangeNotification(FHandle);
2776   FPath := '';
2777   inherited;
2778 end;
2779 {$ENDIF ASM_VERSION}
2780
2781 {$IFDEF ASM_noVERSION}
2782 //[function TDirChange.Execute]
2783 function TDirChange.Execute(Sender: PThread): Integer;
2784 asm
2785         PUSH     EBX
2786         PUSH     ESI
2787         XCHG     EBX, EAX
2788         MOV      ESI, EDX
2789 @@loo:
2790         MOVZX    ECX, [ESI].TThread.FTerminated
2791         INC      ECX
2792         LOOP     @@e_loop
2793
2794         MOV      ECX, [EBX].FHandle
2795         INC      ECX
2796         JZ       @@e_loop
2797
2798         PUSH     INFINITE
2799         PUSH     ECX
2800         CALL     WaitForSingleObject
2801         OR       EAX, EAX
2802         JNZ      @@loo
2803
2804         PUSH     [EBX].FHandle
2805         MOV      EAX, [EBX].FMonitor
2806         PUSH     EBX
2807         PUSH     offset[TDirChange.Changed]
2808         CALL     TThread.Synchronize
2809         CALL     FindNextChangeNotification
2810         JMP      @@loo
2811 @@e_loop:
2812
2813         POP      ESI
2814         POP      EBX
2815         XOR      EAX, EAX
2816 end;
2817 {$ELSE ASM_VERSION} //Pascal
2818 function TDirChange.Execute(Sender: PThread): Integer;
2819 begin
2820   while (not Sender.Terminated and (FHandle <> INVALID_HANDLE_VALUE)) do
2821     if (WaitForSingleObject(FHandle, INFINITE) = WAIT_OBJECT_0) then
2822     begin
2823       if AppletTerminated then break;
2824       Applet.GetWindowHandle;
2825       FMonitor.Synchronize( Changed );
2826       FindNextChangeNotification(FHandle);
2827     end;
2828   Result := 0;
2829 end;
2830 {$ENDIF ASM_VERSION}
2831
2832 ////////////////////////////////////////////////////////////////////////
2833 //
2834 //
2835 //                         M  E T A F I L E
2836 //
2837 //
2838 ////////////////////////////////////////////////////////////////////////
2839
2840 {++}(*
2841 //[API SetEnhMetaFileBits]
2842 function SetEnhMetaFileBits; external gdi32 name 'SetEnhMetaFileBits';
2843 function PlayEnhMetaFile; external gdi32 name 'PlayEnhMetaFile';
2844 *){--}
2845
2846 //[function NewMetafile]
2847 function NewMetafile: PMetafile;
2848 begin
2849   {-}
2850   new( Result, Create );
2851   {+}{++}(*Result := PMetafile.Create;*){--}
2852 end;
2853 //[END NewMetafile]
2854
2855 { TMetafile }
2856
2857 //[procedure TMetafile.Clear]
2858 procedure TMetafile.Clear;
2859 begin
2860   if fHandle <> 0 then
2861     DeleteEnhMetaFile( fHandle );
2862   fHandle := 0;
2863 end;
2864
2865 //[destructor TMetafile.Destroy]
2866 destructor TMetafile.Destroy;
2867 begin
2868   if fHeader <> nil then
2869     FreeMem( fHeader );
2870   Clear;
2871   inherited;
2872 end;
2873
2874 //[procedure TMetafile.Draw]
2875 procedure TMetafile.Draw(DC: HDC; X, Y: Integer);
2876 begin
2877   StretchDraw( DC, MakeRect( X, Y, X + Width, Y + Height ) );
2878 end;
2879
2880 //[function TMetafile.Empty]
2881 function TMetafile.Empty: Boolean;
2882 begin
2883   Result := fHandle = 0;
2884 end;
2885
2886 //[function TMetafile.GetHeight]
2887 function TMetafile.GetHeight: Integer;
2888 begin
2889   Result := 0;
2890   if Empty then Exit;
2891   RetrieveHeader;
2892   Result := fHeader.rclBounds.Bottom - fHeader.rclBounds.Top;
2893 end;
2894
2895 //[function TMetafile.GetWidth]
2896 function TMetafile.GetWidth: Integer;
2897 begin
2898   Result := 0;
2899   if Empty then Exit;
2900   RetrieveHeader;
2901   Result := fHeader.rclBounds.Right - fHeader.rclBounds.Left;
2902 end;
2903
2904 //[function TMetafile.LoadFromFile]
2905 function TMetafile.LoadFromFile(const Filename: String): Boolean;
2906 var Strm: PStream;
2907 begin
2908   Strm := NewReadFileStream( FileName );
2909   Result := LoadFromStream( Strm );
2910   Strm.Free;
2911 end;
2912
2913 //[function ComputeAldusChecksum]
2914 function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
2915 type
2916   PWord = ^Word;
2917 var
2918   pW: PWord;
2919   pEnd: PWord;
2920 begin
2921   Result := 0;
2922   pW := @WMF;
2923   pEnd := @WMF.CheckSum;
2924   while Longint(pW) < Longint(pEnd) do
2925   begin
2926     Result := Result xor pW^;
2927     Inc(Longint(pW), SizeOf(Word));
2928   end;
2929 end;
2930
2931 //[function TMetafile.LoadFromStream]
2932 function TMetafile.LoadFromStream(Strm: PStream): Boolean;
2933 var WMF: TMetaFileHeader;
2934     WmfHdr: TMetaHeader;
2935     EnhHdr: TEnhMetaHeader;
2936     Pos, Pos1: Integer;
2937     Sz: Integer;
2938     MemStrm: PStream;
2939     MFP: TMetafilePict;
2940 begin
2941   Result := FALSE;
2942   Pos := Strm.Position;
2943
2944   if Strm.Read( WMF, Sizeof( WMF ) ) <> Sizeof( WMF ) then
2945   begin
2946     Strm.Position := Pos;
2947     Exit;
2948   end;
2949
2950   MemStrm := NewMemoryStream;
2951
2952   if WMF.Key = WMFKey then
2953   begin // Windows metafile
2954
2955     if WMF.CheckSum <> ComputeAldusChecksum( WMF ) then
2956     begin
2957       Strm.Position := Pos;
2958       Exit;
2959     end;
2960
2961     Pos1 := Strm.Position;
2962     if Strm.Read( WmfHdr, Sizeof( WmfHdr ) ) <> Sizeof( WmfHdr ) then
2963     begin
2964       Strm.Position := Pos;
2965       Exit;
2966     end;
2967
2968     Strm.Position := Pos1;
2969     Sz := WMFHdr.mtSize * 2;
2970     Stream2Stream( MemStrm, Strm, Sz );
2971     FillChar( MFP, Sizeof( MFP ), 0 );
2972     MFP.mm := MM_ANISOTROPIC;
2973     fHandle := SetWinMetafileBits( Sz, MemStrm.Memory, 0, MFP );
2974
2975   end
2976     else
2977   begin // may be enchanced?
2978
2979     Strm.Position := Pos;
2980     if Strm.Read( EnhHdr, Sizeof( EnhHdr ) ) < 8 then
2981     begin
2982       Strm.Position := Pos;
2983       Exit;
2984     end;
2985     // yes, enchanced
2986     Strm.Position := Pos;
2987     Sz := EnhHdr.nBytes;
2988     Stream2Stream( MemStrm, Strm, Sz );
2989     fHandle := SetEnhMetaFileBits( Sz, MemStrm.Memory );
2990
2991   end;
2992
2993   MemStrm.Free;
2994   Result := fHandle <> 0;
2995   if not Result then
2996     Strm.Position := Pos;
2997
2998 end;
2999
3000 //[procedure TMetafile.RetrieveHeader]
3001 procedure TMetafile.RetrieveHeader;
3002 var SzHdr: Integer;
3003 begin
3004   if fHeader <> nil then
3005     FreeMem( fHeader );
3006   SzHdr := GetEnhMetaFileHeader( fHandle, 0, nil );
3007   GetMem( fHeader, SzHdr );
3008   GetEnhMetaFileHeader( fHandle, SzHdr, fHeader );
3009 end;
3010
3011 //[procedure TMetafile.SetHandle]
3012 procedure TMetafile.SetHandle(const Value: THandle);
3013 begin
3014   Clear;
3015   fHandle := Value;
3016 end;
3017
3018 //[procedure TMetafile.StretchDraw]
3019 procedure TMetafile.StretchDraw(DC: HDC; const R: TRect);
3020 begin
3021   if Empty then Exit;
3022   PlayEnhMetaFile( DC, fHandle, R );
3023 end;
3024
3025 { ----------------------------------------------------------------------
3026
3027                 TAction and TActionList
3028
3029 ----------------------------------------------------------------------- }
3030 //[function NewActionList]
3031 function NewActionList(AOwner: PControl): PActionList;
3032 begin
3033   {-}
3034   New( Result, Create );
3035   {+} {++}(* Result := PActionList.Create; *){--}
3036   with Result{-}^{+} do begin
3037     FActions:=NewList;
3038     FOwner:=AOwner;
3039     RegisterIdleHandler(DoUpdateActions);
3040   end;
3041 end;
3042 //[END NewActionList]
3043
3044 //[function NewAction]
3045 function NewAction(const ACaption, AHint: string; AOnExecute: TOnEvent): PAction;
3046 begin
3047   {-}
3048   New( Result, Create );
3049   {+} {++}(* Result := PAction.Create; *){--}
3050   with Result{-}^{+} do begin
3051     FControls:=NewList;
3052     Enabled:=True;
3053     Visible:=True;
3054     Caption:=ACaption;
3055     Hint:=AHint;
3056     OnExecute:=AOnExecute;
3057   end;
3058 end;
3059 //[END NewAction]
3060
3061 { TAction }
3062
3063 //[procedure TAction.LinkCtrl]
3064 procedure TAction.LinkCtrl(ACtrl: PObj; ACtrlKind: TCtrlKind; AItemID: integer; AUpdateProc: TOnUpdateCtrlEvent);
3065 var
3066   cr: PControlRec;
3067 begin
3068   New(cr);
3069   with cr^ do begin
3070     Ctrl:=ACtrl;
3071     CtrlKind:=ACtrlKind;
3072     ItemID:=AItemID;
3073     UpdateProc:=AUpdateProc;
3074   end;
3075   FControls.Add(cr);
3076   AUpdateProc(cr);
3077 end;
3078
3079 //[procedure TAction.LinkControl]
3080 procedure TAction.LinkControl(Ctrl: PControl);
3081 begin
3082   LinkCtrl(Ctrl, ckControl, 0, UpdateCtrl);
3083   Ctrl.OnClick:=DoOnControlClick;
3084 end;
3085
3086 //[procedure TAction.LinkMenuItem]
3087 procedure TAction.LinkMenuItem(Menu: PMenu; MenuItemIdx: integer);
3088 {$IFDEF _FPC}
3089 var
3090   arr1_DoOnMenuItem: array[ 0..0 ] of TOnMenuItem;
3091 {$ENDIF _FPC}
3092 begin
3093   LinkCtrl(Menu, ckMenu, MenuItemIdx, UpdateMenu);
3094   {$IFDEF _FPC}
3095   arr1_DoOnMenuItem[ 0 ] := DoOnMenuItem;
3096   Menu.AssignEvents(MenuItemIdx, arr1_DoOnMenuItem);
3097   {$ELSE}
3098   Menu.AssignEvents(MenuItemIdx, [ DoOnMenuItem ]);
3099   {$ENDIF}
3100 end;
3101
3102 //[procedure TAction.LinkToolbarButton]
3103 procedure TAction.LinkToolbarButton(Toolbar: PControl; ButtonIdx: integer);
3104 {$IFDEF _FPC}
3105 var
3106   arr1_DoOnToolbarButtonClick: array[ 0..0 ] of TOnToolbarButtonClick;
3107 {$ENDIF _FPC}
3108 begin
3109   LinkCtrl(Toolbar, ckToolbar, ButtonIdx, UpdateToolbar);
3110   {$IFDEF _FPC}
3111   arr1_DoOnToolbarButtonClick[ 0 ] := DoOnToolbarButtonClick;
3112   Toolbar.TBAssignEvents(ButtonIdx, arr1_DoOnToolbarButtonClick);
3113   {$ELSE}
3114   Toolbar.TBAssignEvents(ButtonIdx, [DoOnToolbarButtonClick]);
3115   {$ENDIF}
3116 end;
3117
3118 //[destructor TAction.Destroy]
3119 destructor TAction.Destroy;
3120 begin
3121   FControls.Release;
3122   FCaption:='';
3123   FShortCut:='';
3124   FHint:='';
3125   inherited;
3126 end;
3127
3128 //[procedure TAction.DoOnControlClick]
3129 procedure TAction.DoOnControlClick(Sender: PObj);
3130 begin
3131   Execute;
3132 end;
3133
3134 //[procedure TAction.DoOnMenuItem]
3135 procedure TAction.DoOnMenuItem(Sender: PMenu; Item: Integer);
3136 begin
3137   Execute;
3138 end;
3139
3140 //[procedure TAction.DoOnToolbarButtonClick]
3141 procedure TAction.DoOnToolbarButtonClick(Sender: PControl; BtnID: Integer);
3142 begin
3143   Execute;
3144 end;
3145
3146 //[procedure TAction.Execute]
3147 procedure TAction.Execute;
3148 begin
3149   if Assigned(FOnExecute) and FEnabled then
3150     FOnExecute(PObj( @Self ));
3151 end;
3152
3153 //[procedure TAction.SetCaption]
3154 procedure TAction.SetCaption(const Value: string);
3155 var
3156   i: integer;
3157   c, ss: string;
3158
3159 begin
3160   i:=Pos(#9, Value);
3161   if i <> 0 then begin
3162     c:=Copy(Value, 1, i - 1);
3163     ss:=Copy(Value, i + 1, MaxInt);
3164   end
3165   else begin
3166     c:=Value;
3167     ss:='';
3168   end;
3169   if (FCaption = c) and (FShortCut = ss) then exit;
3170   FCaption:=c;
3171   FShortCut:=ss;
3172   UpdateControls;
3173 end;
3174
3175 //[procedure TAction.SetChecked]
3176 procedure TAction.SetChecked(const Value: boolean);
3177 begin
3178   if FChecked = Value then exit;
3179   FChecked := Value;
3180   UpdateControls;
3181 end;
3182
3183 //[procedure TAction.SetEnabled]
3184 procedure TAction.SetEnabled(const Value: boolean);
3185 begin
3186   if FEnabled = Value then exit;
3187   FEnabled := Value;
3188   UpdateControls;
3189 end;
3190
3191 //[procedure TAction.SetHelpContext]
3192 procedure TAction.SetHelpContext(const Value: integer);
3193 begin
3194   if FHelpContext = Value then exit;
3195   FHelpContext := Value;
3196   UpdateControls;
3197 end;
3198
3199 //[procedure TAction.SetHint]
3200 procedure TAction.SetHint(const Value: string);
3201 begin
3202   if FHint = Value then exit;
3203   FHint := Value;
3204   UpdateControls;
3205 end;
3206
3207 //[procedure TAction.SetOnExecute]
3208 procedure TAction.SetOnExecute(const Value: TOnEvent);
3209 begin
3210   if @FOnExecute = @Value then exit;
3211   FOnExecute:=Value;
3212   UpdateControls;
3213 end;
3214
3215 //[procedure TAction.SetVisible]
3216 procedure TAction.SetVisible(const Value: boolean);
3217 begin
3218   if FVisible = Value then exit;
3219   FVisible := Value;
3220   UpdateControls;
3221 end;
3222
3223 //[procedure TAction.UpdateControls]
3224 procedure TAction.UpdateControls;
3225 var
3226   i: integer;
3227 begin
3228   with FControls{-}^{+} do
3229     for i:=0 to Count - 1 do
3230       PControlRec(Items[i]).UpdateProc(Items[i]);
3231 end;
3232
3233 //[procedure TAction.UpdateCtrl]
3234 procedure TAction.UpdateCtrl(Sender: PControlRec);
3235 begin
3236   with Sender^, PControl(Ctrl){-}^{+} do begin
3237     if Caption <> Self.FCaption then
3238       Caption:=Self.FCaption;
3239     if Enabled <> Self.FEnabled then
3240       Enabled:=Self.FEnabled;
3241     if Checked <> Self.FChecked then
3242       Checked:=Self.FChecked;
3243     if Visible <> Self.FVisible then
3244       Visible:=Self.FVisible;
3245   end;
3246 end;
3247
3248 //[procedure TAction.UpdateMenu]
3249 procedure TAction.UpdateMenu(Sender: PControlRec);
3250 var
3251   s: string;
3252 begin
3253   with Sender^, PMenu(Ctrl).Items[ItemID]{-}^{+} do begin
3254     s:=Self.FCaption;
3255     if Self.FShortCut <> '' then
3256       s:=s + #9 + Self.FShortCut;
3257     if Caption <> s then
3258       Caption:=s;
3259     if Enabled <> Self.FEnabled then
3260       Enabled:=Self.FEnabled;
3261     if Checked <> Self.FChecked then
3262       Checked:=Self.FChecked;
3263     if Visible <> Self.FVisible then
3264       Visible:=Self.FVisible;
3265     if HelpContext <> Self.FHelpContext then
3266       HelpContext:=Self.FHelpContext;
3267     if Self.FAccelerator.Key <> 0 then {YS}  // Äîáàâèòü
3268       Accelerator:=Self.FAccelerator;
3269   end;
3270 end;
3271
3272 //[procedure TAction.UpdateToolbar]
3273 procedure TAction.UpdateToolbar(Sender: PControlRec);
3274 var
3275   i: integer;
3276   s: string;
3277 begin
3278   with Sender^, PControl(Ctrl){-}^{+} do begin
3279     i:=TBIndex2Item(ItemID);
3280     s:=TBButtonText[i];
3281     if (s <> '') and (s <> Self.FCaption) then
3282       TBButtonText[i]:=Self.FCaption;
3283     TBSetTooltips(i, [PChar(Self.FHint)]);
3284     if TBButtonEnabled[ItemID] <> Self.FEnabled then
3285       TBButtonEnabled[ItemID]:=Self.FEnabled;
3286     if TBButtonVisible[ItemID] <> Self.FVisible then
3287       TBButtonVisible[ItemID]:=Self.FVisible;
3288     if TBButtonChecked[ItemID] <> Self.FChecked then
3289       TBButtonChecked[ItemID]:=Self.FChecked;
3290   end;
3291 end;
3292
3293 //[procedure TAction.SetAccelerator]
3294 procedure TAction.SetAccelerator(const Value: TMenuAccelerator);
3295 begin
3296   if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then exit;
3297   FAccelerator := Value;
3298   FShortCut:=GetAcceleratorText(FAccelerator);  // {YS}
3299   UpdateControls;
3300 end;
3301
3302 { TActionList }
3303
3304 //[function TActionList.Add]
3305 function TActionList.Add(const ACaption, AHint: string; OnExecute: TOnEvent): PAction;
3306 begin
3307   Result:=NewAction(ACaption, AHint, OnExecute);
3308   FActions.Add(Result);
3309 end;
3310
3311 //[procedure TActionList.Clear]
3312 procedure TActionList.Clear;
3313 begin
3314   while FActions.Count > 0 do
3315     Delete(0);
3316   FActions.Clear;
3317 end;
3318
3319 //[procedure TActionList.Delete]
3320 procedure TActionList.Delete(Idx: integer);
3321 begin
3322   Actions[Idx].Free;
3323   FActions.Delete(Idx);
3324 end;
3325
3326 //[destructor TActionList.Destroy]
3327 destructor TActionList.Destroy;
3328 begin
3329   UnRegisterIdleHandler(DoUpdateActions);
3330   Clear;
3331   FActions.Free;
3332   inherited;
3333 end;
3334
3335 //[procedure TActionList.DoUpdateActions]
3336 procedure TActionList.DoUpdateActions(Sender: PObj);
3337 begin
3338   if Assigned(FOnUpdateActions) and (GetActiveWindow = FOwner.Handle) then
3339     FOnUpdateActions(PObj( @Self ));
3340 end;
3341
3342 //[function TActionList.GetActions]
3343 function TActionList.GetActions(Idx: integer): PAction;
3344 begin
3345   Result:=FActions.Items[Idx];
3346 end;
3347
3348 //[function TActionList.GetCount]
3349 function TActionList.GetCount: integer;
3350 begin
3351   Result:=FActions.Count;
3352 end;
3353
3354 end.