home *** CD-ROM | disk | FTP | other *** search
/ IT.SOFT 22 / ITSOFTCD_22.iso / pc / shareware22 / file3 / TINYWEB.ZIP / SRC.ZIP / XBASE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1998-10-17  |  73.0 KB  |  2,987 lines

  1. //////////////////////////////////////////////////////////////////////////
  2. //
  3. //  TinyWeb Copyright (C) 1997-98 RIT Research Labs
  4. //
  5. //  This programs is free for commercial and non-commercial use as long as
  6. //  the following conditions are aheared to.
  7. //
  8. //  Copyright remains RIT Research Labs, and as such any Copyright notices
  9. //  in the code are not to be removed. If this package is used in a
  10. //  product, RIT Research Labs should be given attribution as the RIT Research
  11. //  Labs of the parts of the library used. This can be in the form of a textual
  12. //  message at program startup or in documentation (online or textual)
  13. //  provided with the package.
  14. //
  15. //  Redistribution and use in source and binary forms, with or without
  16. //  modification, are permitted provided that the following conditions are
  17. //  met:
  18. //
  19. //  1. Redistributions of source code must retain the copyright
  20. //     notice, this list of conditions and the following disclaimer.
  21. //  2. Redistributions in binary form must reproduce the above copyright
  22. //     notice, this list of conditions and the following disclaimer in the
  23. //     documentation and/or other materials provided with the distribution.
  24. //  3. All advertising materials mentioning features or use of this software
  25. //     must display the following acknowledgement:
  26. //     "Based on TinyWeb Server by RIT Research Labs."
  27. //
  28. //  THIS SOFTWARE IS PROVIDED BY RIT RESEARCH LABS "AS IS" AND ANY EXPRESS
  29. //  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  30. //  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  31. //  DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR
  32. //  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  33. //  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  34. //  GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  35. //  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
  36. //  IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  37. //  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  38. //  ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  39. //
  40. //  The licence and distribution terms for any publically available
  41. //  version or derivative of this code cannot be changed. i.e. this code
  42. //  cannot simply be copied and put under another distribution licence
  43. //  (including the GNU Public Licence).
  44. //
  45. //////////////////////////////////////////////////////////////////////////
  46.  
  47. {$I DEFINE.INC}
  48.  
  49.  
  50. unit xBase;
  51.  
  52. interface uses Windows, WinSock;
  53.  
  54. const
  55.  
  56.   _INADDR_ANY = INADDR_ANY;
  57.   INVALID_FILE_ATTRIBUTES = INVALID_FILE_SIZE;
  58.   INVALID_FILE_TIME       = INVALID_FILE_SIZE;
  59.   INVALID_REGISTRY_KEY    = INVALID_HANDLE_VALUE;
  60.   INVALID_VALUE           = INVALID_HANDLE_VALUE;
  61.  
  62.   rrLoHexChar: array[0..$F] of char='0123456789abcdef';
  63.   rrHiHexChar: array[0..$F] of char='0123456789ABCDEF';
  64.  
  65.   SleepQuant = 1*60*1000; // 1 minute
  66.  
  67. { Maximum TColl size }
  68.  
  69.   MaxCollSize = $20000 div SizeOf(Pointer);
  70.  
  71. const
  72.       MMaxChars = 250;
  73.  
  74.  
  75. type
  76.     Str255 = String[255];
  77.     TByteTable = Array[Char] of Byte;
  78.     TBase64Table = (bsBase64, bsUUE, bsXXE);
  79.     TUUStr = String[MMaxChars];
  80.  
  81.  
  82.     TMimeCoder = class
  83.       Table: string;
  84.       MaxChars: Byte;
  85.       Pad: Char;
  86.       XChars: TByteTable;
  87.       constructor Create(AType: TBase64Table);
  88.       procedure   InitTable;
  89.       function    Encode(const Buf; N: byte) : string;
  90.       function    EncodeBuf(const Buf; N: byte; var OutBuf) : Integer;
  91.       function    EncodeStr(const S: String): String;
  92.       function    Decode(const S : String; var Buf): Integer;
  93.       function    DecodeBuf(const SrcBuf; SrcLen: Integer; var Buf): Integer;
  94.     end;
  95.  
  96.  
  97.     TSocketOption = (soBroadcast, soDebug, soDontLinger,
  98.                      soDontRoute, soKeepAlive, soOOBInLine,
  99.                      soReuseAddr, soNoDelay, soBlocking, soAcceptConn);
  100.  
  101.     TSocketOptions = Set of TSocketOption;
  102.  
  103.     TSocketClass = class of TSocket;
  104.  
  105.     TSocket = class
  106.     public
  107.       Dead: Integer;
  108.       FPort: DWORD;
  109.       FAddr: DWORD;
  110.       Handle: DWORD;
  111.       Status: Integer;
  112.       Registered: Boolean;
  113.       procedure RegisterSelf;
  114.       procedure DeregisterSelf;
  115.  
  116.       function Startup: Boolean; virtual;
  117.       function Handshake: Boolean; virtual;
  118.       destructor Destroy; override;
  119.  
  120.       function Read(var B; Size: DWORD): DWORD;
  121.       function Write(const B; Size: DWORD): DWORD;
  122.       function WriteStr(const s: string): DWORD;
  123.  
  124.       function _Write(const B; Size: DWORD): DWORD; virtual;
  125.       function _Read(var B; Size: DWORD): DWORD; virtual;
  126.  
  127.     end;
  128.  
  129.   TObjProc = procedure of object;
  130.   TForEachProc = procedure(P: Pointer) of object;
  131.  
  132.   PFileInfo = ^TFileInfo;
  133.   TFileInfo = record
  134.     Attr: DWORD;
  135.     Size: DWORD;
  136.     Time: DWORD;
  137.   end;
  138.  
  139.   TuFindData = record
  140.     Info: TFileInfo;
  141.     FName: string;
  142.   end;
  143.  
  144.   TCreateFileMode = (
  145.  
  146.    cRead,            // Specifies read access to the file
  147.    cWrite,           // Specifies write access to the file
  148.  
  149.    cFlag,
  150.  
  151.    cEnsureNew,       // Creates a NEW file. The function fails
  152.                      // if the specified file already exists.
  153.  
  154.    cTruncate,        // Once opened, the file is truncated so that
  155.                      // its size is zero bytes.
  156.  
  157.    cExisting,        //  For communications resources, console diveces
  158.  
  159.    cShareAllowWrite,
  160.    cShareDenyRead,
  161.  
  162.    cOverlapped,      // This flag enables more than one operation to be
  163.                      // performed simultaneously with the handle
  164.                      // (e.g. a simultaneous read and write operation).
  165.  
  166.    cRandomAccess,    // Indicates that the file is accessed randomly.
  167.                      // Windows uses this flag to optimize file caching.
  168.  
  169.    cSequentialScan,  // Indicates that the file is to be accessed
  170.                      // sequentially from beginning to end.
  171.  
  172.    cDeleteOnClose    // Indicates that the operating system is to delete
  173.                      // the file immediately after all of its handles
  174.                      // have been closed.
  175.  
  176.                     );
  177.  
  178.    TCreateFileModeSet = set of TCreateFileMode;
  179.  
  180. { Character set type }
  181.  
  182.   PCharSet = ^TCharSet;
  183.   TCharSet = set of Char;
  184.  
  185. { General arrays }
  186.  
  187.  
  188.   PCharArray = ^TCharArray;
  189.   TCharArray = array[0..MaxLongInt-1] of Char;
  190.  
  191.   PByteArray = ^TByteArray;
  192.   TByteArray = array[0..MaxLongInt-1] of Byte;
  193.  
  194.   PIntArray = ^TIntArray;
  195.   TIntArray = array[0..(MaxLongInt div 4)-1] of Integer;
  196.  
  197.   PDwordArray = ^TDwordArray;
  198.   TDwordArray = array[0..(MaxLongInt div 4)-1] of DWORD;
  199.  
  200.  
  201.   PvIntArr = ^TvIntArr;
  202.   TvIntArr = record
  203.     Arr: PIntArray;
  204.     Cnt: Integer;
  205.   end;
  206.  
  207.   PBoolean   = ^Boolean;
  208.  
  209.  
  210.   PItemList = ^TItemList;
  211.   TItemList = array[0..MaxCollSize - 1] of Pointer;
  212.  
  213.   TThreadMethod = procedure of object;
  214.   TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
  215.     tpTimeCritical);
  216.  
  217.   TThread = class
  218.   private
  219.     FHandle: THandle;
  220.     FThreadID: THandle;
  221.     FTerminated: Boolean;
  222.     FSuspended: Boolean;
  223.     FFreeOnTerminate: Boolean;
  224.     FFinished: Boolean;
  225.     FReturnValue: DWORD;
  226.     function GetPriority: TThreadPriority;
  227.     procedure SetPriority(Value: TThreadPriority);
  228.     procedure SetSuspended(Value: Boolean);
  229.   protected
  230.     procedure Execute; virtual; abstract;
  231.     property ReturnValue: DWORD read FReturnValue write FReturnValue;
  232.     property Terminated: Boolean read FTerminated;
  233.   public
  234.     constructor Create(CreateSuspended: Boolean);
  235.     destructor Destroy; override;
  236.     procedure Resume;
  237.     procedure Suspend;
  238.     procedure Terminate;
  239.     property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
  240.     property Handle: THandle read FHandle;
  241.     property Priority: TThreadPriority read GetPriority write SetPriority;
  242.     property Suspended: Boolean read FSuspended write SetSuspended;
  243.     property ThreadID: THandle read FThreadID;
  244.   end;
  245.  
  246.   TAdvObject = class;
  247.  
  248.   TAdvObject = class
  249.   end;
  250.  
  251.   TAdvCpObject = class(TAdvObject)
  252.     function Copy: Pointer; virtual; abstract;
  253.   end;
  254.  
  255.   TAdvClass = class of TAdvObject;
  256.  
  257.   TCollClass = class of TColl;
  258.  
  259.   TListSortCompare = function (Item1, Item2: Pointer): Integer;
  260.  
  261.   TColl = class(TAdvCpObject)
  262.   protected
  263.     FCount: Integer;
  264.     FCapacity: Integer;
  265.     FDelta: Integer;
  266.     CS: TRTLCriticalSection;
  267.     Shared: Integer;
  268.   public
  269.     FList: PItemList;
  270.     procedure CopyItemsTo(Coll: TColl);
  271.     function Copy: Pointer; override;
  272.     function CopyItem(AItem: Pointer): Pointer; virtual;
  273.     procedure DoInit(ALimit, ADelta: Integer);
  274.     constructor Create;
  275.     destructor Destroy; override;
  276.     function At(Index: Integer): Pointer;
  277.     procedure AtDelete(Index: Integer);
  278.     procedure AtFree(Index: Integer);
  279.     procedure AtInsert(Index: Integer; Item: Pointer);
  280.     procedure AtPut(Index: Integer; Item: Pointer);
  281.     procedure Delete(Item: Pointer);
  282.     procedure DeleteAll;
  283.     procedure FFree(Item: Pointer);
  284.     procedure FreeAll;
  285.     procedure FreeItem(Item: Pointer); virtual;
  286.     function IndexOf(Item: Pointer): Integer; virtual;
  287.     procedure Insert(Item: Pointer); virtual;
  288.     procedure Add(Item: Pointer);
  289.     procedure Pack;
  290.     procedure SetCapacity(NewCapacity: Integer);
  291.     procedure MoveTo(CurIndex, NewIndex: Integer);
  292.     property Items[Idx: Integer]: Pointer read At write AtPut; default;
  293.     property Count: Integer read FCount;
  294.     property First: Pointer index 0 read At write AtPut;
  295.     procedure ForEach(Proc: TForEachProc); virtual;
  296.     procedure Sort(Compare: TListSortCompare);
  297.     procedure Concat(AColl: TColl);
  298.     procedure Enter;
  299.     procedure Leave;
  300.   end;
  301.  
  302.   TSortedColl = class(TColl)
  303.   public
  304.     Duplicates: Boolean;
  305.     function Compare(Key1, Key2: Pointer): Integer; virtual; abstract;
  306.     function KeyOf(Item: Pointer): Pointer; virtual;
  307.     function IndexOf(Item: Pointer): Integer; override;
  308.     procedure Insert(Item: Pointer); override;
  309.     function Search(Key: Pointer; var Index: Integer): Boolean; virtual;
  310.   end;
  311.  
  312. { TStringColl object }
  313.  
  314.   TStringColl = class(TSortedColl)
  315.   protected
  316.     procedure SetString(Index: Integer; const Value: string);
  317.     function GetString(Index: Integer): string;
  318.   public
  319.     function KeyOf(Item: Pointer): Pointer; override;
  320.     procedure FreeItem(Item: Pointer); override;
  321.     function Compare(Key1, Key2: Pointer): Integer; override;
  322.     function CopyItem(AItem: Pointer): Pointer; override;
  323.     function Copy: Pointer; override;
  324.     procedure Ins(const S: string);
  325.     procedure Ins0(const S: string);
  326.     procedure Add(const S: string);
  327.     procedure AtIns(Index: Integer; const Item: string);
  328.     property Strings[Index: Integer]: string read GetString write SetString; default;
  329.     function  IdxOf(Item: string): Integer;
  330.     procedure AppendTo(AColl: TStringColl);
  331.     procedure Concat(AColl: TStringColl);
  332.     procedure AddStrings(Strings: TStringColl; Sort: Boolean);
  333.     procedure Fill(const AStrs: array of string);
  334.     function Found(const Str: string): Boolean;
  335.     function FoundU(const Str: string): Boolean;
  336.     function FoundUC(const Str: string): Boolean;
  337.     procedure FillEnum(Str: string; Delim: Char; Sorted: Boolean);
  338.     function LongString: string;
  339.     function LongStringD(c: char): string;
  340.     procedure SetTextStr(const Value: string);
  341.   end;
  342.  
  343.  
  344. { --- string routines }
  345.  
  346. function  AddRightSpaces(const S: string; NumSpaces: Integer): string;
  347. procedure AddStr(var S: string ; C : char);
  348. procedure Add_Str(var S: ShortString ; C : char);
  349. function  CompareStr(const S1, S2: string): Integer; assembler;
  350. function  CopyLeft(const S: string; I: Integer): string;
  351. procedure DelDoubles(const St : string;var Source : string);
  352. procedure DelFC(var s: string);
  353. procedure DelLC(var s: string);
  354. function  DelLeft(const S: string): string;
  355. function  DelRight(const S: string): string;
  356. function  DelSpaces(const s: string): string;
  357. procedure DeleteLeft(var S: string; I: Integer);
  358. function  DigitsOnly(const AStr: string): Boolean;
  359. procedure DisposeStr(P: PString);
  360. function  ExpandFileName(const FileName: string): string;
  361. function  ExtractFilePath(const FileName: string): string;
  362. function  ExtractDir(const S: string): string;
  363. function  ExtractFileRoot(const FileName: string): string;
  364. function  ExtractFileExt(const FileName: string): string;
  365. function  ExtractFileName(const FileName: string): string;
  366. function  ExtractFileDrive(const FileName: string): string;
  367. function  ExtractFileDir(const FileName: string): string;
  368. procedure FSplit(const FName: string; var Path, Name, Ext: string);
  369. procedure FillCharSet(const AStr: string; var CharSet: TCharSet);
  370. procedure GetWrdStrictUC(var s,w:string);
  371. procedure GetWrdStrict(var s,w:string);
  372. procedure GetWrdD(var s,w:string);
  373. procedure GetWrdA(var s,w:string);
  374. procedure GetWrd(var s,w:string;c:char);
  375. function  Hex2(a: Byte): string;
  376. function  Hex4(a: Word): string;
  377. function  Hex8(a: DWORD): string;
  378. function  Int2Hex(a: Integer): string;
  379. function  Int2Str(L: Integer): string;
  380. function  ItoS(I: Integer): string;
  381. function  ItoSz(I, Width: Integer): string;
  382. function  LastDelimiter(const Delimiters, S: string): Integer;
  383. function  LowerCase(const S: string): string;
  384. function  MakeFullDir(const D, S: string): string;
  385. function  MakeNormName(const Path, Name: string): string;
  386. function  MonthE(m: Integer): string;
  387. function  NewStr(const S: string): PString;
  388. function  Replace(const Pattern, ReplaceString: string; var S: string): Boolean;
  389. function  StoI(const S: string): Integer;
  390. function  StrEnds(const S1, S2: string): Boolean;
  391. function  StrRight(const S: string; Num: Integer): string;
  392. function  UpperCase(const S: string): string;
  393. function  WipeChars(const AStr, AWipeChars: string): string;
  394. function  _Val(const S: string; var V: Integer): Boolean;
  395.  
  396. { --- RFC Routines }
  397.  
  398. function  ProcessQuotes(var s: string): Boolean;
  399. function  UnpackPchars(var s: string): Boolean;
  400. function  UnpackUchars(var s: string): Boolean;
  401. function  __alpha(c: char): Boolean;
  402. function  __ctl(c: char): Boolean;
  403. function  __digit(c: char): Boolean;
  404. function  __extra(c: char): Boolean;
  405. function  __national(c: char): Boolean;
  406. function  __pchar(c: char): Boolean;
  407. function  __reserved(c: char): Boolean;
  408. function  __safe(c: char): Boolean;
  409. function  __uchar(c: char): Boolean;
  410. function  __unsafe(c: char): Boolean;
  411.  
  412. { --- Basic Routines }
  413.  
  414. function  Buf2Str(const Buffer): string;
  415. procedure Clear(var Buf; Count: Integer);
  416. function  CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
  417. procedure FreeObject(var O);
  418. procedure LowerPrec(var A, B: Integer; Bits: Byte);
  419. function  MemEqu(const A, B; Sz: Integer): Boolean;
  420. function  MaxI(A, B: Integer): Integer;
  421. function  MinI(A, B: Integer): Integer;
  422. function  MaxD(A, B: DWORD): DWORD;
  423. function  MinD(A, B: DWORD): DWORD;
  424. function  NulSearch(const Buffer): Integer;
  425. function  NumBits(I: Integer): Integer;
  426. procedure XAdd(var Critical, Normal); assembler;
  427. procedure XChg(var Critical, Normal); assembler;
  428.  
  429. { --- Win32 Events Extentions }
  430.  
  431. function  CreateEvtA: DWORD;
  432. function  CreateEvt(Initial: Boolean): DWORD;
  433. function  SignaledEvt(id: DWORD): Boolean;
  434. function  WaitEvt(const id: TWOHandleArray; Timeout: DWORD): DWORD;
  435. function  WaitEvtA(nCount: Integer; lpHandles: PWOHandleArray; Timeout: DWORD): DWORD;
  436.  
  437. { --- Win32 API Hooks }
  438.  
  439. function  ClearHandle(var Handle: THandle): Boolean;
  440. procedure CloseHandles(const Handles: array of DWORD);
  441. function  FileExists(const FName: string): Boolean;
  442. function  FindExecutable(FileName, Directory: PChar; Result: PChar): HINST; stdcall;
  443. function  GetEnvVariable(const Name: string): string;
  444. function  GetFileNfo(const FName: string; var Info: TFileInfo; NeedAttr: Boolean): Boolean;
  445. function  GetFileNfoByHandle(Handle: DWORD; var Info: TFileInfo): Boolean;
  446. function  ZeroHandle(var Handle: THandle): Boolean;
  447.  
  448. function  _CreateFile(const FName: string; Mode: TCreateFileModeSet): DWORD;
  449. function  _CreateFileSecurity(const FName: string; Mode: TCreateFileModeSet; lpSecurityAttributes: PSecurityAttributes): DWORD;
  450. function  _GetFileSize(const FName: string): DWORD;
  451.  
  452. function _MatchMaskBody(AName, AMask: string; SupportPercent: Boolean): Boolean;
  453. function _MatchMask(const AName: string; AMask: string; SupportPercent: Boolean): Boolean;
  454. function MatchMask(const AName, AMask: string): Boolean;
  455.  
  456. function  SysErrorMsg(ErrorCode: DWORD): string;
  457.  
  458. { --- Registry Routines }
  459.  
  460. function  CreateRegKey(const AFName: string): HKey;
  461. function  OpenRegKeyEx(const AName: string; AMode: DWORD): HKey;
  462. function  OpenRegKey(const AName: string): DWORD;
  463. function  ReadRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  464. function  ReadRegInt(Key: DWORD; const AStrName: string): DWORD;
  465. function  ReadRegString(Key: DWORD; const AStrName: string): string;
  466. function  WriteRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  467. function  WriteRegInt(Key: DWORD; const AStrName: string; AValue: DWORD): Boolean;
  468. function  WriteRegString(Key: DWORD; const AStrName, AStr: string): Boolean;
  469.  
  470. { --- Winsock tools }
  471.  
  472. function  AddrInet(i: DWORD): string;
  473. function  GetHostNameByAddr(Addr: DWORD): string;
  474. function  Inet2addr(const s: string): DWORD;
  475. function  InetAddr(const s: string): DWORD;
  476.  
  477. { --- Misc tools }
  478.  
  479. procedure GlobalFail;
  480. function  _LogOK(const Name: string; var Handle: DWORD): Boolean;
  481. procedure xBaseDone;
  482. procedure xBaseInit;
  483. procedure uCvtSetFileTime(T: DWORD; var L, H: DWORD); 
  484. function uCvtGetFileTime(L, H: DWORD): DWORD;
  485. function uGetSystemTime: DWORD;
  486. function Vl(const s: string): DWORD;
  487.  
  488. type
  489.   TResetterThread = class(TThread)
  490.     TimeToSleep,
  491.     oSleep: DWORD;
  492.     constructor Create;
  493.     procedure Execute; override;
  494.     destructor Destroy; override;
  495.   end;
  496.  
  497.  
  498. var
  499.   ResetterThread: TResetterThread;
  500.   TimeZoneBias: Integer;
  501.   SocketsColl: TColl;
  502.   SocksCount: Integer;
  503.  
  504. const
  505.   CServerVersion = '1.4';
  506.   CServerProductName = {$IFDEF DEF_SSL}'TinySSL'{$ELSE}'TinyWeb'{$ENDIF};
  507.   CServerName = CServerProductName+'/'+CServerVersion;
  508.   CMB_FAILED = MB_APPLMODAL or MB_OK or MB_ICONSTOP;
  509.  
  510.  
  511. implementation
  512.  
  513.  
  514. ////////////////////////////////////////////////////////////////////////
  515. //                                                                    //
  516. //                          Time Routines                             //
  517. //                                                                    //
  518. ////////////////////////////////////////////////////////////////////////
  519.  
  520.  
  521.  
  522. const
  523.   cTimeHi   = 27111902;
  524.   cTimeLo   = -717324288;
  525.   cSecScale = 10000000;
  526.   cAgeScale = 10000;
  527.  
  528. function uCvtGetFileTime(L, H: DWORD): DWORD; assembler;
  529. asm
  530.   mov ecx, cSecScale
  531.   sub eax, cTimeLo
  532.   sbb edx, cTimeHi
  533.   jns @@ns
  534.   mov eax, 0
  535.   jmp @@ok
  536. @@ns:
  537.   div ecx
  538.   test eax, eax
  539.   jns @@ok
  540.   mov eax, MaxInt
  541. @@ok:
  542. end;
  543.  
  544. function uCvtGetFileAge(L, H: DWORD): DWORD; assembler;
  545. asm
  546.   mov ecx, cAgeScale
  547.   div ecx
  548. end;
  549.  
  550.  
  551. procedure uCvtSetFileTime(T: DWORD; var L, H: DWORD); assembler;
  552. asm
  553.   push edx
  554.   push ebx
  555.   mov  ebx, cSecScale
  556.   mul  ebx
  557.   pop  ebx
  558.   add  eax, cTimeLo
  559.   adc  edx, cTimeHi
  560.   mov  [ecx], edx
  561.   pop  edx
  562.   mov  [edx], eax
  563. end;
  564.  
  565.  
  566. procedure uNix2WinTime(I: DWORD; var T: TSystemTime);
  567. var
  568.   F: TFileTime;
  569. begin
  570.   uCvtSetFileTime(I, F.dwLowDateTime, F.dwHighDateTime);
  571.   FileTimeToSystemTime(F, T);
  572. end;
  573.  
  574. function uWin2NixTime(const T: TSystemTime): DWORD;
  575. var
  576.   F: TFileTime;
  577. begin
  578.   SystemTimeToFileTime(T, F);
  579.   Result := uCvtGetFileTime(F.dwLowDateTime, F.dwHighDateTime);
  580. end;
  581.  
  582.  
  583.  
  584. function uGetLocalTime: DWORD;
  585. begin
  586.   Result := uGetLocalTime;
  587. end;
  588.  
  589. function uGetSystemTime: DWORD;
  590. var
  591.   T: TFileTime;
  592. begin
  593.   GetSystemTimeAsFileTime(T);
  594.   Result := uCvtGetFileTime(T.dwLowDateTime, T.dwHighDateTime);
  595. end;
  596.  
  597. function uSetFileTimeByHandle(Handle: DWORD; uTime: DWORD): Boolean;
  598. var
  599.   F: TFileTime;
  600. begin
  601.   uCvtSetFileTime(uTime, F.dwLowDateTime, F.dwHighDateTime);
  602.   Result := SetFileTime(Handle, nil, nil, @F);
  603. end;
  604.  
  605. function uSetFileTime(const FName: string; uTime: DWORD): Boolean;
  606. var
  607.   Handle: DWORD;
  608. begin
  609.   Result := False;
  610.   Handle := _CreateFile(FName, [cWrite, cExisting]);
  611.   if Handle = INVALID_HANDLE_VALUE then Exit;
  612.   Result := uSetFileTimeByHandle(Handle, uTime);
  613.   CloseHandle(Handle);
  614. end;
  615.  
  616. procedure CvtFD(const wf: TWin32FindData; var FindData: TuFindData);
  617. begin
  618.   FindData.Info.Attr := wf.dwFileAttributes;
  619.   FindData.Info.Time := uCvtGetFileTime(wf.ftLastWriteTime.dwLowDateTime, wf.ftLastWriteTime.dwHighDateTime);
  620.   FindData.Info.Size := wf.nFileSizeLow;
  621.   FindData.FName := Buf2Str(wf.cFileName);
  622. end;
  623.  
  624. function uFindFirst(const FName: string; var FindData: TuFindData): DWORD;
  625. var
  626.   wf: TWin32FindData;
  627. begin
  628.   Result := FindFirstFile(PChar(FName), wf);
  629.   if Result <> INVALID_HANDLE_VALUE then CvtFD(wf, FindData);
  630. end;
  631.  
  632. function uFindNext(Handle: DWORD; var FindData: TuFindData): Boolean;
  633. var
  634.   wf: TWin32FindData;
  635. begin
  636.   Result := FindNextFile(Handle, wf);
  637.   if Result then CvtFD(wf, FindData);
  638. end;
  639.  
  640. function uFindClose(Handle: DWORD): Boolean;
  641. begin
  642.   Result := Windows.FindClose(Handle);
  643. end;
  644.  
  645.  
  646.  
  647. ////////////////////////////////////////////////////////////////////////
  648. //                                                                    //
  649. //                         string Routines                            //
  650. //                                                                    //
  651. ////////////////////////////////////////////////////////////////////////
  652.  
  653.  
  654. function IsWild(const S: string): Boolean;
  655. begin
  656.   Result := (Pos('*',S)>0) or (Pos('?', S)>0);
  657. end;
  658.  
  659. function TrimZeros(S: string): string;
  660. var
  661.   I, J : Integer;
  662. begin
  663.   I := Length(S);
  664.   while (I > 0) and (S[I] <= ' ') do
  665.     Dec(I);
  666.   J := 1;
  667.   while (J < I) and ((S[J] <= ' ') or (S[J] = '0')) do
  668.     Inc(J);
  669.   TrimZeros := Copy(S, J, (I-J)+1);
  670. end;
  671.  
  672. function BothKVC(const S: string): Boolean;
  673. begin
  674.   Result := (Copy(S, 1, 1)='"') and (Copy(S, Length(S), 1)='"');
  675. end;
  676.  
  677. function AddRightSpaces;
  678. begin
  679.   SetLength(Result, NumSpaces);
  680.   FillChar(Result[1], NumSpaces, ' ');
  681.   Move(S[1], Result[1], MinI(NumSpaces, Length(S)));
  682. end;
  683.  
  684. function Hex2;
  685. begin
  686.   SetLength(Result, 2);
  687.   Result[1] := rrLoHexChar[a shr 4];
  688.   Result[2] := rrLoHexChar[a and $F];
  689. end;
  690.  
  691. function Hex4;
  692.   var I: Integer;
  693. begin
  694.   SetLength(Result, 4);
  695.   for I := 0 to 3 do
  696.     begin Result[4-I] := rrLoHexChar[A and $F]; A := A shr 4; end;
  697. end;
  698.  
  699. function Hex8;
  700.   var I: DWORD;
  701. begin
  702.   SetLength(Result, 8);
  703.   for I := 0 to 7 do
  704.     begin Result[8-I] := rrLoHexChar[A and $F]; A := A shr 4; end;
  705. end;
  706.  
  707. function Int2Hex(a: Integer): string;
  708. begin
  709.   Result := Hex8(a);
  710.   while (Length(Result)>1) and (Result[1]='0') do DelFC(Result);
  711. end;
  712.  
  713. function MakeFullDir(const D, S: string): string;
  714. begin
  715.   if (Pos(':', S) > 0) or (Copy(S, 1, 2) = '\\') then Result := S else
  716.     if Copy(S, 1, 1) = '\' then Result := MakeNormName(Copy(D, 1, Pos(':',D)), Copy(S, 2, Length(S)-1)) else
  717.       Result := MakeNormName(D,S);
  718. end;
  719.  
  720. function ExtractDir;
  721. var
  722.   i: Integer;
  723. begin
  724.   Result := S; i := Length(S);
  725.   if (i > 3) and (S[i] = '\') then DelLC(Result);
  726. end;
  727.  
  728. function MakeNormName;
  729. begin
  730.   Result := Path;
  731.   if (Result <> '') and (Result[Length(Result)] <> '\') then AddStr(Result, '\');
  732.   Result := Result + Name;
  733. end;
  734.  
  735. procedure AddStr;
  736. begin
  737.   S := S + C;
  738. end;
  739.  
  740. procedure Add_Str(var S: ShortString ; C : char);
  741. var
  742.   sl: Byte absolute S;
  743. begin
  744.   Inc(sl); S[sl] := C;
  745. end;
  746.  
  747. procedure FSplit(const FName: string; var Path, Name, Ext: string);
  748. type
  749.   TStep = (sExt, sName, sPath);
  750. var
  751.   Step : TStep;
  752.   I: Integer;
  753.   C: Char;
  754. begin
  755.   I := Length(FName);
  756.   if Pos('.', FName) = 0 then Step := sName else Step := sExt;
  757.   Path := ''; Name := ''; Ext  := '';
  758.   while I > 0 do
  759.   begin
  760.     C := FName[I]; Dec(I);
  761.     case Step of
  762.       sExt  : begin Ext := C + Ext; if C = '.' then Inc(Step) end;
  763.       sName : if C = '\' then begin Path := C; Inc(Step) end else Name := C + Name;
  764.       sPath : Path := C + Path;
  765.     end;
  766.   end;
  767. end;
  768.  
  769.  
  770. function Replace;
  771.  var I, J: Integer;
  772.      LP, LR: Integer;
  773. begin
  774.  Result := False;
  775.  J := 1;
  776.  LP := Length(Pattern);
  777.  LR := Length(ReplaceString);
  778.  repeat
  779.   I := Pos(Pattern, CopyLeft(S, J));
  780.   if I > 0 then
  781.    begin
  782.     Delete(S, J+I-1, LP);
  783.     Insert(ReplaceString, S, J+I-1);
  784.     Result := True;
  785.    end;
  786.   Inc(J, I + LR - 1);
  787.  until I = 0;
  788. end;
  789.  
  790. procedure DelDoubles;
  791. var
  792.   i: Integer;
  793. begin
  794.   repeat
  795.     i := Pos(ST,Source);
  796.     if i = 0 then Break;
  797.     Delete(Source,I,1);
  798.   until False;
  799. end;
  800.  
  801. function ItoS(I: Integer): string;
  802. begin
  803.   Str(I, Result);
  804. end;
  805.  
  806. function ItoSz(I, Width: Integer): string;
  807. begin
  808.   Result := ItoS(I);
  809.   while Length(Result)<Width do Result := '0'+Result;
  810. end;
  811.  
  812. function DelLeft(const S: string): string;
  813. var
  814.   I, L: Integer;
  815. begin
  816.   I := 1;
  817.   L := Length(S);
  818.   while I<=L do
  819.   begin
  820.     case S[I] of #9, ' ':; else Break end;
  821.     Inc(I);
  822.   end;
  823.   Result := Copy(S, I, L+1-I);
  824. end;
  825.  
  826. function DelRight(const S: string): string;
  827. var
  828.   I: Integer;
  829. begin
  830.   I := Length(S);
  831.   while I>0 do
  832.   begin
  833.     case S[I] of #9, ' ':; else Break end;
  834.     Dec(I);
  835.   end;
  836.   Result := Copy(S, 1, I);
  837. end;
  838.  
  839. function DelSpaces(const s: string): string;
  840. begin
  841.   Result := DelLeft(DelRight(s));
  842. end;
  843.  
  844. procedure DelFC(var s: string);
  845. begin
  846.   Delete(s, 1, 1);
  847. end;
  848.  
  849. procedure DelLC(var s: string);
  850. var
  851.   l: Integer;
  852. begin
  853.   l := Length(s);
  854.   case l of
  855.     0 : ;
  856.     1 : s := '';
  857.     else SetLength(s, l-1);
  858.   end;
  859. end;
  860.  
  861. function Int2Str(L: Integer): string;
  862. var I: Integer;
  863. begin
  864.   Result := ItoS(L);
  865.   I := Length(Result)-2;
  866.   while I > 1 do
  867.     begin
  868.       Insert(','{ThousandSeparator}, Result, I);
  869.       Dec(I, 3);
  870.     end;
  871. end;
  872.  
  873. function ExtractFileRoot(const FileName: string): string;
  874. begin
  875.   Result := Copy(FileName, 1, Pos(':',FileName)+1);
  876. end;
  877.  
  878. function WipeChars;
  879. var
  880.   i, j: Integer;
  881. begin
  882.   Result := ''; j := Length(AStr);
  883.   for i := 1 to j do if Pos(AStr[I], AWipeChars) = 0 then AddStr(Result, AStr[I]);
  884. end;
  885.  
  886. procedure FillCharSet(const AStr: string; var CharSet: TCharSet);
  887. var
  888.   i: Integer;
  889. begin
  890.   CharSet := [];
  891.   for i := 1 to Length(AStr) do Include(CharSet, AStr[i]);
  892. end;
  893.  
  894. function DigitsOnly(const AStr: string): Boolean;
  895. var
  896.   i: Integer;
  897. begin
  898.   Result := False;
  899.   if AStr = '' then Exit;
  900.   for i := 1 to Length(AStr) do if not __digit(AStr[i]) then Exit;
  901.   Result := True;
  902. end;
  903.  
  904. procedure GetWrdD(var s,w:string);
  905. begin
  906.  w:=''; if s='' then Exit;
  907.  while (Length(s)>0) and ((s[1]<'0') or (s[1]>'9')) do begin DelFC(s) end;
  908.  while (Length(s)>0) and (s[1]>='0') and (s[1]<='9') do begin w:=w+s[1];DelFC(s) end;
  909.  DelFC(s);
  910. end;
  911.  
  912. procedure GetWrdA(var s,w:string);
  913. begin
  914.  w:=''; if s='' then Exit;
  915.  while (Length(s)>0) and ((UpCase(s[1])<'A') or (UpCase(s[1])>'Z')) do begin DelFC(s) end;
  916.  while (Length(s)>0) and (UpCase(s[1])>='A') and (UpCase(s[1])<='Z') do begin w:=w+s[1];DelFC(s) end;
  917.  DelFC(s);
  918. end;
  919.  
  920.  
  921. procedure GetWrd(var s,w:string;c:char);
  922. begin
  923.  w:=''; if s='' then Exit;
  924.  if c = ' ' then s := DelSpaces(s);
  925.  while (Length(s)>0) and (s[1]<>c) do begin w:=w+s[1];DelFC(s) end;
  926.  DelFC(s);
  927. end;
  928.  
  929. procedure GetWrdStrict(var s,w:string);
  930. begin
  931.   w:=''; if s='' then Exit;
  932.   while (Length(s)>0) and (s[1]<>' ') do begin w:=w+s[1];DelFC(s) end;
  933.   DelFC(s);
  934. end;
  935.  
  936. procedure GetWrdStrictUC(var s,w:string);
  937. begin
  938.   w:=''; if s='' then Exit;
  939.   while (Length(s)>0) and (s[1]<>' ') do begin w:=w+UpCase(s[1]);DelFC(s) end;
  940.   DelFC(s);
  941. end;
  942.  
  943. function StrRight(const S: string; Num: Integer): string;
  944. begin
  945.   Result := Copy(S, Length(S)-Num+1, Num);
  946. end;
  947.  
  948. function StrEnds(const S1, S2: string): Boolean;
  949. begin
  950.   Result := StrRight(S1, Length(S2)) = S2;
  951. end;
  952.  
  953. function CopyLeft(const S: string; I: Integer): string;
  954. begin
  955.   Result := Copy(S, I, Length(S)-I+1);
  956. end;
  957.  
  958. procedure DeleteLeft(var S: string; I: Integer);
  959. begin
  960.   Delete(S, I, Length(S)-I+1);
  961. end;
  962.  
  963.  
  964. ////////////////////////////////////////////////////////////////////////
  965. //                                                                    //
  966. //                          Basic Routines                            //
  967. //                                                                    //
  968. ////////////////////////////////////////////////////////////////////////
  969.  
  970. procedure Clear(var Buf; Count: Integer);
  971. begin
  972.   FillChar(Buf, Count, 0);
  973. end;
  974.  
  975. function MemEqu(const A, B; Sz: Integer): Boolean;
  976. asm
  977.     push  ebx
  978.     xchg  eax, ebx
  979.     jmp   @1
  980.  
  981. @0: inc   edx
  982. @1: mov   al, [ebx]
  983.     inc   ebx
  984.     cmp   al, [edx]
  985.     jne   @@Wrong
  986.     dec   ecx
  987.     jnz   @0
  988.  
  989.     mov   eax, 1
  990.     jmp   @@End
  991. @@Wrong:
  992.     mov   eax, 0
  993. @@End:
  994.     pop   ebx
  995. end;
  996.  
  997. function MaxI(A, B: Integer): Integer; assembler;
  998. asm
  999.   cmp  eax, edx
  1000.   jg   @@g
  1001.   xchg eax, edx
  1002. @@g:
  1003. end;
  1004.  
  1005.  
  1006. function MinI(A, B: Integer): Integer; assembler;
  1007. asm
  1008.   cmp  eax, edx
  1009.   jl   @@l
  1010.   xchg eax, edx
  1011. @@l:
  1012. end;
  1013.  
  1014.  
  1015. function MaxD(A, B: DWORD): DWORD; assembler;
  1016. asm
  1017.   cmp  eax, edx
  1018.   ja   @@a
  1019.   xchg eax, edx
  1020. @@a:
  1021. end;
  1022.  
  1023.  
  1024. function MinD(A, B: DWORD): DWORD; assembler;
  1025. asm
  1026.   cmp  eax, edx
  1027.   jb   @@b
  1028.   xchg eax, edx
  1029. @@b:
  1030. end;
  1031.  
  1032. procedure XChg(var Critical, Normal); assembler;
  1033. asm
  1034.   mov  ecx, [edx]
  1035.   xchg [eax], ecx
  1036.   mov  [edx], ecx
  1037. end;
  1038.  
  1039. function NulSearch; assembler;
  1040. asm;
  1041.   CLD
  1042.   PUSH    EDI
  1043.   MOV     EDI, Buffer
  1044.   XOR     AL,  AL
  1045.   MOV     ECX, -1
  1046.   REPNE   SCASB
  1047.   XCHG    EAX,ECX
  1048.   NOT     EAX
  1049.   DEC     EAX
  1050.   POP     EDI
  1051. end;
  1052.  
  1053. function Buf2Str(const Buffer): string;
  1054. var
  1055.   I: Integer;
  1056. begin
  1057.   I := NulSearch(Buffer);
  1058.   if I = 0 then Result := '' else
  1059.   begin
  1060.     SetLength(Result, I);
  1061.     Move(Buffer, Result[1], I);
  1062.   end;
  1063. end;
  1064.  
  1065. procedure LowerPrec(var A, B: Integer; Bits: Byte);
  1066. var
  1067.   C: ShortInt;
  1068. begin
  1069.   C := MaxI(NumBits(A), NumBits(B))-Bits;
  1070.   if C <= 0 then Exit;
  1071.   A := A shr C;
  1072.   B := B shr C;
  1073. end;
  1074.  
  1075.  
  1076.  
  1077. ////////////////////////////////////////////////////////////////////////
  1078. //                                                                    //
  1079. //                      Win32 Events Extentions                       //
  1080. //                                                                    //
  1081. ////////////////////////////////////////////////////////////////////////
  1082.  
  1083.  
  1084.  
  1085. function CreateEvtA;
  1086. begin
  1087.   Result := CreateEvent(nil, False, False, nil);
  1088. end;
  1089.  
  1090. function CreateEvt;
  1091. begin
  1092.   CreateEvt := CreateEvent(nil,      // address of security attributes
  1093.                            True,     // flag for manual-reset event
  1094.                            Initial,  // flag for initial state
  1095.                            nil);     // address of event-object name
  1096. end;
  1097.  
  1098. function  WaitEvtA(nCount: Integer; lpHandles: PWOHandleArray; Timeout: DWORD): DWORD;
  1099. begin
  1100.   if Timeout = High(Timeout) then Timeout := INFINITE;
  1101.   if nCount = 1 then Result := WaitForSingleObject(lpHandles^[0], Timeout) else
  1102.                      Result := WaitForMultipleObjects(nCount, lpHandles, False, Timeout);
  1103. end;
  1104.  
  1105. function WaitEvt;
  1106. begin
  1107.   Result := WaitEvtA(High(id)+1, @id, Timeout);
  1108. end;
  1109.  
  1110. function SignaledEvt(id: DWORD): Boolean;
  1111. begin
  1112.   SignaledEvt := WaitForSingleObject(id, 0) = id;
  1113. end;
  1114.  
  1115.  
  1116. ////////////////////////////////////////////////////////////////////////
  1117. //                                                                    //
  1118. //                      Win32 API Hooks                               //
  1119. //                                                                    //
  1120. ////////////////////////////////////////////////////////////////////////
  1121.  
  1122. procedure CloseHandles(const Handles: array of DWORD);
  1123. var
  1124.   i: Integer;
  1125. begin
  1126.   for i:=0 to High(Handles) do CloseHandle(Handles[i]);
  1127. end;
  1128.  
  1129. function FileExists(const FName: string): Boolean;
  1130. var
  1131.   Handle: DWORD;
  1132. begin
  1133.   Result := False;
  1134.   Handle := _CreateFile(FName, [cRead, cShareAllowWrite]);
  1135.   if Handle = INVALID_HANDLE_VALUE then Exit;
  1136.   Result := ZeroHandle(Handle);
  1137. end;
  1138.  
  1139. function GetFileNfo;
  1140. var
  1141.   Handle: DWORD;
  1142. begin
  1143.   Result := False;
  1144.   Handle := _CreateFile(FName, [cRead, cShareAllowWrite]);
  1145.   if Handle = INVALID_HANDLE_VALUE then Exit;
  1146.   Result := GetFileNfoByHandle(Handle, Info);
  1147.   CloseHandle(Handle);
  1148.   if NeedAttr and Result and (Info.Attr = INVALID_FILE_ATTRIBUTES) then Result := GetFileAttributes(PChar(FName)) <> INVALID_FILE_ATTRIBUTES;
  1149. end;
  1150.  
  1151. function GetFileNfoByHandle;
  1152. var
  1153.   i: TByHandleFileInformation;
  1154. begin
  1155.   Result := False;
  1156.   if Handle = INVALID_HANDLE_VALUE then Exit;
  1157.   i.dwFileAttributes := INVALID_FILE_ATTRIBUTES;
  1158.   i.nFileSizeLow := GetFileSize(Handle, nil);
  1159.   Result := (i.nFileSizeLow <> INVALID_FILE_SIZE) and GetFileTime(Handle, nil, nil, @i.ftLastWriteTime);
  1160.   if not Result then Exit;
  1161.   Info.Size := i.nFileSizeLow;
  1162.   Info.Attr := i.dwFileAttributes;
  1163.   Info.Time := uCvtGetFileTime(i.ftLastWriteTime.dwLowDateTime, i.ftLastWriteTime.dwHighDateTime);
  1164.   Result := True;
  1165. end;
  1166.  
  1167.  
  1168. function ClearHandle(var Handle: DWORD): Boolean;
  1169. begin
  1170.   if Handle = INVALID_HANDLE_VALUE then Result := False else
  1171.   begin
  1172.     Result := CloseHandle(Handle);
  1173.     Handle := INVALID_HANDLE_VALUE;
  1174.   end;
  1175. end;
  1176.  
  1177. function ZeroHandle(var Handle: DWORD): Boolean;
  1178. begin
  1179.   if (Handle = INVALID_HANDLE_VALUE) or
  1180.      (Handle = 0) then Result := False else
  1181.   begin
  1182.     Result := CloseHandle(Handle);
  1183.     Handle := 0;
  1184.   end;
  1185. end;
  1186.  
  1187. procedure _PostMessage(a, b, c, d: DWORD);
  1188. begin
  1189.   if not PostMessage(a, b, c, d) then
  1190.     GlobalFail;
  1191. end;
  1192.  
  1193. function _CreateFile;
  1194. begin
  1195.   Result := _CreateFileSecurity(FName, Mode, nil);
  1196. end;
  1197.  
  1198. function _CreateFileSecurity;
  1199. var
  1200.   Access,Share,Disp,Flags: DWORD;
  1201.  
  1202. const
  1203.   NumDispModes = 5;
  1204.   DispArr : array[1..NumDispModes] of
  1205.     record
  1206.       w: Boolean; {Write}
  1207.       n: Boolean; {EnsureNew}
  1208.       t: Boolean; {Truncate}
  1209.       d: DWORD; {Disp}
  1210.     end =
  1211.      ( (w:False; n:False; t:False; d:OPEN_EXISTING),
  1212.        (w:True;  n:False; t:False; d:OPEN_ALWAYS),
  1213.        (w:True;  n:True;  t:False; d:CREATE_NEW),
  1214.        (w:True;  n:False; t:True;  d:CREATE_ALWAYS),
  1215.        (w:True;  n:True;  t:True;  d:TRUNCATE_EXISTING) );
  1216. begin
  1217.  
  1218. // Prepare Disp & Flags
  1219.  
  1220.   Flags := FILE_ATTRIBUTE_NORMAL;
  1221.   Access := 0;
  1222.   Share := 0;
  1223.   Disp := 0;
  1224.  
  1225.   if cFlag in Mode then
  1226.   begin
  1227.     Disp := CREATE_NEW;
  1228.     Flags := Flags or FILE_FLAG_DELETE_ON_CLOSE
  1229.   end else
  1230.   begin
  1231.  
  1232.     if cTruncate in Mode then Mode := Mode + [cWrite];
  1233.  
  1234.     if cExisting in Mode then Disp := OPEN_EXISTING else
  1235.     begin
  1236.       if cWrite in Mode then Flags := FILE_ATTRIBUTE_ARCHIVE;
  1237.       repeat
  1238.         Inc(Disp); if Disp > NumDispModes then GlobalFail;
  1239.         with DispArr[Disp] do
  1240.         if (w = (cWrite in Mode)) and
  1241.            (n = (cEnsureNew in Mode)) and
  1242.            (t = (cTruncate in Mode)) then begin Disp := d; Break end;
  1243.       until False;
  1244.  
  1245.     end;
  1246.  
  1247.     if cOverlapped in Mode then Flags := Flags or FILE_FLAG_OVERLAPPED;
  1248.     if cRandomAccess in Mode then Flags := Flags or FILE_FLAG_RANDOM_ACCESS;
  1249.     if cSequentialScan in Mode then Flags := Flags or FILE_FLAG_SEQUENTIAL_SCAN;
  1250.     if cDeleteOnClose in Mode then Flags := Flags or FILE_FLAG_DELETE_ON_CLOSE;
  1251.  
  1252.  
  1253.   // Prepare 'Access' and 'Share'
  1254.  
  1255.     if cShareAllowWrite in Mode then Share := FILE_SHARE_WRITE;
  1256.     if cRead  in Mode then begin Access := Access or GENERIC_READ;  Share := Share or FILE_SHARE_READ end;
  1257.     if cWrite in Mode then begin Access := Access or GENERIC_WRITE; Share := Share or FILE_SHARE_READ end;
  1258.     if cShareDenyRead in Mode then Share := Share and not FILE_SHARE_READ;
  1259.   end;
  1260.  
  1261.   Result := CreateFile(PChar(FName), Access, Share, lpSecurityAttributes, Disp, Flags, 0);
  1262. end;
  1263.  
  1264.  
  1265. function _GetFileSize;
  1266. var
  1267.   H: DWORD;
  1268. begin
  1269.   Result := INVALID_FILE_SIZE;
  1270.   H := _CreateFile(FName, [cRead]);
  1271.   if H = INVALID_HANDLE_VALUE then Exit;
  1272.   Result := GetFileSize(H, nil);
  1273.   CloseHandle(H);
  1274. end;
  1275.  
  1276.  
  1277.  
  1278.  
  1279. function WindowsDirectory: string;
  1280. begin
  1281.   SetLength(Result, MAX_PATH);
  1282.   GetWindowsDirectory(PChar(Result), MAX_PATH);
  1283.   SetLength(Result, NulSearch(Result[1]));
  1284. end;
  1285.  
  1286.  
  1287.  
  1288. ////////////////////////////////////////////////////////////////////////
  1289. //                                                                    //
  1290. //                      Registry Routines                             //
  1291. //                                                                    //
  1292. ////////////////////////////////////////////////////////////////////////
  1293.  
  1294. function OpenRegKeyEx(const AName: string; AMode: DWORD): HKey;
  1295. begin
  1296.   if RegOpenKeyEx(
  1297.     HKEY_LOCAL_MACHINE,      // handle of an open key
  1298.     PChar(AName),           // subkey name
  1299.     0,                       // Reserved
  1300.     AMode,
  1301.     Result
  1302.   ) <> ERROR_SUCCESS then Result := INVALID_REGISTRY_KEY;
  1303. end;
  1304.  
  1305. function OpenRegKey(const AName: string): DWORD;
  1306. begin
  1307.   Result := OpenRegKeyEx(AName, KEY_QUERY_VALUE);
  1308. end;
  1309.  
  1310. function CreateRegKey(const AFName: string): HKey;
  1311. var
  1312.   Disp: DWORD;
  1313. begin
  1314.   if RegCreateKeyEx(
  1315.     HKEY_LOCAL_MACHINE,      // handle of an open key
  1316.     PChar(AFName),           // subkey name
  1317.     0,                       // reserved, must be zero
  1318.     nil,                     // address of class string
  1319.     REG_OPTION_NON_VOLATILE, // options flag
  1320.     KEY_WRITE,               // desired security access
  1321.     nil,                     // security attributes
  1322.     Result,                  // address of buffer for opened handle
  1323.     @Disp                    // address of disposition value buffer
  1324.   ) <> ERROR_SUCCESS then begin
  1325.     Result := INVALID_REGISTRY_KEY;
  1326.   end;
  1327.  
  1328. end;
  1329.  
  1330. function WriteRegString(Key: DWORD; const AStrName, AStr: string): Boolean;
  1331. begin
  1332.   Result := RegSetValueEx(Key, PChar(AStrName), 0, REG_SZ, PChar(AStr), Length(AStr)+1) = ERROR_SUCCESS;
  1333. end;
  1334.  
  1335.  
  1336. function ReadRegString(Key: DWORD; const AStrName: string): string;
  1337. var
  1338.   l, t,e: DWORD;
  1339.   z: ShortString;
  1340. begin
  1341.   z[0] := #250;
  1342.   l := 250;
  1343.   t := REG_SZ;
  1344.   e := RegQueryValueEx(
  1345.     Key,             // handle of key to query
  1346.     PChar(AStrName), // value to query
  1347.     nil,             // reserved
  1348.     @t,              // value type
  1349.     @z[1],           // data buffer
  1350.     @l               // buffer size
  1351.   );
  1352.   if e <> ERROR_SUCCESS then Result := '' else
  1353.   begin
  1354.     Result := Copy(z, 1, NulSearch(z[1]));
  1355.   end;
  1356. end;
  1357.  
  1358. function WriteRegInt(Key: DWORD; const AStrName: string; AValue: DWORD): Boolean;
  1359. begin
  1360.   Result := RegSetValueEx(Key, PChar(AStrName), 0, REG_DWORD, @AValue, SizeOf(AValue)) = ERROR_SUCCESS;
  1361. end;
  1362.  
  1363. function ReadRegInt(Key: DWORD; const AStrName: string): DWORD;
  1364. var
  1365.   t, e, s: DWORD;
  1366.   b: Integer;
  1367. begin
  1368.   t := REG_DWORD;;
  1369.   s := SizeOf(b);
  1370.   e := RegQueryValueEx(
  1371.     Key,             // handle of key to query
  1372.     PChar(AStrName), // value to query
  1373.     nil,             // reserved
  1374.     @t,              // value type
  1375.     @b,              // data buffer
  1376.     @s               // buffer size
  1377.   );
  1378.   if e <> ERROR_SUCCESS then Result := INVALID_REGISTRY_KEY else Result := b;
  1379. end;
  1380.  
  1381. function WriteRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  1382. begin
  1383.   Result := RegSetValueEx(Key, PChar(rvn), 0, REG_BINARY, Bin, Sz) = ERROR_SUCCESS;
  1384. end;
  1385.  
  1386. function ReadRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  1387. var
  1388.   t, e, s: DWORD;
  1389. begin
  1390.   t := REG_BINARY;;
  1391.   s := Sz;
  1392.   e := RegQueryValueEx(
  1393.     Key,             // handle of key to query
  1394.     PChar(rvn),      // value to query
  1395.     nil,             // reserved
  1396.     @t,              // value type
  1397.     Bin,             // data buffer
  1398.     @s               // buffer size
  1399.   );
  1400.   Result := e = ERROR_SUCCESS;
  1401. end;
  1402.  
  1403. ////////////////////////////////////////////////////////////////////////
  1404. //                                                                    //
  1405. //                             Objects                                //
  1406. //                                                                    //
  1407. ////////////////////////////////////////////////////////////////////////
  1408.  
  1409.  
  1410. function SysErrorMsg(ErrorCode: DWORD): string;
  1411. var
  1412.   Len: Integer;
  1413.   Buffer: array[0..255] of Char;
  1414. begin
  1415.   Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
  1416.     FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
  1417.     SizeOf(Buffer), nil);
  1418.   while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
  1419.   SetString(Result, Buffer, Len);
  1420. end;
  1421.  
  1422. procedure QuickSort(SortList: PItemList; L, R: Integer;
  1423.   SCompare: TListSortCompare);
  1424. var
  1425.   I, J: Integer;
  1426.   P, T: Pointer;
  1427. begin
  1428.   repeat
  1429.     I := L;
  1430.     J := R;
  1431.     P := SortList^[(L + R) shr 1];
  1432.     repeat
  1433.       while SCompare(SortList^[I], P) < 0 do Inc(I);
  1434.       while SCompare(SortList^[J], P) > 0 do Dec(J);
  1435.       if I <= J then
  1436.       begin
  1437.         T := SortList^[I];
  1438.         SortList^[I] := SortList^[J];
  1439.         SortList^[J] := T;
  1440.         Inc(I);
  1441.         Dec(J);
  1442.       end;
  1443.     until I > J;
  1444.     if L < J then QuickSort(SortList, L, J, SCompare);
  1445.     L := I;
  1446.   until I >= R;
  1447. end;
  1448.  
  1449.  
  1450. { ---- TColl ---- }
  1451.  
  1452. procedure TColl.Sort(Compare: TListSortCompare);
  1453. begin
  1454.   if (FList <> nil) and (Count > 0) then
  1455.     QuickSort(FList, 0, Count - 1, Compare);
  1456. end;
  1457.  
  1458.  
  1459. function TColl.Copy;
  1460. begin
  1461.   Result := TColl.Create;
  1462.   CopyItemsTo(TColl(Result));
  1463. end;
  1464.  
  1465. procedure TColl.CopyItemsTo;
  1466. var
  1467.   i: Integer;
  1468. begin
  1469.   Coll.FreeAll;
  1470.   for i := 0 to Count-1 do Coll.AtInsert(Coll.Count, CopyItem(At(i)));
  1471. end;
  1472.  
  1473. function TColl.CopyItem(AItem: Pointer): Pointer;
  1474. begin
  1475.   Result := TAdvCpObject(AItem).Copy;
  1476. end;
  1477.  
  1478. procedure TColl.Concat(AColl: TColl);
  1479. var
  1480.   i: Integer;
  1481. begin
  1482.   for i := 0 to AColl.Count-1 do Insert(AColl[i]);
  1483.   AColl.DeleteAll;
  1484. end;
  1485.  
  1486.  
  1487. procedure TColl.Enter;
  1488. var
  1489.   j: Integer;
  1490. begin
  1491.   j := 1; Xchg(Shared, j); if j = 0 then InitializeCriticalSection(CS);
  1492.   EnterCriticalSection(CS);
  1493. end;
  1494.  
  1495. procedure TColl.Leave;
  1496. begin
  1497.   LeaveCriticalSection(CS);
  1498. end;
  1499.  
  1500. procedure TColl.ForEach(Proc: TForEachProc);
  1501. var
  1502.   i: Integer;
  1503. begin
  1504.   for i := 0 to Count-1 do Proc(FList^[I]);
  1505. end;
  1506.  
  1507. constructor TColl.Create;
  1508. begin
  1509.   inherited Create;
  1510.   DoInit(32,64);
  1511. end;
  1512.  
  1513. procedure TColl.DoInit(ALimit, ADelta: Integer);
  1514. begin
  1515.   FList := nil;
  1516.   FCount := 0;
  1517.   FCapacity := 0;
  1518.   FDelta := ADelta;
  1519.   SetCapacity(ALimit);
  1520. end;
  1521.  
  1522.  
  1523. destructor TColl.Destroy;
  1524. begin
  1525.   if Shared = 1 then DeleteCriticalSection(CS);
  1526.   FreeAll;
  1527.   SetCapacity(0);
  1528.   inherited Destroy;
  1529. end;
  1530.  
  1531. function TColl.At(Index: Integer): Pointer;
  1532. begin
  1533.   if (Index < 0) or (Index >= FCount) then GlobalFail;
  1534.   Result := FList^[Index];
  1535. end;
  1536.  
  1537.  
  1538. procedure TColl.AtDelete(Index: Integer);
  1539. begin
  1540.   if (Index < 0) or (Index >= FCount) then GlobalFail;
  1541.   Dec(FCount);
  1542.   if Index < FCount then
  1543.     System.Move(FList^[Index + 1], FList^[Index],
  1544.       (FCount - Index) * SizeOf(Pointer));
  1545. end;
  1546.  
  1547. procedure TColl.AtFree(Index: Integer);
  1548. var
  1549.   Item: Pointer;
  1550. begin
  1551.   Item := At(Index);
  1552.   AtDelete(Index);
  1553.   FreeItem(Item);
  1554. end;
  1555.  
  1556. procedure TColl.AtInsert(Index: Integer; Item: Pointer);
  1557. begin
  1558.   if (Index < 0) or (Index > FCount) then GlobalFail;
  1559.   if FCount = FCapacity then SetCapacity(FCapacity + FDelta);
  1560.   if Index < FCount then
  1561.     System.Move(FList^[Index], FList^[Index + 1],
  1562.       (FCount - Index) * SizeOf(Pointer));
  1563.   FList^[Index] := Item;
  1564.   Inc(FCount);
  1565. end;
  1566.  
  1567. procedure TColl.AtPut(Index: Integer; Item: Pointer);
  1568. begin
  1569.   if (Index < 0) or (Index >= FCount) then GlobalFail;
  1570.   FList^[Index] := Item;
  1571. end;
  1572.  
  1573. procedure TColl.Delete(Item: Pointer);
  1574. begin
  1575.   AtDelete(IndexOf(Item));
  1576. end;
  1577.  
  1578. procedure TColl.DeleteAll;
  1579. begin
  1580.   FCount := 0;
  1581. end;
  1582.  
  1583. procedure TColl.FFree(Item: Pointer);
  1584. begin
  1585.   Delete(Item);
  1586.   FreeItem(Item);
  1587. end;
  1588.  
  1589. procedure TColl.FreeAll;
  1590. var
  1591.   I: Integer;
  1592. begin
  1593.   for I := 0 to FCount - 1 do FreeItem(At(I));
  1594.   FCount := 0;
  1595. end;
  1596.  
  1597. procedure TColl.FreeItem(Item: Pointer);
  1598. begin
  1599.   TObject(Item).Free;
  1600. end;
  1601.  
  1602. function TColl.IndexOf(Item: Pointer): Integer;
  1603. begin
  1604.   Result := 0;
  1605.   while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
  1606.   if Result = FCount then Result := -1;
  1607. end;
  1608.  
  1609. procedure TColl.Insert(Item: Pointer);
  1610. begin
  1611.   AtInsert(FCount, Item);
  1612. end;
  1613.  
  1614. procedure TColl.Add(Item: Pointer);
  1615. begin
  1616.   AtInsert(FCount, Item);
  1617. end;
  1618.  
  1619. procedure TColl.Pack;
  1620. var
  1621.   I: Integer;
  1622. begin
  1623.   for I := FCount - 1 downto 0 do if Items[I] = nil then AtDelete(I);
  1624. end;
  1625.  
  1626. procedure TColl.SetCapacity;
  1627. begin
  1628.   if (NewCapacity < FCount) or (NewCapacity > MaxCollSize) then GlobalFail;
  1629.   if NewCapacity <> FCapacity then
  1630.   begin
  1631.     ReallocMem(FList, NewCapacity * SizeOf(Pointer));
  1632.     FCapacity := NewCapacity;
  1633.   end;
  1634. end;
  1635.  
  1636. procedure TColl.MoveTo(CurIndex, NewIndex: Integer);
  1637. var
  1638.   Item: Pointer;
  1639. begin
  1640.   if CurIndex <> NewIndex then
  1641.   begin
  1642.     if (NewIndex < 0) or (NewIndex >= FCount) then GlobalFail;
  1643.     Item := FList^[CurIndex];
  1644.     AtDelete(CurIndex);
  1645.     AtInsert(NewIndex, Item);
  1646.   end;
  1647. end;
  1648.  
  1649. { TSortedColl }
  1650.  
  1651. function TSortedColl.KeyOf;
  1652. begin
  1653.   Result := Item;
  1654. end;
  1655.  
  1656. function TSortedColl.IndexOf(Item: Pointer): Integer;
  1657. var
  1658.   I: Integer;
  1659. begin
  1660.   IndexOf := -1;
  1661.   if Search(KeyOf(Item), I) then
  1662.   begin
  1663.     if Duplicates then
  1664.       while (I < Count) and (Item <> FList^[I]) do Inc(I);
  1665.     if I < Count then IndexOf := I;
  1666.   end;
  1667. end;
  1668.  
  1669. procedure TSortedColl.Insert(Item: Pointer);
  1670. var
  1671.   I: Integer;
  1672. begin
  1673.   if not Search(KeyOf(Item), I) or Duplicates then AtInsert(I, Item);
  1674. end;
  1675.  
  1676. function TSortedColl.Search(Key: Pointer; var Index: Integer): Boolean;
  1677. var
  1678.   L, H, I, C: Integer;
  1679. begin
  1680.   Search := False;
  1681.   L := 0;
  1682.   H := Count - 1;
  1683.   while L <= H do
  1684.   begin
  1685.     I := (L + H) shr 1;
  1686.     C := Compare(KeyOf(FList^[I]), Key);
  1687.     if C < 0 then L := I + 1 else
  1688.     begin
  1689.       H := I - 1;
  1690.       if C = 0 then
  1691.       begin
  1692.         Search := True;
  1693.         if not Duplicates then L := I;
  1694.       end;
  1695.     end;
  1696.   end;
  1697.   Index := L;
  1698. end;
  1699.  
  1700. { TStringColl }
  1701.  
  1702. function TStringColl.LongString: string;
  1703. var
  1704.   i: Integer;
  1705. begin
  1706.   Result := '';
  1707.   for i := 0 to Count-1 do Result := Result + Strings[i] + #13#10;
  1708. end;
  1709.  
  1710. function TStringColl.LongStringD(c: char): string;
  1711. var
  1712.   i: Integer;
  1713. begin
  1714.   Result := '';
  1715.   for i := 0 to Count-2 do Result := Result + Strings[i] + c;
  1716.   for i := MaxI(0, Count-1) to Count-1 do Result := Result + Strings[i];
  1717. end;
  1718.  
  1719. procedure TStringColl.SetTextStr(const Value: string);
  1720. var
  1721.   P, Start: PChar;
  1722.   S: string;
  1723. begin
  1724.   P := Pointer(Value);
  1725.   if P <> nil then
  1726.     while P^ <> #0 do
  1727.     begin
  1728.       Start := P;
  1729.       while not (P^ in [#0, #10, #13]) do Inc(P);
  1730.       System.SetString(S, Start, P - Start);
  1731.       Add(S);
  1732.       if P^ = #13 then Inc(P);
  1733.       if P^ = #10 then Inc(P);
  1734.     end;
  1735. end;
  1736.  
  1737.  
  1738. procedure TStringColl.FillEnum(Str: string; Delim: Char; Sorted: Boolean);
  1739. var
  1740.   Z: string;
  1741. begin
  1742.   while Str <> '' do
  1743.   begin
  1744.     GetWrd(Str, Z, Delim);
  1745.     if Sorted then Ins(Z) else Add(Z);
  1746.   end;
  1747. end;
  1748.  
  1749.  
  1750. function TStringColl.Found(const Str: string): Boolean;
  1751. var
  1752.   i: Integer;
  1753. begin
  1754.   Result := Search(@Str, I);
  1755. end;
  1756.  
  1757. function TStringColl.FoundU(const Str: string): Boolean;
  1758. var
  1759.   i: Integer;
  1760. begin
  1761.   Result := False;
  1762.   for i := 0 to Count-1 do if Str = Strings[i] then begin Result := True; Exit end;
  1763. end;
  1764.  
  1765. function TStringColl.FoundUC(const Str: string): Boolean;
  1766. var
  1767.   us: string;
  1768.   i: Integer;
  1769. begin
  1770.   us := UpperCase(Str);
  1771.   Result := False;
  1772.   for i := 0 to Count-1 do if us = UpperCase(Strings[i]) then begin Result := True; Exit end;
  1773. end;
  1774.  
  1775. function TStringColl.Copy;
  1776. begin
  1777.   Result := TStringColl.Create;
  1778.   CopyItemsTo(TColl(Result));
  1779. end;
  1780.  
  1781. function TStringColl.CopyItem(AItem: Pointer): Pointer;
  1782. begin
  1783.   Result := NewStr(PString(AItem)^);
  1784. end;
  1785.  
  1786.  
  1787. function TStringColl.KeyOf(Item: Pointer): Pointer;
  1788. begin
  1789.   KeyOf := Item;
  1790. end;
  1791.  
  1792. procedure TStringColl.Concat(AColl: TStringColl);
  1793. var
  1794.   i: Integer;
  1795. begin
  1796.   for i := 0 to AColl.Count - 1 do AtInsert(Count, AColl.At(I));
  1797.   AColl.DeleteAll;
  1798. end;
  1799.  
  1800. procedure TStringColl.AppendTo(AColl: TStringColl);
  1801. var
  1802.   i: Integer;
  1803. begin
  1804.   for i := 0 to Count - 1 do AColl.Add(Strings[i]);
  1805. end;
  1806.  
  1807. procedure TStringColl.Fill(const AStrs: array of string);
  1808. var
  1809.   i: Integer;
  1810. begin
  1811.   FreeAll;
  1812.   for i := Low(AStrs) to High(AStrs) do Add(AStrs[i]);
  1813. end;
  1814.  
  1815. procedure TStringColl.AddStrings(Strings: TStringColl; Sort: Boolean);
  1816. var
  1817.   i: Integer;
  1818. begin
  1819.   for i := 0 to Strings.Count-1 do
  1820.     if Sort then Ins(Strings[i]) else Add(Strings[i]);
  1821. end;
  1822.  
  1823. function TStringColl.IdxOf(Item: string): Integer;
  1824. begin
  1825.   Result := IndexOf(@Item);
  1826. end;
  1827.  
  1828. procedure TStringColl.SetString(Index: Integer; const Value: string);
  1829. begin
  1830.   FreeItem(At(Index));
  1831.   AtPut(Index, NewStr(Value));
  1832. end;
  1833.  
  1834. function TStringColl.GetString(Index: Integer): string;
  1835. begin
  1836.   Result := PString(At(Index))^;
  1837. end;
  1838.  
  1839. function TStringColl.Compare(Key1, Key2: Pointer): Integer;
  1840. begin
  1841.   Compare := CompareStr(PString(Key1)^, PString(Key2)^);
  1842. end;
  1843.  
  1844. procedure TStringColl.FreeItem(Item: Pointer);
  1845. begin
  1846.   DisposeStr(Item);
  1847. end;
  1848.  
  1849. procedure TStringColl.AtIns(Index: Integer; const Item: string);
  1850. begin
  1851.   AtInsert(Index, NewStr(Item));
  1852. end;
  1853.  
  1854. procedure TStringColl.Add(const S: string);
  1855. begin
  1856.   AtInsert(Count, NewStr(S));
  1857. end;
  1858.  
  1859. procedure TStringColl.Ins0(const S: string);
  1860. begin
  1861.   AtInsert(0, NewStr(S));
  1862. end;
  1863.  
  1864. procedure TStringColl.Ins(const S: string);
  1865. begin
  1866.   Insert(NewStr(S));
  1867. end;
  1868.  
  1869. procedure FreeObject(var O);
  1870. var
  1871.   OO: TObject absolute O;
  1872.   OP: Pointer absolute O;
  1873. begin
  1874.   if OP <> nil then begin OO.Free; OP := nil end;
  1875. end;
  1876.  
  1877. function DeleteEmptyDirInheritance(S: string; const StopOn: string): Integer;
  1878. begin
  1879.   Result := 0;
  1880.   while (S <> StopOn) and RemoveDirectory(PChar(S)) do
  1881.   begin
  1882.     Inc(Result);
  1883.     S := ExtractFileDir(S);
  1884.   end;
  1885. end;
  1886.  
  1887. const
  1888.   CMonths = 'JanFebMarAprMayJunJulAugSepOctNovDec';
  1889.   Months: string[Length(CMonths)] = CMonths;
  1890.  
  1891. function MonthE(m: Integer): string;
  1892. begin
  1893.   Result := Copy(Months, 1+(m-1)*3, 3);
  1894. end;
  1895.  
  1896.  
  1897. procedure GlobalFail;
  1898. begin
  1899. //  WriteLn('Global Failure!!!');
  1900.   Halt;
  1901. end;
  1902.  
  1903.  
  1904.  
  1905. function CreateTCollEL: TColl;
  1906. begin
  1907.   Result := TColl.Create;
  1908.   TColl(Result).Enter;
  1909.   TColl(Result).Leave;
  1910. end;
  1911.  
  1912. procedure XorStr(P: PByteArray; Len: Integer; const S: string);
  1913. var
  1914.   sl, i: Integer;
  1915. begin
  1916.   sl := Length(s); if sl = 0 then Exit;
  1917.   for i := 0 to Len-1 do
  1918.   begin
  1919.     P^[i] := P^[i] xor Byte(S[(i mod sl)+1]);
  1920.   end;
  1921. end;
  1922.  
  1923. function GetEnvVariable(const Name: string): string;
  1924. const
  1925.   BufSize = 128;
  1926. var
  1927.   Buf: array[0..BufSize] of Char;
  1928.   I: DWORD;
  1929. begin
  1930.   I := GetEnvironmentVariable(PChar(Name), Buf, BufSize);
  1931.   case I of
  1932.     1..BufSize:
  1933.       begin
  1934.         SetLength(Result, I);
  1935.         Move(Buf, Result[1], I);
  1936.       end;
  1937.     BufSize+1..MaxInt:
  1938.       begin
  1939.         SetLength(Result, I+1);
  1940.         GetEnvironmentVariable(PChar(Name), @Result[1], I);
  1941.         SetLength(Result, I);
  1942.       end;
  1943.     else
  1944.       begin
  1945.         Result := '';
  1946.       end;
  1947.    end;
  1948. end;
  1949.  
  1950. function LoadRS(Ident: Integer): string;
  1951. const
  1952.    strbufsize = $10000;
  1953. var
  1954.    strbuf: array[0..StrBufSize] of Char;
  1955. begin
  1956.   SetString(Result, PChar(@strbuf), LoadString(hInstance, Ident, @strbuf, strbufsize));
  1957. end;
  1958.  
  1959. function StrBegins(const s1,s2:string):Boolean;
  1960. begin
  1961.   Result := Copy(s1, 1, Length(s2)) = s2;
  1962. end;
  1963.  
  1964. function DivideDash(const S: string): string;
  1965. begin
  1966.   Result := S;
  1967.   Insert('-', Result, (Length(S) div 2)+1);
  1968. end;
  1969.  
  1970. procedure MoveColl(Src, Dst: TColl; Idx: Integer);
  1971. begin
  1972.   if Idx = -1 then Exit;
  1973.   Dst.Insert(Src[Idx]);
  1974.   Src.AtDelete(Idx);
  1975. end;
  1976.  
  1977.  
  1978. function TempFileName(const APath, APfx: string): string;
  1979. var
  1980.   s: string;
  1981. begin
  1982.   SetLength(s, 1000);
  1983.   GetTempFileName(PChar(APath), PChar(APfx), 0, @s[1]);
  1984.   Result := Copy(s, 1, NulSearch(s[1]));
  1985. end;
  1986.  
  1987. function CreateTempFile(const APath, APfx: string; var FName: string): DWORD;
  1988. begin
  1989.   FName := TempFileName(APath, APfx);
  1990.   Result := _CreateFile(FName, [cWrite, cExisting]);
  1991. end;
  1992.  
  1993. { TThread }
  1994.  
  1995. function ThreadProc(Thread: TThread): DWORD;
  1996. var
  1997.   FreeThread: Boolean;
  1998. begin
  1999.   Thread.Execute;
  2000.   FreeThread := Thread.FFreeOnTerminate;
  2001.   Result := Thread.FReturnValue;
  2002.   Thread.FFinished := True;
  2003.   if FreeThread then Thread.Free;
  2004.   EndThread(Result);
  2005. end;
  2006.  
  2007. constructor TThread.Create(CreateSuspended: Boolean);
  2008. var
  2009.   Flags: DWORD;
  2010. begin
  2011.   inherited Create;
  2012.   FSuspended := CreateSuspended;
  2013.   Flags := 0;
  2014.   if CreateSuspended then Flags := CREATE_SUSPENDED;
  2015.   FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), Flags, FThreadID);
  2016. end;
  2017.  
  2018. destructor TThread.Destroy;
  2019. begin
  2020.   if FHandle <> 0 then CloseHandle(FHandle);
  2021.   inherited Destroy;
  2022. end;
  2023.  
  2024. const
  2025.   Priorities: array [TThreadPriority] of Integer =
  2026.    (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
  2027.     THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
  2028.     THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
  2029.  
  2030. function TThread.GetPriority: TThreadPriority;
  2031. var
  2032.   P: Integer;
  2033.   I: TThreadPriority;
  2034. begin
  2035.   P := GetThreadPriority(FHandle);
  2036.   Result := tpNormal;
  2037.   for I := Low(TThreadPriority) to High(TThreadPriority) do
  2038.     if Priorities[I] = P then Result := I;
  2039. end;
  2040.  
  2041. procedure TThread.SetPriority(Value: TThreadPriority);
  2042. begin
  2043.   SetThreadPriority(FHandle, Priorities[Value]);
  2044. end;
  2045.  
  2046. procedure TThread.SetSuspended(Value: Boolean);
  2047. begin
  2048.   if Value <> FSuspended then
  2049.     if Value then
  2050.       Suspend else
  2051.       Resume;
  2052. end;
  2053.  
  2054. procedure TThread.Suspend;
  2055. begin
  2056.   FSuspended := True;
  2057.   SuspendThread(FHandle);
  2058. end;
  2059.  
  2060. procedure TThread.Resume;
  2061. begin
  2062.   if ResumeThread(FHandle) = 1 then FSuspended := False;
  2063. end;
  2064.  
  2065. procedure TThread.Terminate;
  2066. begin
  2067.   FTerminated := True;
  2068. end;
  2069.  
  2070. function NumBits(I: Integer): Integer; assembler;
  2071. asm
  2072.   bsr eax, eax
  2073.   jz @z
  2074.   inc eax
  2075. @z:
  2076. end;
  2077.  
  2078.  
  2079.  
  2080. function ExtractFilePath(const FileName: string): string;
  2081. var
  2082.   I: Integer;
  2083. begin
  2084.   I := LastDelimiter('\:', FileName);
  2085.   Result := Copy(FileName, 1, I);
  2086. end;
  2087.  
  2088. function ExtractFileDir(const FileName: string): string;
  2089. var
  2090.   I: Integer;
  2091. begin
  2092.   I := LastDelimiter('\:',Filename);
  2093.   if (I > 1) and (FileName[I] = '\') and
  2094.     (not (FileName[I - 1] in ['\', ':'])) then Dec(I);
  2095.   Result := Copy(FileName, 1, I);
  2096. end;
  2097.  
  2098. function ExtractFileDrive(const FileName: string): string;
  2099. var
  2100.   I, J: Integer;
  2101. begin
  2102.   if (Length(FileName) >= 2) and (FileName[2] = ':') then
  2103.     Result := Copy(FileName, 1, 2)
  2104.   else if (Length(FileName) >= 2) and (FileName[1] = '\') and
  2105.     (FileName[2] = '\') then
  2106.   begin
  2107.     J := 0;
  2108.     I := 3;
  2109.     While (I < Length(FileName)) and (J < 2) do
  2110.     begin
  2111.       if FileName[I] = '\' then Inc(J);
  2112.       if J < 2 then Inc(I);
  2113.     end;
  2114.     if FileName[I] = '\' then Dec(I);
  2115.     Result := Copy(FileName, 1, I);
  2116.   end else Result := '';
  2117. end;
  2118.  
  2119. function LastDelimiter(const Delimiters, S: string): Integer;
  2120. begin
  2121.   Result := Length(S);
  2122.   while Result > 0 do
  2123.   begin
  2124.     if (S[Result] <> #0) and (Pos(S[Result], Delimiters) = 0) then Dec(Result) else Break;
  2125.   end;
  2126. end;
  2127.  
  2128. function ExtractFileName(const FileName: string): string;
  2129. var
  2130.   I: Integer;
  2131. begin
  2132.   I := LastDelimiter('\:', FileName);
  2133.   Result := Copy(FileName, I + 1, MaxInt);
  2134. end;
  2135.  
  2136. function ExtractFileExt(const FileName: string): string;
  2137. var
  2138.   I: Integer;
  2139. begin
  2140.   I := LastDelimiter('.\:', FileName);
  2141.   if (I > 0) and (FileName[I] = '.') then
  2142.     Result := Copy(FileName, I, MaxInt) else
  2143.     Result := '';
  2144. end;
  2145.  
  2146. function ExpandFileName(const FileName: string): string;
  2147. var
  2148.   FName: PChar;
  2149.   Buffer: array[0..MAX_PATH - 1] of Char;
  2150. begin
  2151.   SetString(Result, Buffer, GetFullPathName(PChar(FileName), SizeOf(Buffer),
  2152.     Buffer, FName));
  2153. end;
  2154.  
  2155.  
  2156. function UpperCase(const S: string): string;
  2157. var
  2158.   Ch: Char;
  2159.   L: Integer;
  2160.   Source, Dest: PChar;
  2161. begin
  2162.   L := Length(S);
  2163.   SetLength(Result, L);
  2164.   Source := Pointer(S);
  2165.   Dest := Pointer(Result);
  2166.   while L <> 0 do
  2167.   begin
  2168.     Ch := Source^;
  2169.     if (Ch >= 'a') and (Ch <= 'z') then Dec(Ch, 32);
  2170.     Dest^ := Ch;
  2171.     Inc(Source);
  2172.     Inc(Dest);
  2173.     Dec(L);
  2174.   end;
  2175. end;
  2176.  
  2177. function LowerCase(const S: string): string;
  2178. var
  2179.   Ch: Char;
  2180.   L: Integer;
  2181.   Source, Dest: PChar;
  2182. begin
  2183.   L := Length(S);
  2184.   SetLength(Result, L);
  2185.   Source := Pointer(S);
  2186.   Dest := Pointer(Result);
  2187.   while L <> 0 do
  2188.   begin
  2189.     Ch := Source^;
  2190.     if (Ch >= 'A') and (Ch <= 'Z') then Inc(Ch, 32);
  2191.     Dest^ := Ch;
  2192.     Inc(Source);
  2193.     Inc(Dest);
  2194.     Dec(L);
  2195.   end;
  2196. end;
  2197.  
  2198. const
  2199.   EmptyStr: string = '';
  2200.   NullStr: PString = @EmptyStr;
  2201.  
  2202. function NewStr(const S: string): PString;
  2203. begin
  2204.   if S = '' then Result := NullStr else
  2205.   begin
  2206.     New(Result);
  2207.     Result^ := S;
  2208.   end;
  2209. end;
  2210.  
  2211. procedure DisposeStr(P: PString);
  2212. begin
  2213.   if (P <> nil) and (P^ <> '') then Dispose(P);
  2214. end;
  2215.  
  2216. function CompareStr(const S1, S2: string): Integer; assembler;
  2217. asm
  2218.         PUSH    ESI
  2219.         PUSH    EDI
  2220.         MOV     ESI,EAX
  2221.         MOV     EDI,EDX
  2222.         OR      EAX,EAX
  2223.         JE      @@1
  2224.         MOV     EAX,[EAX-4]
  2225. @@1:    OR      EDX,EDX
  2226.         JE      @@2
  2227.         MOV     EDX,[EDX-4]
  2228. @@2:    MOV     ECX,EAX
  2229.         CMP     ECX,EDX
  2230.         JBE     @@3
  2231.         MOV     ECX,EDX
  2232. @@3:    CMP     ECX,ECX
  2233.         REPE    CMPSB
  2234.         JE      @@4
  2235.         MOVZX   EAX,BYTE PTR [ESI-1]
  2236.         MOVZX   EDX,BYTE PTR [EDI-1]
  2237. @@4:    SUB     EAX,EDX
  2238.         POP     EDI
  2239.         POP     ESI
  2240. end;
  2241.  
  2242. function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
  2243. asm
  2244.         PUSH    ESI
  2245.         PUSH    EDI
  2246.         MOV     ESI,P1
  2247.         MOV     EDI,P2
  2248.         MOV     EDX,ECX
  2249.         XOR     EAX,EAX
  2250.         AND     EDX,3
  2251.         SHR     ECX,1
  2252.         SHR     ECX,1
  2253.         REPE    CMPSD
  2254.         JNE     @@2
  2255.         MOV     ECX,EDX
  2256.         REPE    CMPSB
  2257.         JNE     @@2
  2258. @@1:    INC     EAX
  2259. @@2:    POP     EDI
  2260.         POP     ESI
  2261. end;
  2262.  
  2263.  
  2264. procedure TSocket.RegisterSelf;
  2265. begin
  2266.   SocketsColl.Enter;
  2267.   SocketsColl.Insert(Self);
  2268.   Registered := True;
  2269.   SocketsColl.Leave;
  2270. end;
  2271.  
  2272. procedure TSocket.DeregisterSelf;
  2273. begin
  2274.   SocketsColl.Enter;
  2275.   if Registered then SocketsColl.Delete(Self);
  2276.   Registered := False;
  2277.   SocketsColl.Leave;
  2278. end;
  2279.  
  2280.  
  2281. function TSocket.Startup: Boolean;
  2282. begin
  2283.   Result := True;
  2284. end;
  2285.  
  2286. function TSocket.Handshake: Boolean;
  2287. begin
  2288.   Result := True;
  2289. end;
  2290.  
  2291.  
  2292. destructor TSocket.Destroy;
  2293. begin
  2294.   DeregisterSelf;
  2295.   CloseSocket(Handle);
  2296.   SocketsColl.Enter;
  2297.   Dec(SocksCount);
  2298.   if SocksCount = 0 then ResetterThread.TimeToSleep := INFINITE;
  2299.   SocketsColl.Leave;
  2300.   inherited Destroy;
  2301. end;
  2302.  
  2303. function TSocket.Read(var B; Size: DWORD): DWORD;
  2304. begin
  2305.   Result := _Read(B, Size);
  2306.   Dead := 0;
  2307. end;
  2308.  
  2309. function TSocket.Write(const B; Size: DWORD): DWORD;
  2310. const
  2311.   cWrite = $2000;
  2312. var
  2313.   p: PByteArray;
  2314.   Written, Left, i, WriteNow: DWORD;
  2315. begin
  2316.   p := @B;
  2317.   i := 0;
  2318.   Left := Size;
  2319.   while Left > 0 do
  2320.   begin
  2321.     WriteNow := MinD(Left, cWrite);
  2322.     Written := _Write(p^[i], WriteNow);
  2323.     Dead := 0;
  2324.     Inc(i, Written);
  2325.     Dec(Left, Written);
  2326.     if Written <> WriteNow then Break;
  2327.   end;
  2328.   Result := i;
  2329. end;
  2330.  
  2331.  
  2332.  
  2333. function TSocket.WriteStr(const s: string): DWORD;
  2334. var
  2335.   slen: Integer;
  2336. begin
  2337.   slen := Length(s);
  2338.   if slen > 0 then Result := Write(s[1], slen) else Result := 0;
  2339. end;
  2340.  
  2341. function TSocket._Write(const B; Size: DWORD): DWORD;
  2342. var
  2343.   I: Integer;
  2344. begin
  2345.   I := send(Handle, (@B)^, Size, 0);
  2346.   if (I = SOCKET_ERROR) or (I < 0) then begin Status := WSAGetLastError; Result := 0 end else Result := I;
  2347. end;
  2348.  
  2349. function TSocket._Read(var B; Size: DWORD): DWORD;
  2350. var
  2351.   i: Integer;
  2352. begin
  2353.   i := recv(Handle, B, Size, 0);
  2354.   if (i = SOCKET_ERROR) or (I < 0) then begin Status := WSAGetLastError; Result := 0 end else Result := i;
  2355. end;
  2356.  
  2357. function Inet2addr(const s: string): DWORD;
  2358. begin
  2359.   Result := inet_addr(PChar(s));
  2360. end;
  2361.  
  2362. function __pchar(c: char): Boolean;
  2363. begin
  2364.   case c of
  2365.     ':', '@', '&', '=', '+': Result := True
  2366.     else Result := __uchar(c)
  2367.   end;
  2368. end;
  2369.  
  2370. function __uchar(c: char): Boolean;
  2371. begin
  2372.   Result := __alpha(c) or __digit(c) or __safe(c) or __extra(c) or __national(c)
  2373. end;
  2374.  
  2375. function __national(c: char): Boolean;
  2376. begin
  2377.   case c of
  2378.     '0'..'9', 'A'..'Z', 'a'..'z': Result := False;
  2379.     else Result := not (__reserved(c) or __extra(c) or __safe(c) or __unsafe(c));
  2380.   end;
  2381. end;
  2382.  
  2383. function __reserved(c: char): Boolean;
  2384. begin
  2385.   case c of
  2386.     ';', '/', '?', ':', '@', '&', '=', '+' : Result := True
  2387.     else Result := False;
  2388.   end;
  2389. end;
  2390.  
  2391. function __extra(c: char): Boolean;
  2392. begin
  2393.   case c of
  2394.     '!', '*', '''' ,'(', ')', ',' : Result := True
  2395.     else Result := False;
  2396.   end;
  2397. end;
  2398.  
  2399. function __safe(c: char): Boolean;
  2400. begin
  2401.   case c of
  2402.     '$', '-', '_', '.' : Result := True
  2403.     else Result := False;
  2404.   end;
  2405. end;
  2406.  
  2407. function __unsafe(c: char): Boolean;
  2408. begin
  2409.   case c of
  2410.       '"', '#', '%', '<', '>': Result := True;
  2411.     else Result := __ctl(c);
  2412.   end;
  2413. end;
  2414.  
  2415. function __alpha(c: char): Boolean;
  2416. begin
  2417.   case c of
  2418.     'A'..'Z', 'a'..'z': Result := True
  2419.     else Result := False;
  2420.   end;
  2421. end;
  2422.  
  2423. function __digit(c: char): Boolean;
  2424. begin
  2425.   case c of
  2426.     '0'..'9': Result := True
  2427.     else Result := False;
  2428.   end;
  2429. end;
  2430.  
  2431. function __ctl(c: char): Boolean;
  2432. begin
  2433.   case c of
  2434.     #0..#31, #127 : Result := True
  2435.     else Result := False;
  2436.   end;
  2437. end;
  2438.  
  2439.  
  2440. function UnpackXchars(var s: string; p: Boolean): Boolean;
  2441. var
  2442.   r: string;
  2443.   c: char;
  2444.   i, h, l, sl: Integer;
  2445.  
  2446. begin
  2447.   Result := False;
  2448.   sl := Length(s);
  2449.   i := 0;
  2450.   while i < sl do
  2451.   begin
  2452.     Inc(i);
  2453.     c := s[i];
  2454.     if c = '%' then
  2455.     begin
  2456.       if i > sl-2 then Exit;
  2457.       l := Pos(UpCase(s[i+2]), rrHiHexChar)-1;
  2458.       h := Pos(UpCase(s[i+1]), rrHiHexChar)-1;
  2459.       if (h = -1) or (l = -1) then Exit;
  2460.       r := r + Chr(h shl 4 or l);
  2461.       Inc(i, 2);
  2462.       Continue;
  2463.     end;
  2464.     if p then
  2465.     begin
  2466.       if not __pchar(c) and (c <> '/') then Exit;
  2467.     end else
  2468.     begin
  2469.       if not __uchar(c) then Exit
  2470.     end;
  2471.     r := r + c;
  2472.   end;
  2473.   s := r;
  2474.   Result := True;
  2475. end;
  2476.  
  2477. function UnpackUchars(var s: string): Boolean;
  2478. begin
  2479.   Result := UnpackXchars(s, False);
  2480. end;
  2481.  
  2482.  
  2483. function UnpackPchars(var s: string): Boolean;
  2484. begin
  2485.   Result := UnpackXchars(s, True);
  2486. end;
  2487.  
  2488. function ProcessQuotes(var s: string): Boolean;
  2489. var
  2490.   r: string;
  2491.   i: Integer;
  2492.   KVC: Boolean;
  2493.   c: Char;
  2494. begin
  2495.   Result := False;
  2496.   KVC := False;
  2497.   for i := 1 to Length(s) do
  2498.   begin
  2499.     c := s[i];
  2500.     case c of
  2501.       #0..#9, #11..#12, #14..#31 : Exit;
  2502.       '"' : begin KVC := not KVC; Continue end;
  2503.     end;
  2504.     if KVC then r := r + '%' + Hex2(Byte(c)) else r := r + c;
  2505.   end;
  2506.   Result := not KVC;
  2507.   if Result then s := r;
  2508. end;
  2509.  
  2510. function _Val(const S: string; var V: Integer): Boolean;
  2511. var
  2512.   I, R: Integer;
  2513.   C: Char;
  2514. begin
  2515.   Result := False;
  2516.   if S = '' then Exit;
  2517.   R := 0;
  2518.   for I := 1 to Length(S) do
  2519.   begin
  2520.     C := S[I];
  2521.     if not __digit(C) then Exit;
  2522.     R := (R * 10) + Ord(C) - Ord('0');
  2523.   end;
  2524.   Result := True;
  2525.   V := R;
  2526. end;
  2527.  
  2528.  
  2529. function StoI(const S: string): Integer;
  2530. begin
  2531.   if not _Val(S, Result) then Result := 0;
  2532. end;
  2533.  
  2534. function _LogOK(const Name: string; var Handle: DWORD): Boolean;
  2535. begin
  2536.   if Handle = 0 then
  2537.   begin
  2538.     Handle := _CreateFile(Name, [cWrite]);
  2539.     if Handle <> INVALID_HANDLE_VALUE then if SetFilePointer(Handle, 0, nil, FILE_END) = INVALID_FILE_SIZE then ClearHandle(Handle);
  2540.   end;
  2541.   Result := Handle <> INVALID_HANDLE_VALUE;
  2542. end;
  2543.  
  2544. function InetAddr(const s: string): DWORD;
  2545. begin
  2546.   Result := inet_addr(PChar(s))
  2547. end;
  2548.  
  2549. function AddrInet(i: DWORD): string;
  2550. var
  2551.   r: record a, b, c, d: Byte end absolute i;
  2552. begin
  2553.   Result := ItoS(r.a)+'.'+ItoS(r.b)+'.'+ItoS(r.c)+'.'+ItoS(r.d);
  2554. end;
  2555.  
  2556.  
  2557. const
  2558.     shell32 = 'shell32.dll';
  2559.  
  2560.  
  2561. function FindExecutable; external shell32 name 'FindExecutableA';
  2562.  
  2563.  
  2564. procedure XAdd(var Critical, Normal); assembler;
  2565. asm
  2566.   mov  ecx, [edx]
  2567.   xadd [eax], ecx  // !!! i486+
  2568.   mov  [edx], ecx
  2569. end;
  2570.  
  2571. procedure GetBias;
  2572. var
  2573.   T, L: TFileTime;
  2574.   a, b, c: DWORD;
  2575. begin
  2576.   GetSystemTimeAsFileTime(T);
  2577.   FileTimeToLocalFileTime(T, L);
  2578.   a := uCvtGetFileTime(T.dwLowDateTime, T.dwHighDateTime);
  2579.   b := uCvtGetFileTime(L.dwLowDateTime, L.dwHighDateTime);
  2580.   if a > b then
  2581.   begin
  2582.     c := a - b;
  2583.     TimeZoneBias := c;
  2584.   end else
  2585.   begin
  2586.     c := b - a;
  2587.     TimeZoneBias := c;
  2588.     TimeZoneBias := - TimeZoneBias;
  2589.   end;
  2590. end;
  2591.  
  2592. type
  2593.   THostCache = class
  2594.     Addr: DWORD;
  2595.     Name: string;
  2596.   end;
  2597.  
  2598.   THostCacheColl = class(TSortedColl)
  2599.     function Compare(Key1, Key2: Pointer): Integer; override;
  2600.     function KeyOf(Item: Pointer): Pointer; override;
  2601.   end;
  2602.  
  2603. var
  2604.   HostCache: THostCacheColl;
  2605.  
  2606. function THostCacheColl.Compare(Key1, Key2: Pointer): Integer;
  2607. begin
  2608.   Result := Integer(Key1) - Integer(Key2);
  2609. end;
  2610.  
  2611. function THostCacheColl.KeyOf(Item: Pointer): Pointer;
  2612. begin
  2613.   Result := Pointer(THostCache(Item).Addr);
  2614. end;
  2615.  
  2616.  
  2617. function GetHostNameByAddr(Addr: DWORD): string;
  2618. var
  2619.   p: PHostEnt;
  2620.   i: Integer;
  2621.   f: Boolean;
  2622.   c: THostCache;
  2623.   ok: Boolean;
  2624.   he: PHostEnt;
  2625.   HostName: string;
  2626. begin
  2627.   HostCache.Enter;
  2628.   f := HostCache.Search(Pointer(Addr), i);
  2629.   if f then Result := THostCache(HostCache[i]).Name;
  2630.   HostCache.Leave;
  2631.   if f then Exit;
  2632.   p := gethostbyaddr(@addr, 4, PF_INET);
  2633.   ok := False;
  2634.   if p <> nil then
  2635.   begin // host name got - now get address of this name
  2636.     HostName := p^.h_name;
  2637.     he := gethostbyname(PChar(HostName));
  2638.     if he <> nil then
  2639.     begin // address got - now compare it with the real one
  2640.       ok := PDwordArray(he^.h_addr_list^)^[0] = Addr;
  2641.     end;
  2642.   end;
  2643.   if ok then Result := HostName else Result := AddrInet(Addr);
  2644.   HostCache.Enter;
  2645.   f := HostCache.Search(Pointer(Addr), i);
  2646.   if not f then
  2647.   begin
  2648.     c := THostCache.Create;
  2649.     c.Addr := Addr;
  2650.     c.Name := Result;
  2651.     HostCache.AtInsert(i, c);
  2652.   end;
  2653.   HostCache.Leave;
  2654. end;
  2655.  
  2656. function Vl(const s: string): DWORD;
  2657. var
  2658.   a, i, l: Integer;
  2659.   c: Char;
  2660. begin
  2661.   Result := INVALID_VALUE;
  2662.   l := Length(s);
  2663.   if L > 9 then Exit;
  2664.   a := 0;
  2665.   for i := 1 to l do
  2666.   begin
  2667.     C := s[i];
  2668.     if (C < '0') or (C > '9') then Exit;
  2669.     a := a * 10 + Ord(C) - Ord('0');
  2670.   end;
  2671.   Result := a;
  2672. end;
  2673.  
  2674.  
  2675. procedure xBaseInit;
  2676. begin
  2677.   GetBias;
  2678.   HostCache := THostCacheColl.Create;
  2679.   HostCache.Enter;
  2680.   HostCache.Leave;
  2681. end;
  2682.  
  2683. procedure xBaseDone;
  2684. begin
  2685.   FreeObject(HostCache);
  2686. end;
  2687.  
  2688. constructor TResetterThread.Create;
  2689. begin
  2690.   inherited Create(False);
  2691.   oSleep := CreateEvent(nil, False, False, nil);
  2692.   TimeToSleep := INFINITE;
  2693. end;
  2694.  
  2695. destructor TResetterThread.Destroy;
  2696. begin
  2697.   CloseHandle(oSleep);
  2698.   inherited Destroy;
  2699. end;
  2700.  
  2701.  
  2702. procedure TResetterThread.Execute;
  2703. const
  2704.   KillQuants = 5; // Quants to shut down socket for inactivity
  2705. var
  2706.   i: Integer;
  2707.   s: TSocket;
  2708. begin
  2709.   repeat
  2710.     WaitForSingleObject(oSleep, TimeToSleep);
  2711.     if Terminated then Break;
  2712.     SocketsColl.Enter;
  2713.     for i := 0 to SocketsColl.Count - 1 do
  2714.     begin
  2715.       s := SocketsColl[i];
  2716.       if s.Dead < 0 then Continue; // Already shut down
  2717.       Inc(s.Dead);
  2718.       if s.Dead <= KillQuants then Continue; // This one shows activity - let him live
  2719.       s.Dead := -1; // Mark
  2720.        // disable both sends and receives
  2721.       shutdown(s.Handle, 2);
  2722.     end;
  2723.     SocketsColl.Leave;
  2724.   until Terminated;
  2725. end;
  2726.  
  2727.  
  2728. function CompareMask(const n, m: string; SupportPercent: Boolean): Boolean;
  2729. var
  2730.   i: Integer;
  2731. begin
  2732.   Result := False;
  2733.   for i := 1 to Length(m) do
  2734.   begin
  2735.     if (m[i] = '?') then Continue;
  2736.     if (i > Length(n)) or (n[i] <> m[i]) then
  2737.     begin
  2738.       if SupportPercent and (m[i] = '%') and (n[i] in ['0'..'9']) then else Exit;
  2739.     end;
  2740.   end;
  2741.   Result := True;
  2742. end;
  2743.  
  2744. function PosMask(const m, s: string; SupportPercent: Boolean): Integer;
  2745. var
  2746.   i: Integer;
  2747. begin
  2748.   Result := 0;
  2749.   for i := 1 to Length(s)-Length(m)+1 do
  2750.   begin
  2751.     if CompareMask(Copy(s, i, Length(m)), m, SupportPercent) then
  2752.     begin
  2753.       Result := i;
  2754.       Exit;
  2755.     end;
  2756.   end;
  2757. end;
  2758.  
  2759. function MatchMask(const AName, AMask: string): Boolean;
  2760. begin
  2761.   Result := _MatchMask(AName, AMask, False);
  2762. end;
  2763.  
  2764. function _MatchMaskBody(AName, AMask: string; SupportPercent: Boolean): Boolean;
  2765. var
  2766.   i, j: Integer;
  2767.   Scan: Boolean;
  2768. begin
  2769.   Result := False;
  2770.   Scan := False;
  2771.   while True do
  2772.   begin
  2773.     i := Pos('*', AMask);
  2774.     if i = 0 then
  2775.     begin
  2776.       if AMask = '' then begin Result := True; Exit end;
  2777.       j := PosMask(AMask, AName, SupportPercent); if j=0 then Exit;
  2778.       if (j+Length(AMask)) <= Length(AName) then Exit;
  2779.       Result := True;
  2780.       Exit;
  2781.     end else
  2782.     begin
  2783.       if i > 1 then
  2784.       begin
  2785.         if Scan then j := PosMask(Copy(AMask, 1, i-1), AName, SupportPercent) else if CompareMask(AName, Copy(AMask, 1, i-1), SupportPercent) then j := i-1 else j := 0;
  2786.         if j = 0 then Exit else Delete(AName, 1, j);
  2787.       end;
  2788.       Delete(AMask, 1, i);
  2789.     end;
  2790.     Scan := True;
  2791.   end;
  2792. end;
  2793.  
  2794. function _MatchMask(const AName: string; AMask: string; SupportPercent: Boolean): Boolean;
  2795. begin
  2796.   Replace('?*', '*', AMask);
  2797.   Replace('*?', '*', AMask);
  2798.   Replace('**', '*', AMask);
  2799.   Result := _MatchMaskBody(UpperCase(AName), UpperCase(AMask), SupportPercent);
  2800. end;
  2801.  
  2802. function FromHex(C1, C2: Char): Char;
  2803.   var I1, I2: Byte;
  2804. begin
  2805.   case C1 of
  2806.     '0'..'9': I1 := Byte(C1)-48;
  2807.     'A'..'F': I1 := Byte(C1)-55;
  2808.     'a'..'f': I1 := Byte(C1)-87;
  2809.       else I1 := 0;
  2810.   end;
  2811.   case C2 of
  2812.     '0'..'9': I2 := Byte(C2)-48;
  2813.     'A'..'F': I2 := Byte(C2)-55;
  2814.     'a'..'f': I2 := Byte(C2)-87;
  2815.       else I2 := 0;
  2816.   end;
  2817.   Result := Char(I1 shl 4 + I2);
  2818. end;
  2819.  
  2820. constructor TMimeCoder.Create;
  2821. begin
  2822.   case AType of
  2823.     bsBase64: begin
  2824.                 Table:='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  2825.                 MaxChars := 57;
  2826.                 Pad := '=';
  2827.               end;
  2828.     bsUUE: begin
  2829.              Table := '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';
  2830.              Pad := '`';
  2831.              MaxChars := 45;
  2832.            end;
  2833.     bsXXE: begin
  2834.              Table := '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  2835.              Pad := '+';
  2836.              MaxChars := 45;
  2837.            end;
  2838.   end;
  2839.   InitTable;
  2840. end;
  2841.  
  2842. procedure TMimeCoder.InitTable;
  2843.   var I: Integer;
  2844. begin
  2845.   FillChar(XChars, SizeOf(XChars), 65);
  2846.   for I := 1 to Length(Table) do XChars[Table[I]] := I-1;
  2847.   XChars[Pad] := 0;
  2848.   if Pad = '`' then XChars[' '] := 0;
  2849. end;
  2850.  
  2851. function TMimeCoder.EncodeStr;
  2852. begin
  2853.   if S = '' then Result := ''
  2854.     else Result := Encode(S[1], Length(S));
  2855. end;
  2856.  
  2857. function IsUUEStr(const S: String): Boolean;
  2858.   var I: Integer;
  2859. begin
  2860.   Result := False;
  2861.   for I := 1 to Length(S) do
  2862.     if (S[I] < '!') or (S[I] > '`') then Exit;
  2863.   Result := True;
  2864. end;
  2865.  
  2866. function TMimeCoder.Encode;
  2867. var
  2868.   B: Array[0..MMaxChars] of Byte;
  2869.   I,K,L: Word;
  2870.   S: Str255;
  2871. begin
  2872.   FillChar(B, SizeOf(B), 0);
  2873.   Move(Buf, B, N);
  2874.   L := N;
  2875.   if L mod 3 <> 0 then Inc(L, 3);
  2876.   S[0] := Char((L div 3) * 4);
  2877.   FillChar(S[1], Length(S), Pad);
  2878.   I := 0; K := 1;
  2879.   while I < N do
  2880.     begin
  2881.       S[K]   := Table[1+(B[I] shr 2)];
  2882.       S[K+1] := Table[1+(((B[I] and $03) shl 4) or (B[I+1] shr 4))];
  2883.       if I+1 >= N then Break;
  2884.       S[K+2] := Table[1+(((B[I+1] and $0F) shl 2) or (B[I+2] shr 6))];
  2885.       if I+2 >= N then Break;
  2886.       S[K+3] := Table[1+(B[I+2] and $3F)];
  2887.       Inc(I, 3); Inc(K, 4);
  2888.     end;
  2889.   Result := S;
  2890. end;
  2891.  
  2892. function TMimeCoder.EncodeBuf(const Buf; N: byte; var OutBuf) : Integer;
  2893. var
  2894.   B: Array[0..MMaxChars] of Byte;
  2895.   I,K,L: Word;
  2896.   p: PCharArray;
  2897. begin
  2898.   p := @OutBuf;
  2899.   FillChar(B, SizeOf(B), 0);
  2900.   Move(Buf, B, N);
  2901.   L := N;
  2902.   if L mod 3 <> 0 then Inc(L, 3);
  2903.   Result := (L div 3) * 4;
  2904.   FillChar(p^, Result, Pad);
  2905.   I := 0; K := 0;
  2906.   while I < N do
  2907.     begin
  2908.       p^[K]   := Table[1+(B[I] shr 2)];
  2909.       p^[K+1] := Table[1+(((B[I] and $03) shl 4) or (B[I+1] shr 4))];
  2910.       if I+1 >= N then Break;
  2911.       p^[K+2] := Table[1+(((B[I+1] and $0F) shl 2) or (B[I+2] shr 6))];
  2912.       if I+2 >= N then Break;
  2913.       p^[K+3] := Table[1+(B[I+2] and $3F)];
  2914.       Inc(I, 3); Inc(K, 4);
  2915.     end;
  2916. end;
  2917.  
  2918.  
  2919.  
  2920.  
  2921. function TMimeCoder.Decode;
  2922.   var B: array [0..MMaxChars] of Byte absolute Buf;
  2923.       A: array [0..MMaxChars] of Byte;
  2924.       I,J,K, Pdd: Integer;
  2925. begin
  2926.   if S = '' then begin Result := 0; Exit end;
  2927.   Result := -1;
  2928.   FillChar(A, SizeOf(A), 0);
  2929.   for I := 0 to Length(S)-1 do
  2930.     begin
  2931.       A[I] := XChars[S[I+1]];
  2932.       if A[I] > 64 then Exit;
  2933.     end;
  2934.   J := Length(S);
  2935.   Pdd := 3;
  2936.   if (Pad = '=') then
  2937.     while S[J] = Pad do begin Dec(Pdd); Dec(J) end;
  2938.   Pdd := Pdd mod 3;
  2939.   Result := (J div 4) * 3 + Pdd;
  2940.   I := 0; K := 0;
  2941.   while I < J do
  2942.     begin
  2943.       B[K] := ((A[I] shl 2) or (A[I+1] shr 4)) and $FF;
  2944.       B[K+1] := ((A[I+1] shl 4) or (A[I+2] shr 2)) and $FF;
  2945.       B[K+2] := ((A[I+2] shl 6) or (A[I+3])) and $FF;
  2946.       Inc(I, 4); Inc(K, 3);
  2947.     end;
  2948. end;
  2949.  
  2950. function TMimeCoder.DecodeBuf(const SrcBuf; SrcLen: Integer; var Buf): Integer;
  2951. var
  2952.   B: array [0..MMaxChars] of Byte absolute Buf;
  2953.   A: array [0..MMaxChars] of Byte;
  2954.   I,J,K, Pdd: Integer;
  2955.   p: PByteArray;
  2956. begin
  2957.   p := @SrcBuf;
  2958.   if SrcLen = 0 then begin Result := 0; Exit end;
  2959.   Result := -1;
  2960.   FillChar(A, SizeOf(A), 0);
  2961.   for I := 0 to SrcLen-1 do
  2962.     begin
  2963.       A[I] := XChars[Char(P^[I])];
  2964.       if A[I] > 64 then Exit;
  2965.     end;
  2966.   J := SrcLen;
  2967.   Pdd := 3;
  2968.   if (Pad = '=') then
  2969.     while (J>0) and (Char(p^[J-1]) = Pad) do begin Dec(Pdd); Dec(J) end;
  2970.   Pdd := Pdd mod 3;
  2971.   Result := (J div 4) * 3 + Pdd;
  2972.   I := 0; K := 0;
  2973.   while I < J do
  2974.     begin
  2975.       B[K] := ((A[I] shl 2) or (A[I+1] shr 4)) and $FF;
  2976.       B[K+1] := ((A[I+1] shl 4) or (A[I+2] shr 2)) and $FF;
  2977.       B[K+2] := ((A[I+2] shl 6) or (A[I+3])) and $FF;
  2978.       Inc(I, 4); Inc(K, 3);
  2979.     end;
  2980. end;
  2981.  
  2982.  
  2983.  
  2984. end.
  2985.  
  2986.  
  2987.