| [17] | 1 | Unit ACLUtility;
|
|---|
| 2 |
|
|---|
| 3 | Interface
|
|---|
| 4 |
|
|---|
| 5 | Uses
|
|---|
| 6 | Classes, SysUtils,
|
|---|
| 7 | {$ifdef os2}
|
|---|
| 8 | Os2Def, IniFiles;
|
|---|
| 9 | {$endif}
|
|---|
| 10 | {$ifdef win32}
|
|---|
| 11 | Registry;
|
|---|
| 12 | {$endif}
|
|---|
| 13 |
|
|---|
| 14 | function GetACLLibraryVersion: string;
|
|---|
| 15 |
|
|---|
| 16 | Type
|
|---|
| 17 | TPrintOutput = procedure( TheText: string ) of object;
|
|---|
| 18 | TTerminateCheck = function: boolean of object;
|
|---|
| 19 | TProgressCallback = procedure( n, outof: integer;
|
|---|
| 20 | Message: string ) of object;
|
|---|
| 21 |
|
|---|
| 22 | const
|
|---|
| [152] | 23 | _MAX_PATH = 260; // max. length of full pathname
|
|---|
| [17] | 24 | _MAX_DRIVE = 3; // max. length of drive component
|
|---|
| 25 | _MAX_DIR = 256; // max. length of path component
|
|---|
| 26 | _MAX_FNAME = 256; // max. length of file name component
|
|---|
| 27 | _MAX_EXT = 256; // max. length of extension component
|
|---|
| 28 |
|
|---|
| 29 | mrFailed = $c000 + 1;
|
|---|
| 30 |
|
|---|
| 31 | {$ifdef win32}
|
|---|
| 32 | Function GetAPIErrorString( ErrorCode: integer ): string;
|
|---|
| 33 | Function GetLastAPIErrorString: string;
|
|---|
| 34 | {$endif}
|
|---|
| 35 |
|
|---|
| 36 | Type
|
|---|
| 37 | TMyIniFile =
|
|---|
| 38 | {$ifdef os2}
|
|---|
| 39 | class( TAsciiIniFile )
|
|---|
| 40 | {$else}
|
|---|
| 41 | class( TRegIniFile )
|
|---|
| 42 | {$endif}
|
|---|
| 43 | constructor CreateMe( const Path: string );
|
|---|
| 44 | destructor Destroy; override;
|
|---|
| 45 | end;
|
|---|
| 46 |
|
|---|
| 47 | {$ifdef os2}
|
|---|
| 48 | function AllocateMemory( const Size: longint ): pointer;
|
|---|
| 49 | procedure DeallocateMemory( Var P: pointer );
|
|---|
| 50 | procedure Sleep( const milliseconds: longint );
|
|---|
| 51 | {$endif}
|
|---|
| 52 |
|
|---|
| 53 | // allocate a new copy of the given source memory
|
|---|
| 54 | procedure AllocMemCopy( const Source: pointer;
|
|---|
| 55 | var Dest: pointer;
|
|---|
| 56 | const Size: longint );
|
|---|
| 57 |
|
|---|
| 58 | procedure MemCopy( const Source: pointer;
|
|---|
| 59 | const Dest: pointer;
|
|---|
| 60 | const Size: longint );
|
|---|
| 61 |
|
|---|
| 62 | procedure FillMem( Dest: pointer;
|
|---|
| 63 | Size: longint;
|
|---|
| 64 | Data: Byte );
|
|---|
| 65 |
|
|---|
| 66 | // Returns A - B
|
|---|
| 67 | function PtrDiff( A, B: pointer ): longword;
|
|---|
| 68 |
|
|---|
| 69 | function Min( const a: longint;
|
|---|
| 70 | const b: longint ): longint;
|
|---|
| 71 |
|
|---|
| 72 | function Max( const a: longint;
|
|---|
| 73 | const b: longint ): longint;
|
|---|
| 74 |
|
|---|
| 75 | function Between( const Value: longint;
|
|---|
| 76 | const Limit1: longint;
|
|---|
| 77 | const Limit2: longint ): boolean;
|
|---|
| 78 |
|
|---|
| 79 | function PtrBetween( const Value: pointer;
|
|---|
| 80 | const Limit1: pointer;
|
|---|
| 81 | const Limit2: pointer ): boolean;
|
|---|
| 82 |
|
|---|
| 83 | Procedure AddList( Source, Dest: TList );
|
|---|
| 84 |
|
|---|
| 85 | Procedure AssignList( Source, Dest: TList );
|
|---|
| 86 |
|
|---|
| 87 | // Destroy the objects stored in List
|
|---|
| 88 | // and clear the list.
|
|---|
| 89 | Procedure ClearListAndObjects( List: TList );
|
|---|
| 90 |
|
|---|
| 91 | // Destroy the objects stored in the list
|
|---|
| 92 | // and then destroy the list itself
|
|---|
| 93 | // And set the reference to nil
|
|---|
| 94 | Procedure DestroyListAndObjects( Var List: TList );
|
|---|
| 95 |
|
|---|
| 96 | // Destroy the objects stored in the list.
|
|---|
| 97 | // You probably want to use one of the two functions above.
|
|---|
| 98 | Procedure DestroyListObjects( List: TList );
|
|---|
| 99 |
|
|---|
| 100 | // Returns the filename of the running app
|
|---|
| 101 | // (including drive/directory)
|
|---|
| 102 | Function GetApplicationFilename: string;
|
|---|
| 103 |
|
|---|
| 104 | // Returns the starting directory of the app
|
|---|
| 105 | Function GetApplicationDir: string;
|
|---|
| 106 |
|
|---|
| 107 | {$ifdef win32}
|
|---|
| 108 | type
|
|---|
| 109 | TDaylightSavingStatus =
|
|---|
| 110 | (
|
|---|
| 111 | dssDisabled,
|
|---|
| 112 | dssDaylightSaving,
|
|---|
| 113 | dssNormal
|
|---|
| 114 | );
|
|---|
| 115 |
|
|---|
| 116 | function GetDaylightSavingStatus: TDaylightSavingStatus;
|
|---|
| 117 | {$endif}
|
|---|
| 118 |
|
|---|
| 119 | type
|
|---|
| 120 | TDataList = TList; // to help distinguish from TObjectList below
|
|---|
| 121 |
|
|---|
| 122 | type
|
|---|
| 123 | TObjectListSortCompare = function ( Item1, Item2: TObject ): Integer;
|
|---|
| 124 |
|
|---|
| 125 | // TObjectList has exactly the same functionality as TList,
|
|---|
| 126 | // except that rather than using untyped pointers it expects
|
|---|
| 127 | // object references. This means that incorrect typecasts can
|
|---|
| 128 | // be detected when using the list
|
|---|
| 129 | TObjectList = class( TList )
|
|---|
| 130 | protected
|
|---|
| 131 | function Get( index: integer ): TObject;
|
|---|
| 132 | procedure Put( index: integer; Item: TObject );
|
|---|
| 133 | public
|
|---|
| 134 | function Add( item: TObject ): integer;
|
|---|
| 135 | function First: TObject;
|
|---|
| 136 | function IndexOf( item: TObject ): integer;
|
|---|
| 137 | procedure Insert( Index: Integer; Item: TObject );
|
|---|
| 138 | function Last: TObject;
|
|---|
| 139 | function Remove( Item: TObject ): Integer;
|
|---|
| 140 | procedure Sort( Compare: TObjectListSortCompare );
|
|---|
| 141 | property Items[ index: integer ]: TObject read Get write Put; default;
|
|---|
| 142 |
|
|---|
| 143 | // Additional:
|
|---|
| 144 | // Copy the given list to this one.
|
|---|
| 145 | procedure Assign( Source: TObjectList );
|
|---|
| 146 | // Add the objects in the given list to this one
|
|---|
| 147 | procedure AddList( Source: TObjectList );
|
|---|
| 148 |
|
|---|
| 149 | end;
|
|---|
| 150 |
|
|---|
| [400] | 151 | {$ifdef os2}
|
|---|
| 152 | function GetCrc32( pData: pointer; size: longint ): longword;
|
|---|
| 153 | {$endif}
|
|---|
| 154 |
|
|---|
| 155 | function Pascal_GetCrc32( pData: pointer; size: longint ): longword;
|
|---|
| 156 |
|
|---|
| [17] | 157 | // Raise an exception if the given Code is <> 0
|
|---|
| 158 | procedure CheckSystemError( Code: longword;
|
|---|
| 159 | Message: string );
|
|---|
| 160 |
|
|---|
| 161 | {$ifdef os2}
|
|---|
| [400] | 162 | // get pointer to start, and length, of specified parameter
|
|---|
| 163 | procedure GetCommandLineParameter( item: byte;
|
|---|
| 164 | var pParam: pchar;
|
|---|
| 165 | var ParamLength: longint );
|
|---|
| 166 |
|
|---|
| [17] | 167 | function GetUserProfileString( const AppName: string;
|
|---|
| 168 | const KeyName: string;
|
|---|
| 169 | const Default: string ): string;
|
|---|
| 170 |
|
|---|
| 171 | Procedure SetUserProfileString( const AppName: string;
|
|---|
| 172 | const KeyName: string;
|
|---|
| 173 | const Value: string );
|
|---|
| 174 |
|
|---|
| 175 | Procedure LoadDLLFunction( const DLLName: string;
|
|---|
| 176 | const FunctionName: string;
|
|---|
| 177 | var hDLL: HMODULE;
|
|---|
| 178 | var F: pointer );
|
|---|
| 179 |
|
|---|
| 180 | {$endif}
|
|---|
| 181 |
|
|---|
| 182 | Implementation
|
|---|
| 183 |
|
|---|
| 184 | // Implementation ------------------------------------------
|
|---|
| 185 |
|
|---|
| 186 | Uses
|
|---|
| 187 | {$ifdef os2}
|
|---|
| 188 | Dos, BseDos, BseTib, PmWin, PmGpi, PmDev, PmShl;
|
|---|
| 189 | {$else}
|
|---|
| 190 | Windows, FileCtrl;
|
|---|
| 191 | {$endif}
|
|---|
| 192 |
|
|---|
| 193 | constructor TMyIniFile.CreateMe( const Path: string );
|
|---|
| 194 | begin
|
|---|
| 195 | {$ifdef os2}
|
|---|
| 196 | Inherited Create( Path );
|
|---|
| 197 | {$else}
|
|---|
| 198 | Inherited Create( Path );
|
|---|
| 199 | {$endif}
|
|---|
| 200 | end;
|
|---|
| 201 |
|
|---|
| 202 | destructor TMyIniFile.Destroy;
|
|---|
| 203 | begin
|
|---|
| 204 | {$ifdef os2}
|
|---|
| 205 | Refresh;
|
|---|
| 206 | {$endif}
|
|---|
| 207 | inherited Destroy;
|
|---|
| 208 | end;
|
|---|
| 209 |
|
|---|
| 210 | {$ifdef os2}
|
|---|
| 211 | function AllocateMemory( const Size: longint ): pointer;
|
|---|
| 212 | begin
|
|---|
| 213 | GetMem( Result, size + sizeof( Size ) );
|
|---|
| 214 | pLong( Result )^ := Size;
|
|---|
| 215 | inc( Result, sizeof( Size ) );
|
|---|
| 216 | end;
|
|---|
| 217 |
|
|---|
| 218 | procedure DeallocateMemory( Var P: pointer );
|
|---|
| 219 | var
|
|---|
| 220 | Size: longint;
|
|---|
| 221 | begin
|
|---|
| 222 | if P = nil then
|
|---|
| 223 | exit;
|
|---|
| 224 |
|
|---|
| 225 | dec( P, sizeof( Size ) );
|
|---|
| 226 | Size := pLong( P )^;
|
|---|
| 227 | FreeMem( P, Size + sizeof( Size ) );
|
|---|
| 228 | P := nil;
|
|---|
| 229 | end;
|
|---|
| 230 | {$endif}
|
|---|
| 231 |
|
|---|
| 232 | {$ifdef win32}
|
|---|
| 233 | Function GetAPIErrorString( ErrorCode: integer ): string;
|
|---|
| 234 | var
|
|---|
| 235 | buffer: array[ 0..1000 ] of char;
|
|---|
| 236 | begin
|
|---|
| 237 | if FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM,
|
|---|
| 238 | nil, // no special message source
|
|---|
| 239 | ErrorCode,
|
|---|
| 240 | 0, // use default language
|
|---|
| 241 | Buffer,
|
|---|
| 242 | Sizeof( Buffer ),
|
|---|
| 243 | nil ) > 0
|
|---|
| 244 | then // no arguments
|
|---|
| 245 | Result:= IntToStr( ErrorCode ) + ': ' + Buffer
|
|---|
| 246 | else
|
|---|
| 247 | Result:= '(Unknown error)';
|
|---|
| 248 |
|
|---|
| 249 | end;
|
|---|
| 250 |
|
|---|
| 251 | Function GetLastAPIErrorString: string;
|
|---|
| 252 | begin
|
|---|
| 253 | Result := GetAPIErrorString( GetLastError );
|
|---|
| 254 | end;
|
|---|
| 255 | {$endif}
|
|---|
| 256 |
|
|---|
| 257 | procedure AllocMemCopy( const Source: pointer;
|
|---|
| 258 | var Dest: pointer;
|
|---|
| 259 | const Size: longint );
|
|---|
| 260 | begin
|
|---|
| 261 | GetMem( Dest, Size );
|
|---|
| 262 | MemCopy( Source, Dest, Size );
|
|---|
| 263 | end;
|
|---|
| 264 |
|
|---|
| 265 | procedure MemCopy( const Source: pointer;
|
|---|
| 266 | const Dest: pointer;
|
|---|
| 267 | const Size: longint );
|
|---|
| 268 | begin
|
|---|
| 269 | Move( Source^, Dest^, Size );
|
|---|
| 270 | end;
|
|---|
| 271 |
|
|---|
| 272 | procedure FillMem( Dest: pointer;
|
|---|
| 273 | Size: longint;
|
|---|
| 274 | Data: Byte );
|
|---|
| 275 | begin
|
|---|
| 276 | FillChar( Dest^, Size, Data );
|
|---|
| 277 | end;
|
|---|
| 278 |
|
|---|
| 279 | function PtrDiff( A, B: pointer ): longword;
|
|---|
| 280 | begin
|
|---|
| 281 | result:= longword( A ) - longword( B );
|
|---|
| 282 | end;
|
|---|
| 283 |
|
|---|
| 284 | Procedure AddList( Source, Dest: TList );
|
|---|
| 285 | var
|
|---|
| 286 | i: longint;
|
|---|
| 287 | begin
|
|---|
| 288 | // expand the destination list
|
|---|
| 289 | // to what's required
|
|---|
| 290 | Dest.Capacity := Dest.Capacity
|
|---|
| 291 | + Source.Capacity;
|
|---|
| 292 | for i:= 0 to Source.Count - 1 do
|
|---|
| 293 | Dest.Add( Source[ i ] );
|
|---|
| 294 | end;
|
|---|
| 295 |
|
|---|
| 296 | Procedure AssignList( Source, Dest: TList );
|
|---|
| 297 | begin
|
|---|
| 298 | Dest.Clear;
|
|---|
| 299 | AddList( Source, Dest );
|
|---|
| 300 | end;
|
|---|
| 301 |
|
|---|
| 302 | {$ifdef win32}
|
|---|
| 303 | function GetDaylightSavingStatus: TDaylightSavingStatus;
|
|---|
| 304 | var
|
|---|
| 305 | TimeZoneInfo: TIME_ZONE_INFORMATION;
|
|---|
| 306 | ZoneID: DWORD;
|
|---|
| 307 | Begin
|
|---|
| 308 | ZoneID:= GetTimeZoneInformation( TimeZoneInfo );
|
|---|
| 309 | if TimeZoneInfo.DaylightBias = 0 then
|
|---|
| 310 | Result:= dssDisabled
|
|---|
| 311 | else if ZoneID = TIME_ZONE_ID_DAYLIGHT then
|
|---|
| 312 | Result:= dssDaylightSaving
|
|---|
| 313 | else
|
|---|
| 314 | Result:= dssNormal;
|
|---|
| 315 | end;
|
|---|
| 316 | {$endif}
|
|---|
| 317 |
|
|---|
| 318 | // Destroy the objects stored in List
|
|---|
| 319 | // and clear the list.
|
|---|
| 320 | Procedure ClearListAndObjects( List: TList );
|
|---|
| 321 | begin
|
|---|
| 322 | DestroyListObjects( List );
|
|---|
| 323 | List.Clear;
|
|---|
| 324 | end;
|
|---|
| 325 |
|
|---|
| 326 | // Destroy the objects stored in the list
|
|---|
| 327 | // and then destroy the list itself.
|
|---|
| 328 | Procedure DestroyListAndObjects( Var List: TList );
|
|---|
| 329 | begin
|
|---|
| 330 | if not Assigned( List ) then
|
|---|
| 331 | exit;
|
|---|
| 332 |
|
|---|
| 333 | DestroyListObjects( List );
|
|---|
| 334 | List.Destroy;
|
|---|
| 335 | List := nil;
|
|---|
| 336 | end;
|
|---|
| 337 |
|
|---|
| 338 | Procedure DestroyListObjects( List: TList );
|
|---|
| 339 | var
|
|---|
| 340 | Index: longint;
|
|---|
| 341 | begin
|
|---|
| 342 | for Index := 0 to List.Count - 1 do
|
|---|
| 343 | begin
|
|---|
| 344 | if List[ Index ] <> nil then
|
|---|
| 345 | begin
|
|---|
| 346 | TObject( List[ Index ] ).Destroy;
|
|---|
| 347 | List[ Index ] := nil;
|
|---|
| 348 | end;
|
|---|
| 349 | end;
|
|---|
| 350 | end;
|
|---|
| 351 |
|
|---|
| 352 | function Min( const a: longint;
|
|---|
| 353 | const b: longint ): longint;
|
|---|
| 354 | begin
|
|---|
| 355 | if a<b then
|
|---|
| 356 | result:= a
|
|---|
| 357 | else
|
|---|
| 358 | result:= b;
|
|---|
| 359 | end;
|
|---|
| 360 |
|
|---|
| 361 | function Max( const a: longint;
|
|---|
| 362 | const b: longint ): longint;
|
|---|
| 363 | begin
|
|---|
| 364 | if a>b then
|
|---|
| 365 | result:= a
|
|---|
| 366 | else
|
|---|
| 367 | result:= b;
|
|---|
| 368 | end;
|
|---|
| 369 |
|
|---|
| 370 | function Between( const Value: longint;
|
|---|
| 371 | const Limit1: longint;
|
|---|
| 372 | const Limit2: longint ): boolean;
|
|---|
| 373 | begin
|
|---|
| 374 | if Limit1 < Limit2 then
|
|---|
| 375 | Result:= ( Value >= Limit1 ) and ( Value <= Limit2 )
|
|---|
| 376 | else
|
|---|
| 377 | Result:= ( Value >= Limit2 ) and ( Value <= Limit1 )
|
|---|
| 378 | end;
|
|---|
| 379 |
|
|---|
| 380 | function PtrBetween( const Value: pointer;
|
|---|
| 381 | const Limit1: pointer;
|
|---|
| 382 | const Limit2: pointer ): boolean;
|
|---|
| 383 | var
|
|---|
| 384 | v, p1, p2: pchar;
|
|---|
| 385 | begin
|
|---|
| 386 | v := Value;
|
|---|
| 387 | p1 := Limit1;
|
|---|
| 388 | p2 := Limit2;
|
|---|
| 389 | if p1 < p2 then
|
|---|
| 390 | Result:= ( V >= p1 ) and ( V <= p2 )
|
|---|
| 391 | else
|
|---|
| 392 | Result:= ( V >= p2 ) and ( V <= p1 )
|
|---|
| 393 | end;
|
|---|
| 394 |
|
|---|
| 395 | {$ifdef os2}
|
|---|
| 396 | Function GetApplicationFilename: string;
|
|---|
| 397 | var
|
|---|
| 398 | pThreadInfo: PTIB;
|
|---|
| 399 | pProcessInfo: PPIB;
|
|---|
| 400 | ProcessName: cstring[ _MAX_PATH ];
|
|---|
| 401 | begin
|
|---|
| 402 | DosGetInfoBlocks( pThreadInfo,
|
|---|
| 403 | pProcessInfo );
|
|---|
| 404 | DosQueryModuleName( pProcessInfo^.pib_hmte,
|
|---|
| 405 | sizeof( ProcessName ),
|
|---|
| 406 | ProcessName );
|
|---|
| 407 | Result := ProcessName;
|
|---|
| 408 | end;
|
|---|
| 409 | {$else}
|
|---|
| 410 | Function GetApplicationFilename: string;
|
|---|
| 411 | var
|
|---|
| 412 | ProcessName: array[ 0.._MAX_PATH ] of char;
|
|---|
| 413 | begin
|
|---|
| 414 | GetModuleFileName( 0, // our own process
|
|---|
| 415 | ProcessName,
|
|---|
| 416 | sizeof( ProcessName ) );
|
|---|
| 417 |
|
|---|
| 418 | Result := ProcessName;
|
|---|
| 419 | end;
|
|---|
| 420 | {$endif}
|
|---|
| 421 |
|
|---|
| 422 | Function GetApplicationDir: string;
|
|---|
| 423 | begin
|
|---|
| 424 | Result := ExtractFilePath( GetApplicationFilename );
|
|---|
| 425 | end;
|
|---|
| 426 |
|
|---|
| 427 | { TObjectList }
|
|---|
| 428 |
|
|---|
| 429 | function TObjectList.Add( item: TObject ): integer;
|
|---|
| 430 | begin
|
|---|
| 431 | result := inherited Add( item );
|
|---|
| 432 | end;
|
|---|
| 433 |
|
|---|
| 434 | function TObjectList.First: TObject;
|
|---|
| 435 | begin
|
|---|
| 436 | result := inherited First;
|
|---|
| 437 | end;
|
|---|
| 438 |
|
|---|
| 439 | function TObjectList.Get( index: integer ): TObject;
|
|---|
| 440 | begin
|
|---|
| 441 | result := Items[ Index ];
|
|---|
| 442 | end;
|
|---|
| 443 |
|
|---|
| 444 | function TObjectList.IndexOf( item: TObject ): integer;
|
|---|
| 445 | begin
|
|---|
| 446 | result := inherited IndexOf( item );
|
|---|
| 447 | end;
|
|---|
| 448 |
|
|---|
| 449 | procedure TObjectList.Insert( Index: Integer; Item: TObject );
|
|---|
| 450 | begin
|
|---|
| 451 | inherited Insert( Index, Item );
|
|---|
| 452 | end;
|
|---|
| 453 |
|
|---|
| 454 | function TObjectList.Last: TObject;
|
|---|
| 455 | begin
|
|---|
| 456 | result := inherited Last;
|
|---|
| 457 | end;
|
|---|
| 458 |
|
|---|
| 459 | procedure TObjectList.Put( index: integer; Item: TObject );
|
|---|
| 460 | begin
|
|---|
| 461 | Items[ Index ] := Item;
|
|---|
| 462 | end;
|
|---|
| 463 |
|
|---|
| 464 | function TObjectList.Remove( Item: TObject ): Integer;
|
|---|
| 465 | begin
|
|---|
| 466 | result := inherited Remove( Item );
|
|---|
| 467 | end;
|
|---|
| 468 |
|
|---|
| 469 | procedure QuickSortObjectList( SortList: PPointerList;
|
|---|
| 470 | L, R: Integer;
|
|---|
| 471 | CompareFunction: TObjectListSortCompare );
|
|---|
| 472 | var
|
|---|
| 473 | I, J: Integer;
|
|---|
| 474 | P, T: Pointer;
|
|---|
| 475 | begin
|
|---|
| 476 | repeat
|
|---|
| 477 | I := L;
|
|---|
| 478 | J := R;
|
|---|
| 479 | P := SortList^[(L + R) shr 1];
|
|---|
| 480 | repeat
|
|---|
| 481 | while CompareFunction( TObject( SortList^[I] ), P ) < 0 do
|
|---|
| 482 | Inc(I);
|
|---|
| 483 | while CompareFunction( TObject( SortList^[J] ), P) > 0 do
|
|---|
| 484 | Dec(J);
|
|---|
| 485 | if I <= J then
|
|---|
| 486 | begin
|
|---|
| 487 | T := SortList^[I];
|
|---|
| 488 | SortList^[I] := SortList^[J];
|
|---|
| 489 | SortList^[J] := T;
|
|---|
| 490 | Inc(I);
|
|---|
| 491 | Dec(J);
|
|---|
| 492 | end;
|
|---|
| 493 | until I > J;
|
|---|
| 494 | if L < J then
|
|---|
| 495 | QuickSortObjectList( SortList, L, J, CompareFunction );
|
|---|
| 496 | L := I;
|
|---|
| 497 | until I >= R;
|
|---|
| 498 | end;
|
|---|
| 499 |
|
|---|
| 500 | procedure TObjectList.Sort( Compare: TObjectListSortCompare );
|
|---|
| 501 | begin
|
|---|
| 502 | if ( List <> nil ) and ( Count > 0 ) then
|
|---|
| 503 | QuickSortObjectList( List, 0, Count - 1, Compare );
|
|---|
| 504 | end;
|
|---|
| 505 |
|
|---|
| 506 | procedure TObjectList.Assign( Source: TObjectList );
|
|---|
| 507 | begin
|
|---|
| 508 | Clear;
|
|---|
| 509 | AddList( Source );
|
|---|
| 510 | end;
|
|---|
| 511 |
|
|---|
| 512 | procedure TObjectList.AddList( Source: TObjectList );
|
|---|
| 513 | var
|
|---|
| 514 | i: integer;
|
|---|
| 515 | begin
|
|---|
| 516 | for i := 0 to Source.Count - 1 do
|
|---|
| 517 | Add( Source[ i ] );
|
|---|
| 518 | end;
|
|---|
| 519 |
|
|---|
| 520 | {$ifdef os2}
|
|---|
| 521 | procedure Sleep( const milliseconds: longint );
|
|---|
| 522 | begin
|
|---|
| 523 | DosSleep( milliseconds );
|
|---|
| 524 | end;
|
|---|
| 525 | {$endif}
|
|---|
| 526 |
|
|---|
| [400] | 527 | const
|
|---|
| 528 | Crc32Table: array[ 0..255 ] of longword =
|
|---|
| 529 | (
|
|---|
| 530 | $00000000, $77073096, $EE0E612C, $990951BA,
|
|---|
| 531 | $076DC419, $706AF48F, $E963A535, $9E6495A3,
|
|---|
| 532 | $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
|
|---|
| 533 | $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
|
|---|
| 534 | $1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
|
|---|
| 535 | $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
|
|---|
| 536 | $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
|
|---|
| 537 | $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
|
|---|
| 538 | $3B6E20C8, $4C69105E, $D56041E4, $A2677172,
|
|---|
| 539 | $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
|
|---|
| 540 | $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
|
|---|
| 541 | $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
|
|---|
| 542 | $26D930AC, $51DE003A, $C8D75180, $BFD06116,
|
|---|
| 543 | $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
|
|---|
| 544 | $2802B89E, $5F058808, $C60CD9B2, $B10BE924,
|
|---|
| 545 | $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
|
|---|
| 546 | $76DC4190, $01DB7106, $98D220BC, $EFD5102A,
|
|---|
| 547 | $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
|
|---|
| 548 | $7807C9A2, $0F00F934, $9609A88E, $E10E9818,
|
|---|
| 549 | $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
|
|---|
| 550 | $6B6B51F4, $1C6C6162, $856530D8, $F262004E,
|
|---|
| 551 | $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
|
|---|
| 552 | $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
|
|---|
| 553 | $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
|
|---|
| 554 | $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
|
|---|
| 555 | $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
|
|---|
| 556 | $4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
|
|---|
| 557 | $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
|
|---|
| 558 | $5005713C, $270241AA, $BE0B1010, $C90C2086,
|
|---|
| 559 | $5768B525, $206F85B3, $B966D409, $CE61E49F,
|
|---|
| 560 | $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
|
|---|
| 561 | $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
|
|---|
| 562 | $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
|
|---|
| 563 | $EAD54739, $9DD277AF, $04DB2615, $73DC1683,
|
|---|
| 564 | $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
|
|---|
| 565 | $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
|
|---|
| 566 | $F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
|
|---|
| 567 | $F762575D, $806567CB, $196C3671, $6E6B06E7,
|
|---|
| 568 | $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
|
|---|
| 569 | $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
|
|---|
| 570 | $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
|
|---|
| 571 | $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
|
|---|
| 572 | $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
|
|---|
| 573 | $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
|
|---|
| 574 | $CB61B38C, $BC66831A, $256FD2A0, $5268E236,
|
|---|
| 575 | $CC0C7795, $BB0B4703, $220216B9, $5505262F,
|
|---|
| 576 | $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
|
|---|
| 577 | $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
|
|---|
| 578 | $9B64C2B0, $EC63F226, $756AA39C, $026D930A,
|
|---|
| 579 | $9C0906A9, $EB0E363F, $72076785, $05005713,
|
|---|
| 580 | $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
|
|---|
| 581 | $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
|
|---|
| 582 | $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
|
|---|
| 583 | $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
|
|---|
| 584 | $88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
|
|---|
| 585 | $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
|
|---|
| 586 | $A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
|
|---|
| 587 | $A7672661, $D06016F7, $4969474D, $3E6E77DB,
|
|---|
| 588 | $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
|
|---|
| 589 | $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
|
|---|
| 590 | $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
|
|---|
| 591 | $BAD03605, $CDD70693, $54DE5729, $23D967BF,
|
|---|
| 592 | $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
|
|---|
| 593 | $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D
|
|---|
| 594 | );
|
|---|
| 595 |
|
|---|
| 596 | function Pascal_GetCrc32( pData: pointer; size: longint ): longword;
|
|---|
| 597 | var
|
|---|
| 598 | i: longint;
|
|---|
| 599 | p: pbyte;
|
|---|
| 600 | begin
|
|---|
| 601 | Result := $ffffffff;
|
|---|
| 602 | p := pData;
|
|---|
| 603 | for i := 0 to size - 1 do
|
|---|
| 604 | begin
|
|---|
| 605 | Result := ( Result shr 8 )
|
|---|
| 606 | xor Crc32Table[ ( Result xor p^ ) and $000000FF ];
|
|---|
| 607 | inc( p );
|
|---|
| 608 | end;
|
|---|
| 609 | end;
|
|---|
| 610 |
|
|---|
| 611 | {$ifdef os2}
|
|---|
| 612 | function GetCrc32( pData: pointer; size: longint ): longword;
|
|---|
| 613 | begin
|
|---|
| 614 | asm
|
|---|
| 615 | mov esi, pData {esi: Points to Buffer}
|
|---|
| 616 | mov edx, $ffffffff {edx: Result}
|
|---|
| 617 | mov ecx, Size
|
|---|
| 618 | xor eax, eax {clear EAX: top bits must remain 0}
|
|---|
| 619 | cld
|
|---|
| 620 |
|
|---|
| 621 | @@Loop:
|
|---|
| 622 | mov ebx, edx {Save Result in ebx}
|
|---|
| 623 | shr edx, 8
|
|---|
| 624 | lodsb {Load next Buffer entry}
|
|---|
| 625 | xor ebx, eax
|
|---|
| 626 | and ebx, $ff
|
|---|
| 627 |
|
|---|
| 628 | // should be able to use
|
|---|
| 629 | // xor edx, dword ptr [edi+4*ebx]
|
|---|
| 630 | // Sibyl Assembler doesn't support it!
|
|---|
| 631 |
|
|---|
| 632 | mov edi, ebx {Get lookup index}
|
|---|
| 633 | shl edi, 2 {x4 to get address for longword}
|
|---|
| 634 | xor edx, Crc32Table[edi] {lookup in table, XOR with edx}
|
|---|
| 635 |
|
|---|
| 636 | dec ecx {Dec Count}
|
|---|
| 637 | jnz @@Loop {if Count<>0 goto @@Loop}
|
|---|
| 638 |
|
|---|
| 639 | mov Result, edx {Save Result}
|
|---|
| 640 | end;
|
|---|
| 641 | end;
|
|---|
| 642 | {$endif}
|
|---|
| 643 |
|
|---|
| [17] | 644 | // Raise an exception if the given Code is <> 0
|
|---|
| 645 | procedure CheckSystemError( Code: longword;
|
|---|
| 646 | Message: string );
|
|---|
| 647 | begin
|
|---|
| 648 | if Code <> 0 then
|
|---|
| 649 | raise Exception.Create( Message
|
|---|
| 650 | + ': ['
|
|---|
| 651 | + IntToStr( Code )
|
|---|
| 652 | + '] '
|
|---|
| 653 | + SysErrorMessage( Code ) );
|
|---|
| 654 | end;
|
|---|
| 655 |
|
|---|
| 656 | {$ifdef os2}
|
|---|
| [400] | 657 | procedure GetCommandLineParameter( item: byte;
|
|---|
| 658 | var pParam: pchar;
|
|---|
| 659 | var ParamLength: longint );
|
|---|
| 660 |
|
|---|
| 661 | Begin
|
|---|
| 662 | ParamLength := 0;
|
|---|
| 663 | ASM
|
|---|
| 664 | MOV CL, item // Load item to CL
|
|---|
| 665 | MOV AL, 2
|
|---|
| 666 | MOV ESI, SYSTEM.ArgStart // Get start of parameters
|
|---|
| 667 | CALLN32 SYSTEM.!ParaInfo // Get start of this parameter
|
|---|
| 668 |
|
|---|
| 669 | LEA EDI, pParam // Address of pParam
|
|---|
| 670 | MOV EDI, [EDI] // Address of what pParam references
|
|---|
| 671 | MOV [EDI], ESI // store start of param
|
|---|
| 672 |
|
|---|
| 673 | CMP ESI, 0 // Parameter invalid ?
|
|---|
| 674 | JE gclp_End // leave if invalid
|
|---|
| 675 |
|
|---|
| 676 | CLD
|
|---|
| 677 | MOV ECX, 0 // Len is 0
|
|---|
| 678 | MOV DL, 0 // we are not in quote state
|
|---|
| 679 |
|
|---|
| 680 | gclp_Loop:
|
|---|
| 681 | LODSB // load byte of parameter
|
|---|
| 682 |
|
|---|
| 683 | CMP AL, '"' // Check for quote char
|
|---|
| 684 | JNE gclp_NotQuote
|
|---|
| 685 | NOT DL // toggle quote flag
|
|---|
| 686 |
|
|---|
| 687 | gclp_NotQuote:
|
|---|
| 688 | CMP AL, ' ' // check for space - end of parameter
|
|---|
| 689 | JNE gclp_NotEnd
|
|---|
| 690 | // parameter has ended, unless in quote
|
|---|
| 691 | CMP DL, 0 // check quote flag
|
|---|
| 692 | JE gclp_Done // if off, then we're finished
|
|---|
| 693 |
|
|---|
| 694 | gclp_NotEnd:
|
|---|
| 695 | CMP AL, 0 // check for zero terminator at end of last parameter
|
|---|
| 696 | JE gclp_Done // if found, we're finished
|
|---|
| 697 |
|
|---|
| 698 | INC ECX // OK we have one more byte
|
|---|
| 699 | JMP gclp_Loop // next please
|
|---|
| 700 |
|
|---|
| 701 | gclp_Done:
|
|---|
| 702 | // now to remove quotes at start/end
|
|---|
| 703 | CMP ECX, 0
|
|---|
| 704 | JE gclp_NoQuotes // length is zero, can't be quotes
|
|---|
| 705 |
|
|---|
| 706 | LEA EDI, pParam // Address of pParam
|
|---|
| 707 | MOV EDI, [EDI] // Address of what pParam references
|
|---|
| 708 | MOV ESI, [EDI] // get start of param
|
|---|
| 709 |
|
|---|
| 710 | MOV AL, [ESI+ECX-1] // get last char
|
|---|
| 711 | CMP AL, '"' // check if quote
|
|---|
| 712 | JNE gclp_EndQuoteDone
|
|---|
| 713 | DEC ECX // decrease length
|
|---|
| 714 | CMP ECX, 0
|
|---|
| 715 | JE gclp_StartQuoteDone // length is zero, can't be another quote
|
|---|
| 716 | gclp_EndQuoteDone:
|
|---|
| 717 |
|
|---|
| 718 | LODSB // load first byte, inc ESI
|
|---|
| 719 | CMP AL, '"' // check if quote
|
|---|
| 720 | JNE gclp_StartQuoteDone
|
|---|
| 721 | DEC ECX // quote, so decrease length
|
|---|
| 722 | MOV [EDI], ESI // store new start of param
|
|---|
| 723 | gclp_StartQuoteDone:
|
|---|
| 724 |
|
|---|
| 725 | gclp_NoQuotes:
|
|---|
| 726 | LEA EDI,ParamLength // address of ParamLength
|
|---|
| 727 | MOV EDI, [EDI] // dereference
|
|---|
| 728 | MOV [EDI],ECX // store length
|
|---|
| 729 | gclp_End:
|
|---|
| 730 | END;
|
|---|
| 731 | END;
|
|---|
| 732 |
|
|---|
| [17] | 733 | function GetUserProfileString( const AppName: string;
|
|---|
| 734 | const KeyName: string;
|
|---|
| 735 | const Default: string ): string;
|
|---|
| 736 | var
|
|---|
| 737 | Buffer: array[ 0..255 ] of char;
|
|---|
| 738 | Len: longint;
|
|---|
| 739 | i: longint;
|
|---|
| 740 | szDefault: cstring;
|
|---|
| 741 | begin
|
|---|
| 742 | szDefault := Default;
|
|---|
| 743 | Len := PrfQueryProfileString( HINI_USERPROFILE, // user profile
|
|---|
| 744 | AppName, // application
|
|---|
| 745 | KeyName, // key
|
|---|
| 746 | szDefault,
|
|---|
| 747 | Buffer,
|
|---|
| 748 | sizeof( Buffer ) );
|
|---|
| 749 |
|
|---|
| 750 | // remove null terminator, if present
|
|---|
| 751 | if Len > 0 then
|
|---|
| 752 | if Buffer[ Len - 1 ] = #0 then
|
|---|
| 753 | dec( Len );
|
|---|
| 754 | Result := '';
|
|---|
| 755 | for i := 0 to Len - 1 do
|
|---|
| 756 | Result := Result + Buffer[ i ];
|
|---|
| 757 | end;
|
|---|
| 758 |
|
|---|
| 759 | Procedure SetUserProfileString( const AppName: string;
|
|---|
| 760 | const KeyName: string;
|
|---|
| 761 | const Value: string );
|
|---|
| 762 | begin
|
|---|
| 763 | if not PrfWriteProfileString( HINI_USERPROFILE, // user profile
|
|---|
| 764 | AppName, // application
|
|---|
| 765 | KeyName, // key
|
|---|
| 766 | Value ) then
|
|---|
| 767 | raise Exception.Create(
|
|---|
| 768 | 'Error writing INI ['
|
|---|
| 769 | + AppName
|
|---|
| 770 | + '/'
|
|---|
| 771 | + KeyName
|
|---|
| 772 | + '] rc = '
|
|---|
| 773 | + IntToHex( WinGetLastError( AppHandle ), 8 ) );
|
|---|
| 774 | end;
|
|---|
| 775 |
|
|---|
| 776 | procedure LoadDLLFunction( const DLLName: string;
|
|---|
| 777 | const FunctionName: string;
|
|---|
| 778 | var hDLL: HMODULE;
|
|---|
| 779 | var F: pointer );
|
|---|
| 780 | var
|
|---|
| 781 | ActualDLLName: string;
|
|---|
| 782 | csErrorObject: cstring;
|
|---|
| 783 | csFunctionName: cstring;
|
|---|
| 784 | rc: APIRET;
|
|---|
| 785 | begin
|
|---|
| 786 | F := nil;
|
|---|
| 787 |
|
|---|
| 788 | if hDLL = NullHandle then
|
|---|
| 789 | begin
|
|---|
| 790 | ActualDLLName := GetApplicationDir + DLLName;
|
|---|
| 791 | if not FileExists( ActualDLLName ) then
|
|---|
| 792 | ActualDLLName := DLLName;
|
|---|
| 793 |
|
|---|
| 794 | rc := DosLoadModule( csErrorObject,
|
|---|
| 795 | sizeof( csErrorObject ),
|
|---|
| 796 | ActualDLLName,
|
|---|
| 797 | hDLL );
|
|---|
| 798 | if rc <> 0 then
|
|---|
| 799 | raise Exception.Create( DLLName
|
|---|
| 800 | + ' could not be loaded: '
|
|---|
| 801 | + SysErrorMessage( rc ) );
|
|---|
| 802 |
|
|---|
| 803 | end;
|
|---|
| 804 |
|
|---|
| 805 | csFunctionName := FunctionName;
|
|---|
| 806 | rc := DosQueryProcAddr( hDLL,
|
|---|
| 807 | 0, // using by name
|
|---|
| 808 | csFunctionName,
|
|---|
| 809 | F );
|
|---|
| 810 | if rc <> 0 then
|
|---|
| 811 | raise Exception.Create( FunctionName
|
|---|
| 812 | + ' in '
|
|---|
| 813 | + DLLName
|
|---|
| 814 | + ': '
|
|---|
| 815 | + SysErrorMessage( rc ) );
|
|---|
| 816 | end;
|
|---|
| 817 |
|
|---|
| 818 | {$endif}
|
|---|
| 819 |
|
|---|
| 820 | const
|
|---|
| 821 | LibVersion = 'V1.5.14'; // $SS_REQUIRE_NEW_VERSION$
|
|---|
| 822 |
|
|---|
| 823 | function GetACLLibraryVersion: string;
|
|---|
| 824 | begin
|
|---|
| 825 | Result := LibVersion;
|
|---|
| 826 | end;
|
|---|
| 827 |
|
|---|
| 828 | Initialization
|
|---|
| 829 | End.
|
|---|
| 830 |
|
|---|
