src/shared/utils.pas

   1 (* Copyright (C)  Doom 2D: Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, version 3 of the License ONLY.
   6  *
   7  * This program is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  14  *)
  15 {$INCLUDE a_modes.inc}
  16 unit utils;
  17
  18 interface
  19
  20 uses
  21   SysUtils, Classes, md5;
  22
  23
  24 // ////////////////////////////////////////////////////////////////////////// //
  25 type
  26   SSArray = array of ShortString;
  27
  28
  29 const wadExtensions: array [0..6] of AnsiString = (
  30   '.dfz',
  31   '.wad',
  32   '.dfwad',
  33   '.pk3',
  34   '.pak',
  35   '.zip',
  36   '.dfzip'
  37 );
  38
  39
  40 // ////////////////////////////////////////////////////////////////////////// //
  41 type
  42   TUtf8DecoderFast = packed record
  43   public
  44     const Replacement = $FFFD; // replacement char for invalid unicode
  45     const Accept = 0;
  46     const Reject = 12;
  47
  48   private
  49     state: LongWord;
  50
  51   public
  52     codepoint: LongWord; // decoded codepoint (valid only when decoder is in "complete" state)
  53
  54   public
  55     constructor Create (v: Boolean{fuck you, fpc});
  56
  57     procedure reset (); inline;
  58
  59     function complete (): Boolean; inline; // is current character complete? take `codepoint` then
  60     function invalid (): Boolean; inline;
  61     function completeOrInvalid (): Boolean; inline;
  62
  63     // process one byte, return `true` if codepoint is ready
  64     function decode (b: Byte): Boolean; inline; overload;
  65     function decode (c: AnsiChar): Boolean; inline; overload;
  66   end;
  67
  68
  69 // ////////////////////////////////////////////////////////////////////////// //
  70 function getFilenameExt (const fn: AnsiString): AnsiString;
  71 function setFilenameExt (const fn, ext: AnsiString): AnsiString;
  72 function forceFilenameExt (const fn, ext: AnsiString): AnsiString;
  73
  74 // strips out name from `fn`, leaving trailing slash
  75 function getFilenamePath (const fn: AnsiString): AnsiString;
  76
  77 // ends with '/' or '\'?
  78 function isFilenamePath (const fn: AnsiString): Boolean;
  79
  80 // strips extra trailing slashes in `path, and extra leading slashes in `fn`
  81 // will add slash to `path`, even if `fn` is empty!
  82 function filenameConcat (const path, fn: AnsiString): AnsiString;
  83
  84 // does filename have one of ".wad", ".pk3", ".zip" extensions?
  85 function hasWadExtension (const fn: AnsiString): Boolean;
  86
  87 // does filepath have ".XXX:\" in it?
  88 function isWadPath (const fn: AnsiString): Boolean;
  89
  90 // adds ".wad" extension if filename doesn't have one of ".wad", ".pk3", ".zip"
  91 function addWadExtension (const fn: AnsiString): AnsiString;
  92
  93 // check wad signature
  94 function isWadData (data: Pointer; len: LongWord): Boolean;
  95
  96 // convert number to strig with nice commas
  97 function int64ToStrComma (i: Int64): AnsiString;
  98
  99 function upcase1251 (ch: AnsiChar): AnsiChar; inline;
 100 function locase1251 (ch: AnsiChar): AnsiChar; inline;
 101 function IsValid1251 (ch: Word): Boolean;
 102 function IsPrintable1251 (ch: AnsiChar): Boolean;
 103
 104 function toLowerCase1251 (const s: AnsiString): AnsiString;
 105
 106 // `true` if strings are equal; ignoring case for cp1251
 107 function strEquCI1251 (const s0, s1: AnsiString): Boolean;
 108
 109 function utf8Valid (const s: AnsiString): Boolean;
 110
 111 function utf8to1251 (s: AnsiString): AnsiString;
 112
 113 // findFileCI takes case-insensitive path, traverses it, and rewrites it to
 114 // a case-sensetive one (using real on-disk names). return value means 'success'.
 115 // if some dir or file wasn't found, pathname is undefined (destroyed, but not
 116 // necessarily cleared).
 117 // last name assumed to be a file, not directory (unless `lastIsDir` flag is set).
 118 function findFileCI (var pathname: AnsiString; lastIsDir: Boolean=false): Boolean;
 119
 120 // findDiskWad tries to find the wad file using common wad extensions
 121 // (see `wadExtensions` array).
 122 // returns real on-disk filename, or empty string.
 123 // original wad extension is used as a hint for the first try.
 124 // also, this automatically performs `findFileCI()`.
 125 function findDiskWad (fname: AnsiString): AnsiString;
 126 // slashes must be normalized!
 127 function isWadNamesEqu (wna, wnb: AnsiString): Boolean;
 128
 129 // they throws
 130 function openDiskFileRO (pathname: AnsiString): TStream;
 131 function createDiskFile (pathname: AnsiString): TStream;
 132 // create file if necessary, but don't truncate the existing one
 133 function openDiskFileRW (pathname: AnsiString): TStream;
 134
 135 // little endian
 136 procedure writeSign (st: TStream; const sign: AnsiString);
 137 function checkSign (st: TStream; const sign: AnsiString): Boolean;
 138
 139 procedure writeBool (st: TStream; b: Boolean);
 140 function readBool (st: TStream): Boolean;
 141
 142 procedure writeStr (st: TStream; const str: AnsiString; maxlen: LongWord=65535);
 143 function readStr (st: TStream; maxlen: LongWord=65535): AnsiString;
 144
 145 procedure writeInt (st: TStream; v: Byte); overload;
 146 procedure writeInt (st: TStream; v: ShortInt); overload;
 147 procedure writeInt (st: TStream; v: Word); overload;
 148 procedure writeInt (st: TStream; v: SmallInt); overload;
 149 procedure writeInt (st: TStream; v: LongWord); overload;
 150 procedure writeInt (st: TStream; v: LongInt); overload;
 151 procedure writeInt (st: TStream; v: Int64); overload;
 152 procedure writeInt (st: TStream; v: UInt64); overload;
 153
 154 function readByte (st: TStream): Byte;
 155 function readShortInt (st: TStream): ShortInt;
 156 function readWord (st: TStream): Word;
 157 function readSmallInt (st: TStream): SmallInt;
 158 function readLongWord (st: TStream): LongWord;
 159 function readLongInt (st: TStream): LongInt;
 160 function readInt64 (st: TStream): Int64;
 161 function readUInt64 (st: TStream): UInt64;
 162
 163 // big endian
 164 procedure writeIntBE (st: TStream; v: Byte); overload;
 165 procedure writeIntBE (st: TStream; v: ShortInt); overload;
 166 procedure writeIntBE (st: TStream; v: Word); overload;
 167 procedure writeIntBE (st: TStream; v: SmallInt); overload;
 168 procedure writeIntBE (st: TStream; v: LongWord); overload;
 169 procedure writeIntBE (st: TStream; v: LongInt); overload;
 170 procedure writeIntBE (st: TStream; v: Int64); overload;
 171 procedure writeIntBE (st: TStream; v: UInt64); overload;
 172
 173 function readByteBE (st: TStream): Byte;
 174 function readShortIntBE (st: TStream): ShortInt;
 175 function readWordBE (st: TStream): Word;
 176 function readSmallIntBE (st: TStream): SmallInt;
 177 function readLongWordBE (st: TStream): LongWord;
 178 function readLongIntBE (st: TStream): LongInt;
 179 function readInt64BE (st: TStream): Int64;
 180 function readUInt64BE (st: TStream): UInt64;
 181
 182
 183 function nmin (a, b: Byte): Byte; inline; overload;
 184 function nmin (a, b: ShortInt): ShortInt; inline; overload;
 185 function nmin (a, b: Word): Word; inline; overload;
 186 function nmin (a, b: SmallInt): SmallInt; inline; overload;
 187 function nmin (a, b: LongWord): LongWord; inline; overload;
 188 function nmin (a, b: LongInt): LongInt; inline; overload;
 189 function nmin (a, b: Int64): Int64; inline; overload;
 190 function nmin (a, b: UInt64): UInt64; inline; overload;
 191 function nmin (a, b: Single): Single; inline; overload;
 192 function nmin (a, b: Double): Double; inline; overload;
 193 {$IF DEFINED(CPU386) OR DEFINED(CPUAMD64)}
 194 function nmin (a, b: Extended): Extended; inline; overload;
 195 {$ENDIF}
 196
 197 function nmax (a, b: Byte): Byte; inline; overload;
 198 function nmax (a, b: ShortInt): ShortInt; inline; overload;
 199 function nmax (a, b: Word): Word; inline; overload;
 200 function nmax (a, b: SmallInt): SmallInt; inline; overload;
 201 function nmax (a, b: LongWord): LongWord; inline; overload;
 202 function nmax (a, b: LongInt): LongInt; inline; overload;
 203 function nmax (a, b: Int64): Int64; inline; overload;
 204 function nmax (a, b: UInt64): UInt64; inline; overload;
 205 function nmax (a, b: Single): Single; inline; overload;
 206 function nmax (a, b: Double): Double; inline; overload;
 207 {$IF DEFINED(CPU386) OR DEFINED(CPUAMD64)}
 208 function nmax (a, b: Extended): Extended; inline; overload;
 209 {$ENDIF}
 210 function nclamp (v, a, b: Byte): Byte; inline; overload;
 211 function nclamp (v, a, b: ShortInt): ShortInt; inline; overload;
 212 function nclamp (v, a, b: Word): Word; inline; overload;
 213 function nclamp (v, a, b: SmallInt): SmallInt; inline; overload;
 214 function nclamp (v, a, b: LongWord): LongWord; inline; overload;
 215 function nclamp (v, a, b: LongInt): LongInt; inline; overload;
 216 function nclamp (v, a, b: Int64): Int64; inline; overload;
 217 function nclamp (v, a, b: UInt64): UInt64; inline; overload;
 218 function nclamp (v, a, b: Single): Single; inline; overload;
 219 function nclamp (v, a, b: Double): Double; inline; overload;
 220 {$IF DEFINED(CPU386) OR DEFINED(CPUAMD64)}
 221 function nclamp (v, a, b: Extended): Extended; inline; overload;
 222 {$ENDIF}
 223
 224 type
 225   TFormatStrFCallback = procedure (constref buf; len: SizeUInt);
 226
 227 // returns formatted string if `writerCB` is `nil`, empty string otherwise
 228 function formatstrf (const fmt: AnsiString; const args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
 229
 230 function wchar2win (wc: WideChar): AnsiChar; inline;
 231 function utf2win (const s: AnsiString): AnsiString;
 232 function win2utf (const s: AnsiString): AnsiString;
 233 function digitInBase (ch: AnsiChar; base: Integer): Integer;
 234
 235 // returns string in single or double quotes
 236 // single quotes supports only pascal-style '' for single quote char
 237 // double quotes supports c-style escapes
 238 // function will select quote mode automatically
 239 function quoteStr (const s: AnsiString): AnsiString;
 240
 241
 242 type
 243   generic TSimpleList<ItemT> = class
 244   private
 245     //type PItemT = ^ItemT;
 246     type TItemArr = array of ItemT;
 247
 248   public
 249     type
 250       TEnumerator = record
 251       private
 252         mItems: TItemArr;
 253         mCount: Integer;
 254         mCurrent: Integer;
 255       public
 256         constructor Create (const aitems: TItemArr; acount: Integer);
 257         function MoveNext: Boolean;
 258         function getCurrent (): ItemT;
 259         property Current: ItemT read getCurrent;
 260       end;
 261
 262   private
 263     mItems: TItemArr;
 264     mCount: Integer; // can be less than `mItems` size
 265
 266   private
 267     function getAt (idx: Integer): ItemT; inline;
 268     procedure setAt (idx: Integer; const it: ItemT); inline;
 269
 270     function getCapacity (): Integer; inline;
 271     procedure setCapacity (v: Integer); inline;
 272
 273   public
 274     constructor Create (acapacity: Integer=-1);
 275     destructor Destroy (); override;
 276
 277     //WARNING! don't change list contents in `for ... in`!
 278     function GetEnumerator (): TEnumerator;
 279
 280     procedure reset (); inline; // won't resize `mItems`
 281     procedure clear (); inline;
 282
 283     procedure append (constref it: ItemT); inline;
 284     procedure delete (idx: Integer); inline;
 285     function remove (idx: Integer): ItemT; inline;
 286
 287   public
 288     property count: Integer read mCount;
 289     property capacity: Integer read getCapacity write setCapacity;
 290     property at[idx: Integer]: ItemT read getAt write setAt; default;
 291   end;
 292
 293
 294 procedure FillMemory (Dest: Pointer; Len: LongWord; Ch: Byte); inline;
 295 procedure CopyMemory (Dest: Pointer; Src: Pointer; Len: LongWord); inline;
 296 procedure ZeroMemory (Dest: Pointer; Len: LongWord); inline;
 297
 298
 299 type
 300   TDiskFileInfo = record
 301     diskName: AnsiString;
 302     size: LongInt;
 303     age: LongInt;
 304     // not changed by info getter; used in other parts of the code
 305     userName: AnsiString;
 306     tag: Integer;
 307     hash: TMD5Digest;
 308     udata: Pointer;
 309   end;
 310
 311 function GetDiskFileInfo (fname: AnsiString; var info: TDiskFileInfo): Boolean;
 312
 313
 314 implementation
 315
 316 uses
 317   xstreams;
 318
 319 // ////////////////////////////////////////////////////////////////////////// //
 320 procedure CopyMemory (Dest: Pointer; Src: Pointer; Len: LongWord); inline;
 321 begin
 322   Move(Src^, Dest^, Len);
 323 end;
 324
 325 procedure FillMemory (Dest: Pointer; Len: LongWord; Ch: Byte); inline;
 326 begin
 327   FillChar(Dest^, Len, Ch);
 328 end;
 329
 330 procedure ZeroMemory (Dest: Pointer; Len: LongWord); inline;
 331 begin
 332   FillChar(Dest^, Len, 0);
 333 end;
 334
 335
 336 // ////////////////////////////////////////////////////////////////////////// //
 337 constructor TSimpleList.TEnumerator.Create (const aitems: TItemArr; acount: Integer);
 338 begin
 339   mItems := aitems;
 340   mCurrent := -1;
 341   mCount := acount;
 342 end;
 343
 344 function TSimpleList.TEnumerator.MoveNext: Boolean;
 345 begin
 346   Inc(mCurrent);
 347   result := (mCurrent < mCount);
 348 end;
 349
 350 function TSimpleList.TEnumerator.getCurrent (): ItemT;
 351 begin
 352   result := mItems[mCurrent];
 353 end;
 354
 355
 356 // ////////////////////////////////////////////////////////////////////////// //
 357 constructor TSimpleList.Create (acapacity: Integer=-1);
 358 begin
 359   mItems := nil;
 360   if (acapacity > 0) then SetLength(mItems, acapacity);
 361   mCount := 0;
 362 end;
 363
 364
 365 destructor TSimpleList.Destroy ();
 366 begin
 367   mItems := nil;
 368   inherited;
 369 end;
 370
 371
 372 function TSimpleList.getCapacity (): Integer; inline;
 373 begin
 374   result := Length(mItems);
 375 end;
 376
 377
 378 procedure TSimpleList.setCapacity (v: Integer); inline;
 379 begin
 380   if (v < mCount) then v := mCount;
 381   if (v <> Length(mItems)) then SetLength(mItems, v);
 382 end;
 383
 384
 385 function TSimpleList.GetEnumerator (): TEnumerator;
 386 begin
 387   if (Length(mItems) > 0) then result := TEnumerator.Create(mItems, mCount)
 388   else result := TEnumerator.Create(nil, -1);
 389 end;
 390
 391
 392 procedure TSimpleList.reset (); inline;
 393 begin
 394   mCount := 0;
 395 end;
 396
 397
 398 procedure TSimpleList.clear (); inline;
 399 begin
 400   mItems := nil;
 401   mCount := 0;
 402 end;
 403
 404
 405 function TSimpleList.getAt (idx: Integer): ItemT; inline;
 406 begin
 407   if (idx >= 0) and (idx < mCount) then result := mItems[idx] else result := Default(ItemT);
 408 end;
 409
 410
 411 procedure TSimpleList.setAt (idx: Integer; const it: ItemT); inline;
 412 begin
 413   if (idx >= 0) and (idx < mCount) then mItems[idx] := it;
 414 end;
 415
 416
 417 procedure TSimpleList.append (constref it: ItemT); inline;
 418 var
 419   newsz: Integer;
 420 begin
 421   if (mCount >= Length(mItems)) then
 422   begin
 423     newsz := mCount+(mCount div 3)+128;
 424     SetLength(mItems, newsz);
 425   end;
 426   mItems[mCount] := it;
 427   Inc(mCount);
 428 end;
 429
 430
 431 procedure TSimpleList.delete (idx: Integer); inline;
 432 var
 433   f: Integer;
 434 begin
 435   if (idx >= 0) and (idx < mCount) then
 436   begin
 437     for f := idx+1 to mCount-1 do mItems[f-1] := mItems[f];
 438   end;
 439 end;
 440
 441
 442 function TSimpleList.remove (idx: Integer): ItemT; inline;
 443 var
 444   f: Integer;
 445 begin
 446   if (idx >= 0) and (idx < mCount) then
 447   begin
 448     result := mItems[idx];
 449     for f := idx+1 to mCount-1 do mItems[f-1] := mItems[f];
 450   end
 451   else
 452   begin
 453     result := Default(ItemT);
 454   end;
 455 end;
 456
 457
 458 // ////////////////////////////////////////////////////////////////////////// //
 459 var
 460   wc2shitmap: array[0..65535] of AnsiChar;
 461   wc2shitmapInited: Boolean = false;
 462
 463
 464 // ////////////////////////////////////////////////////////////////////////// //
 465 const
 466   cp1251: array[0..127] of Word = (
 467     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
 468     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
 469     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
 470     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
 471     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
 472     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
 473     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
 474     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
 475   );
 476
 477
 478 procedure initShitMap ();
 479 var
 480   f: Integer;
 481 begin
 482   for f := 0 to High(wc2shitmap) do wc2shitmap[f] := '?';
 483   for f := 0 to 127 do wc2shitmap[f] := AnsiChar(f);
 484   for f := 0 to 127 do wc2shitmap[cp1251[f]] := AnsiChar(f+128);
 485   wc2shitmapInited := true;
 486 end;
 487
 488
 489 // ////////////////////////////////////////////////////////////////////////// //
 490 // fast state-machine based UTF-8 decoder; using 8 bytes of memory
 491 // code points from invalid range will never be valid, this is the property of the state machine
 492 const
 493   // see http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
 494   utf8dfa: array[0..$16c-1] of Byte = (
 495     // maps bytes to character classes
 496     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 00-0f
 497     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 10-1f
 498     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 20-2f
 499     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 30-3f
 500     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 40-4f
 501     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 50-5f
 502     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 60-6f
 503     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 70-7f
 504     $01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01, // 80-8f
 505     $09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09, // 90-9f
 506     $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07, // a0-af
 507     $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07, // b0-bf
 508     $08,$08,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02, // c0-cf
 509     $02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02, // d0-df
 510     $0a,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$04,$03,$03, // e0-ef
 511     $0b,$06,$06,$06,$05,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08, // f0-ff
 512     // maps a combination of a state of the automaton and a character class to a state
 513     $00,$0c,$18,$24,$3c,$60,$54,$0c,$0c,$0c,$30,$48,$0c,$0c,$0c,$0c, // 100-10f
 514     $0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$00,$0c,$0c,$0c,$0c,$0c,$00, // 110-11f
 515     $0c,$00,$0c,$0c,$0c,$18,$0c,$0c,$0c,$0c,$0c,$18,$0c,$18,$0c,$0c, // 120-12f
 516     $0c,$0c,$0c,$0c,$0c,$0c,$0c,$18,$0c,$0c,$0c,$0c,$0c,$18,$0c,$0c, // 130-13f
 517     $0c,$0c,$0c,$0c,$0c,$18,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$24, // 140-14f
 518     $0c,$24,$0c,$0c,$0c,$24,$0c,$0c,$0c,$0c,$0c,$24,$0c,$24,$0c,$0c, // 150-15f
 519     $0c,$24,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c);
 520
 521
 522 // ////////////////////////////////////////////////////////////////////////// //
 523 constructor TUtf8DecoderFast.Create (v: Boolean{fuck you, fpc}); begin state := Accept; codepoint := 0; end;
 524
 525 procedure TUtf8DecoderFast.reset (); inline; begin state := Accept; codepoint := 0; end;
 526
 527 function TUtf8DecoderFast.complete (): Boolean; inline; begin result := (state = Accept); end;
 528 function TUtf8DecoderFast.invalid (): Boolean; inline; begin result := (state = Reject); end;
 529 function TUtf8DecoderFast.completeOrInvalid (): Boolean; inline; begin result := (state = Accept) or (state = Reject); end;
 530
 531 function TUtf8DecoderFast.decode (c: AnsiChar): Boolean; inline; overload; begin result := decode(Byte(c)); end;
 532
 533 function TUtf8DecoderFast.decode (b: Byte): Boolean; inline; overload;
 534 var
 535   tp: LongWord;
 536 begin
 537   if (state = Reject) then begin state := Accept; codepoint := 0; end;
 538   tp := utf8dfa[b];
 539   if (state <> Accept) then codepoint := (b and $3f) or (codepoint shl 6) else codepoint := ($ff shr tp) and b;
 540   state := utf8dfa[256+state+tp];
 541   if (state = Reject) then begin codepoint := Replacement; state := Accept; end;
 542   result := (state = Accept);
 543 end;
 544
 545
 546 // ////////////////////////////////////////////////////////////////////////// //
 547 function wchar2win (wc: WideChar): AnsiChar; inline;
 548 begin
 549   if not wc2shitmapInited then initShitMap();
 550   if (LongWord(wc) > 65535) then result := '?' else result := wc2shitmap[LongWord(wc)];
 551 end;
 552
 553
 554 // ////////////////////////////////////////////////////////////////////////// //
 555 function utf2win (const s: AnsiString): AnsiString;
 556 var
 557   f, c: Integer;
 558   ud: TUtf8DecoderFast;
 559 begin
 560   for f := 1 to Length(s) do
 561   begin
 562     if (Byte(s[f]) > 127) then
 563     begin
 564       ud := TUtf8DecoderFast.Create(true);
 565       result := '';
 566       for c := 1 to Length(s) do
 567       begin
 568         if ud.decode(s[c]) then result += wchar2win(WideChar(ud.codepoint));
 569       end;
 570       exit;
 571     end;
 572   end;
 573   result := s;
 574 end;
 575
 576
 577 function win2utf (const s: AnsiString): AnsiString;
 578 var
 579   f, c: Integer;
 580
 581   function utf8Encode (code: Integer): AnsiString;
 582   begin
 583     if (code < 0) or (code > $10FFFF) then begin result := '?'; exit; end;
 584     if (code <= $7f) then
 585     begin
 586       result := AnsiChar(code and $ff);
 587     end
 588     else if (code <= $7FF) then
 589     begin
 590       result := AnsiChar($C0 or (code shr 6));
 591       result += AnsiChar($80 or (code and $3F));
 592     end
 593     else if (code <= $FFFF) then
 594     begin
 595       result := AnsiChar($E0 or (code shr 12));
 596       result += AnsiChar($80 or ((code shr 6) and $3F));
 597       result += AnsiChar($80 or (code and $3F));
 598     end
 599     else if (code <= $10FFFF) then
 600     begin
 601       result := AnsiChar($F0 or (code shr 18));
 602       result += AnsiChar($80 or ((code shr 12) and $3F));
 603       result += AnsiChar($80 or ((code shr 6) and $3F));
 604       result += AnsiChar($80 or (code and $3F));
 605     end
 606     else
 607     begin
 608       result := '?';
 609     end;
 610   end;
 611
 612 begin
 613   for f := 1 to Length(s) do
 614   begin
 615     if (Byte(s[f]) > 127) then
 616     begin
 617       result := '';
 618       for c := 1 to Length(s) do
 619       begin
 620         if (Byte(s[c]) < 128) then
 621         begin
 622           result += s[c];
 623         end
 624         else
 625         begin
 626           result += utf8Encode(cp1251[Byte(s[c])-128])
 627         end;
 628       end;
 629       exit;
 630     end;
 631   end;
 632   result := s;
 633 end;
 634
 635
 636 // ////////////////////////////////////////////////////////////////////////// //
 637 function digitInBase (ch: AnsiChar; base: Integer): Integer;
 638 begin
 639   result := -1;
 640   if (base < 1) or (base > 36) then exit;
 641   if (ch < '0') then exit;
 642   if (base <= 10) then
 643   begin
 644     if (Integer(ch) >= 48+base) then exit;
 645     result := Integer(ch)-48;
 646   end
 647   else
 648   begin
 649     if (ch >= '0') and (ch <= '9') then begin result := Integer(ch)-48; exit; end;
 650     if (ch >= 'a') and (ch <= 'z') then Dec(ch, 32); // poor man's tolower()
 651     if (ch < 'A') or (Integer(ch) >= 65+(base-10)) then exit;
 652     result := Integer(ch)-65+10;
 653   end;
 654 end;
 655
 656
 657 // ////////////////////////////////////////////////////////////////////////// //
 658 function quoteStr (const s: AnsiString): AnsiString;
 659
 660   function squote (const s: AnsiString): AnsiString;
 661   var
 662     f: Integer;
 663   begin
 664     result := '''';
 665     for f := 1 to Length(s) do
 666     begin
 667       if (s[f] = '''') then result += '''';
 668       result += s[f];
 669     end;
 670     result += '''';
 671   end;
 672
 673   function dquote (const s: AnsiString): AnsiString;
 674   var
 675     f: Integer;
 676     ch: AnsiChar;
 677   begin
 678     result := '"';
 679     for f := 1 to Length(s) do
 680     begin
 681       ch := s[f];
 682            if (ch = #0) then result += '\z'
 683       else if (ch = #9) then result += '\t'
 684       else if (ch = #10) then result += '\n'
 685       else if (ch = #13) then result += '\r'
 686       else if (ch = #27) then result += '\e'
 687       else if (ch < ' ') or (ch = #127) then
 688       begin
 689         result += '\x';
 690         result += LowerCase(IntToHex(Integer(ch), 2));
 691       end
 692       else if (ch = '"') or (ch = '\') then
 693       begin
 694         result += '\';
 695         result += ch;
 696       end
 697       else
 698       begin
 699         result += ch;
 700       end;
 701     end;
 702     result += '"';
 703   end;
 704
 705 var
 706   needSingle: Boolean = false;
 707   f: Integer;
 708 begin
 709   for f := 1 to Length(s) do
 710   begin
 711     if (s[f] = '''') then begin needSingle := true; continue; end;
 712     if (s[f] < ' ') or (s[f] = #127) then begin result := dquote(s); exit; end;
 713   end;
 714   if needSingle then result := squote(s) else result := ''''+s+'''';
 715 end;
 716
 717
 718 // ////////////////////////////////////////////////////////////////////////// //
 719 function getFilenameExt (const fn: AnsiString): AnsiString;
 720 var
 721   pos: Integer;
 722   ch: AnsiChar;
 723 begin
 724   pos := Length(fn);
 725   while (pos > 0) do
 726   begin
 727     ch := fn[pos];
 728     if (ch = '.') then
 729     begin
 730       if (pos = Length(fn)) then result := '' else result := Copy(fn, pos, Length(fn)-pos+1);
 731       exit;
 732     end;
 733     if (ch = '/') or (ch = '\') then break;
 734     Dec(pos);
 735   end;
 736   result := ''; // no extension
 737 end;
 738
 739
 740 function setFilenameExt (const fn, ext: AnsiString): AnsiString;
 741 var
 742   pos: Integer;
 743   ch: AnsiChar;
 744 begin
 745   result := fn;
 746   if (Length(ext) = 0) or (ext = '.') then exit;
 747   pos := Length(fn);
 748   while (pos > 0) do
 749   begin
 750     ch := fn[pos];
 751     if (ch = '.') then exit;
 752     if (ch = '/') or (ch = '\') then break;
 753     Dec(pos);
 754   end;
 755   if (ext[1] <> '.') then result += '.';
 756   result += ext;
 757 end;
 758
 759
 760 function forceFilenameExt (const fn, ext: AnsiString): AnsiString;
 761 var
 762   pos: Integer;
 763   ch: AnsiChar;
 764 begin
 765   result := fn;
 766   pos := Length(fn);
 767   while (pos > 0) do
 768   begin
 769     ch := fn[pos];
 770     if (ch = '.') then
 771     begin
 772       if (Length(ext) = 0) or (ext = '.') then
 773       begin
 774         result := Copy(fn, 1, pos-1);
 775       end
 776       else
 777       begin
 778         if (ext[1] = '.') then result := Copy(fn, 1, pos-1) else result := Copy(fn, 1, pos);
 779         result += ext;
 780         exit;
 781       end;
 782     end;
 783     if (ch = '/') or (ch = '\') then break;
 784     Dec(pos);
 785   end;
 786   if (Length(ext) > 0) then
 787   begin
 788     if (ext[1] <> '.') then result += '.';
 789     result += ext;
 790   end;
 791 end;
 792
 793
 794 // strips out name from `fn`, leaving trailing slash
 795 function getFilenamePath (const fn: AnsiString): AnsiString;
 796 var
 797   pos: Integer;
 798   ch: AnsiChar;
 799 begin
 800   if (Length(fn) = 0) then begin result := './'; exit; end;
 801   if (fn[Length(fn)] = '/') or (fn[Length(fn)] = '\') then begin result := fn; exit; end;
 802   pos := Length(fn);
 803   while (pos > 0) do
 804   begin
 805     ch := fn[pos];
 806     if (ch = '/') or (ch = '\') then begin result := Copy(fn, 1, pos); exit; end;
 807     Dec(pos);
 808   end;
 809   result := './'; // no path -> current dir
 810 end;
 811
 812
 813 // ends with '/' or '\'?
 814 function isFilenamePath (const fn: AnsiString): Boolean;
 815 begin
 816   if (Length(fn) = 0) then
 817   begin
 818     result := false;
 819   end
 820   else
 821   begin
 822     result := (fn[Length(fn)] = '/') or (fn[Length(fn)] = '\');
 823   end;
 824 end;
 825
 826
 827 // strips extra trailing slashes in `path, and extra leading slashes in `fn`
 828 // will add slash to `path`, even if `fn` is empty!
 829 function filenameConcat (const path, fn: AnsiString): AnsiString;
 830 var
 831   pos: Integer;
 832 begin
 833   pos := 1;
 834   while (pos <= Length(fn)) and ((fn[pos] = '/') or (fn[pos] = '\')) do Inc(pos);
 835   result := path;
 836   if (Length(result) > 0) and ((result[Length(result)] <> '/') and (result[Length(result)] <> '\')) then result += '/';
 837   if (pos <= Length(fn)) then
 838   begin
 839     result += Copy(fn, pos, Length(fn)-pos+1);
 840     //FIXME: make this faster!
 841     while (Length(result) > 0) and ((result[Length(result)] = '/') or (result[Length(result)] = '\')) do
 842     begin
 843       Delete(result, Length(result), 1);
 844     end;
 845     if (fn[Length(fn)] = '/') or (fn[Length(fn)] = '\') then result += '/';
 846   end;
 847 end;
 848
 849
 850 function hasWadExtension (const fn: AnsiString): Boolean;
 851 var
 852   ext, newExt: AnsiString;
 853 begin
 854   ext := getFilenameExt(fn);
 855   result := true;
 856   for newExt in wadExtensions do if (StrEquCI1251(ext, newExt)) then exit;
 857   result := false;
 858   //result := StrEquCI1251(ext, '.wad') or StrEquCI1251(ext, '.pk3') or StrEquCI1251(ext, '.zip') or StrEquCI1251(ext, '.dfz');
 859 end;
 860
 861
 862 function addWadExtension (const fn: AnsiString): AnsiString;
 863 begin
 864   result := fn;
 865   if not hasWadExtension(result) then result := result+'.wad';
 866 end;
 867
 868
 869 function isWadData (data: Pointer; len: LongWord): Boolean;
 870   var p: PChar;
 871 begin
 872   p := PChar(data);
 873   Result :=
 874     (* ZIP *)
 875     ((len > 3) and (p[0] = 'P') and (p[1] = 'K') and (p[2] = #03) and (p[3] = #04)) or
 876     ((len > 3) and (p[0] = 'P') and (p[1] = 'K') and (p[2] = #05) and (p[3] = #06)) or
 877     (* PACK *)
 878     ((len > 3) and (p[0] = 'P') and (p[1] = 'A') and (p[2] = 'C') and (p[3] = 'K')) or
 879     ((len > 3) and (p[0] = 'S') and (p[1] = 'P') and (p[2] = 'A') and (p[3] = 'K')) or
 880     (* DFWAD *)
 881     ((len > 5) and (p[0] = 'D') and (p[1] = 'F') and (p[2] = 'W') and (p[3] = 'A') and (p[4] = 'D') and (p[5] = #01))
 882 end;
 883
 884
 885 function isWadPath (const fn: AnsiString): Boolean;
 886 var
 887   pos: Integer;
 888   s: AnsiString;
 889 begin
 890   result := false;
 891   pos := 1;
 892   while (pos <= Length(fn)) do
 893   begin
 894     if (fn[pos] = ':') then
 895     begin
 896       if (Length(fn)-pos < 1) then break;
 897       if (pos-4 > 1) and (fn[pos-4] = '.') and ((fn[pos+1] = '\') or (fn[pos+1] = '/')) then
 898       begin
 899         s := Copy(fn, pos-4, 4);
 900         if StrEquCI1251(s, '.wad') or StrEquCI1251(s, '.pk3') or StrEquCI1251(s, '.zip') or StrEquCI1251(s, '.dfz') then
 901         begin
 902           result := true;
 903           exit;
 904         end;
 905       end;
 906     end;
 907     Inc(pos);
 908   end;
 909 end;
 910
 911
 912 function int64ToStrComma (i: Int64): AnsiString;
 913 var
 914   f: Integer;
 915 begin
 916   Str(i, result);
 917   f := Length(result)+1;
 918   while f > 4 do
 919   begin
 920     Dec(f, 3); Insert(',', result, f);
 921   end;
 922 end;
 923
 924
 925 function upcase1251 (ch: AnsiChar): AnsiChar; inline;
 926 begin
 927   if ch < #128 then
 928   begin
 929     if (ch >= 'a') and (ch <= 'z') then Dec(ch, 32);
 930   end
 931   else
 932   begin
 933     if (ch >= #224) and (ch <= #255) then
 934     begin
 935       Dec(ch, 32);
 936     end
 937     else
 938     begin
 939       case ch of
 940         #184, #186, #191: Dec(ch, 16);
 941         #162, #179: Dec(ch);
 942       end;
 943     end;
 944   end;
 945   result := ch;
 946 end;
 947
 948
 949 function locase1251 (ch: AnsiChar): AnsiChar; inline;
 950 begin
 951   if ch < #128 then
 952   begin
 953     if (ch >= 'A') and (ch <= 'Z') then Inc(ch, 32);
 954   end
 955   else
 956   begin
 957     if (ch >= #192) and (ch <= #223) then
 958     begin
 959       Inc(ch, 32);
 960     end
 961     else
 962     begin
 963       case ch of
 964         #168, #170, #175: Inc(ch, 16);
 965         #161, #178: Inc(ch);
 966       end;
 967     end;
 968   end;
 969   result := ch;
 970 end;
 971
 972 function IsValid1251 (ch: Word): Boolean;
 973 begin
 974   result := (ch = Ord('?')) or (wc2shitmap[ch] <> '?')
 975 end;
 976
 977 function IsPrintable1251 (ch: AnsiChar): Boolean;
 978 begin
 979   result := (ch >= #32) and (ch <> #127)
 980 end;
 981
 982
 983 function strEquCI1251 (const s0, s1: AnsiString): Boolean;
 984 var
 985   i: Integer;
 986 begin
 987   result := false;
 988   if length(s0) <> length(s1) then exit;
 989   for i := 1 to length(s0) do if UpCase1251(s0[i]) <> UpCase1251(s1[i]) then exit;
 990   result := true;
 991 end;
 992
 993
 994 function toLowerCase1251 (const s: AnsiString): AnsiString;
 995 var
 996   f: Integer;
 997   ch: AnsiChar;
 998 begin
 999   for ch in s do
1000   begin
1001     if (ch <> LoCase1251(ch)) then
1002     begin
1003       result := '';
1004       SetLength(result, Length(s));
1005       for f := 1 to Length(s) do result[f] := LoCase1251(s[f]);
1006       exit;
1007     end;
1008   end;
1009   // nothing to do
1010   result := s;
1011 end;
1012
1013
1014 // ////////////////////////////////////////////////////////////////////////// //
1015 // utils
1016 // `ch`: utf8 start
1017 // -1: invalid utf8
1018 function utf8CodeLen (ch: Word): Integer;
1019 begin
1020   if ch < $80 then begin result := 1; exit; end;
1021   if (ch and $FE) = $FC then begin result := 6; exit; end;
1022   if (ch and $FC) = $F8 then begin result := 5; exit; end;
1023   if (ch and $F8) = $F0 then begin result := 4; exit; end;
1024   if (ch and $F0) = $E0 then begin result := 3; exit; end;
1025   if (ch and $E0) = $C0 then begin result := 2; exit; end;
1026   result := -1; // invalid
1027 end;
1028
1029
1030 function utf8Valid (const s: AnsiString): Boolean;
1031 var
1032   pos, len: Integer;
1033 begin
1034   result := false;
1035   pos := 1;
1036   while pos <= length(s) do
1037   begin
1038     len := utf8CodeLen(Byte(s[pos]));
1039     if len < 1 then exit; // invalid sequence start
1040     if pos+len-1 > length(s) then exit; // out of chars in string
1041     Dec(len);
1042     Inc(pos);
1043     // check other sequence bytes
1044     while len > 0 do
1045     begin
1046       if (Byte(s[pos]) and $C0) <> $80 then exit;
1047       Dec(len);
1048       Inc(pos);
1049     end;
1050   end;
1051   result := true;
1052 end;
1053
1054
1055 // ////////////////////////////////////////////////////////////////////////// //
1056 const
1057   uni2wint: array [128..255] of Word = (
1058     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
1059     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
1060     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
1061     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
1062     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
1063     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
1064     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
1065     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
1066   );
1067
1068
1069 function decodeUtf8Char (s: AnsiString; var pos: Integer): AnsiChar;
1070 var
1071   b, c: Integer;
1072 begin
1073   (* The following encodings are valid, except for the 5 and 6 byte
1074    * combinations:
1075    *  0xxxxxxx
1076    *  110xxxxx 10xxxxxx
1077    *  1110xxxx 10xxxxxx 10xxxxxx
1078    *  11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
1079    *  111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
1080    *  1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
1081    *)
1082   result := '?';
1083   if pos > length(s) then exit;
1084
1085   b := Byte(s[pos]);
1086   Inc(pos);
1087   if b < $80 then begin result := AnsiChar(b); exit; end;
1088
1089   // mask out unused bits
1090        if (b and $FE) = $FC then b := b and $01
1091   else if (b and $FC) = $F8 then b := b and $03
1092   else if (b and $F8) = $F0 then b := b and $07
1093   else if (b and $F0) = $E0 then b := b and $0F
1094   else if (b and $E0) = $C0 then b := b and $1F
1095   else exit; // invalid utf8
1096
1097   // now continue
1098   while pos <= length(s) do
1099   begin
1100     c := Byte(s[pos]);
1101     if (c and $C0) <> $80 then break; // no more
1102     b := b shl 6;
1103     b := b or (c and $3F);
1104     Inc(pos);
1105   end;
1106
1107   // done, try 1251
1108   for c := 128 to 255 do if uni2wint[c] = b then begin result := AnsiChar(c and $FF); exit; end;
1109   // alas
1110 end;
1111
1112
1113 function utf8to1251 (s: AnsiString): AnsiString;
1114 var
1115   pos: Integer;
1116 begin
1117   if not utf8Valid(s) then begin result := s; exit; end;
1118   pos := 1;
1119   while pos <= length(s) do
1120   begin
1121     if Byte(s[pos]) >= $80 then break;
1122     Inc(pos);
1123   end;
1124   if pos > length(s) then begin result := s; exit; end; // nothing to do here
1125   result := '';
1126   pos := 1;
1127   while pos <= length(s) do result := result+decodeUtf8Char(s, pos);
1128 end;
1129
1130
1131 // ////////////////////////////////////////////////////////////////////////// //
1132 // findFileCI eats case-insensitive path, traverses it and rewrites it to a
1133 // case-sensetive. result value means success.
1134 // if file/dir not founded than pathname is in undefined state!
1135 function findFileCI (var pathname: AnsiString; lastIsDir: Boolean=false): Boolean;
1136 var
1137   sr: TSearchRec;
1138   npt: AnsiString;
1139   newname: AnsiString = '';
1140   curname: AnsiString;
1141   wantdir: Boolean;
1142   attr: LongInt;
1143   foundher: Boolean;
1144 begin
1145   npt := pathname;
1146   result := (length(npt) > 0);
1147   if (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) then newname := '/';
1148   while length(npt) > 0 do
1149   begin
1150     // remove trailing slashes
1151     while (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) do Delete(npt, 1, 1);
1152     if length(npt) = 0 then break;
1153     // extract name
1154     curname := '';
1155     while (length(npt) > 0) and (npt[1] <> '/') and (npt[1] <> '\') do
1156     begin
1157       curname := curname+npt[1];
1158       Delete(npt, 1, 1);
1159     end;
1160     // remove trailing slashes again
1161     while (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) do Delete(npt, 1, 1);
1162     wantdir := lastIsDir or (length(npt) > 0); // do we want directory here?
1163     //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
1164     // try the easiest case first
1165     attr := FileGetAttr(newname+curname);
1166     if attr <> -1 then
1167     begin
1168       if wantdir = ((attr and faDirectory) <> 0) then
1169       begin
1170         // i found her!
1171         newname := newname+curname;
1172         if wantdir then newname := newname+'/';
1173         continue;
1174       end;
1175     end;
1176     //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
1177     // alas, either not found, or invalid attributes
1178     foundher := false;
1179     try
1180       if FindFirst(newname+'*', faAnyFile, sr) = 0 then
1181       repeat
1182         if (wantdir = ((sr.attr and faDirectory) <> 0)) and StrEquCI1251(sr.name, curname) then
1183         begin
1184           // i found her!
1185           newname := newname+sr.name;
1186           if wantdir then newname := newname+'/';
1187           foundher := true;
1188           break;
1189         end;
1190       until FindNext(sr) <> 0;
1191     finally
1192       FindClose(sr);
1193     end;
1194     if not foundher then begin newname := ''; result := false; break; end;
1195   end;
1196   if result then pathname := newname;
1197 end;
1198
1199
1200 function isWadNamesEqu (wna, wnb: AnsiString): Boolean;
1201 var
1202   ext, newExt: AnsiString;
1203   found: Boolean;
1204 begin
1205   result := StrEquCI1251(wna, wnb);
1206   if result then exit;
1207   // check first ext
1208   ext := getFilenameExt(wna);
1209   found := false;
1210   for newExt in wadExtensions do if (StrEquCI1251(ext, newExt)) then begin found := true; break; end;
1211   if not found then exit;
1212   // check second ext
1213   ext := getFilenameExt(wnb);
1214   found := false;
1215   for newExt in wadExtensions do if (StrEquCI1251(ext, newExt)) then begin found := true; break; end;
1216   if not found then exit;
1217   wna := forceFilenameExt(wna, '');
1218   wnb := forceFilenameExt(wnb, '');
1219   result := StrEquCI1251(wna, wnb);
1220 end;
1221
1222 function findDiskWad (fname: AnsiString): AnsiString;
1223 var
1224   origExt: AnsiString = '';
1225   newExt: AnsiString = '';
1226 begin
1227   result := '';
1228   //writeln('findDiskWad00: fname=<', fname, '>');
1229   if (findFileCI(fname)) then begin result := fname; exit; end;
1230   origExt := getFilenameExt(fname);
1231   fname := forceFilenameExt(fname, '');
1232   //writeln(' findDiskWad01: fname=<', fname, '>; origExt=<', origExt, '>');
1233   for newExt in wadExtensions do
1234   begin
1235     //writeln(' findDiskWad02: fname=<', fname, '>; origExt=<', origExt, '>; newExt=<', newExt, '>');
1236     if (StrEquCI1251(newExt, origExt)) then
1237     begin
1238       //writeln('   SKIP');
1239       continue;
1240     end;
1241     result := fname+newExt;
1242     if (findFileCI(result)) then exit;
1243   end;
1244   result := '';
1245 end;
1246
1247
1248 function openDiskFileRO (pathname: AnsiString): TStream;
1249 begin
1250   if not findFileCI(pathname) then raise EFileNotFoundException.Create('can''t open file "'+pathname+'"');
1251   result := TFileStream.Create(pathname, fmOpenRead or {fmShareDenyWrite}fmShareDenyNone);
1252 end;
1253
1254 function createDiskFile (pathname: AnsiString): TStream;
1255 var
1256   path: AnsiString;
1257 begin
1258   path := ExtractFilePath(pathname);
1259   if length(path) > 0 then
1260   begin
1261     if not findFileCI(path, true) then raise Exception.Create('can''t create file "'+pathname+'"');
1262   end;
1263   result := TFileStream.Create(path+ExtractFileName(pathname), fmCreate);
1264 end;
1265
1266
1267 function openDiskFileRW (pathname: AnsiString): TStream;
1268 var
1269   path: AnsiString;
1270   oldname: AnsiString;
1271 begin
1272   //writeln('*** TRYING R/W FILE "', pathname, '"');
1273   path := ExtractFilePath(pathname);
1274   if length(path) > 0 then
1275   begin
1276     if not findFileCI(path, true) then raise Exception.Create('can''t create file "'+pathname+'"');
1277   end;
1278   oldname := pathname;
1279   if findFileCI(oldname) then
1280   begin
1281     //writeln('*** found old file "', oldname, '"');
1282     result := TFileStream.Create(oldname, fmOpenReadWrite or fmShareDenyWrite);
1283   end
1284   else
1285   begin
1286     result := TFileStream.Create(path+ExtractFileName(pathname), fmCreate);
1287   end;
1288 end;
1289
1290
1291 procedure writeIntegerLE (st: TStream; vp: Pointer; size: Integer);
1292 {$IFDEF ENDIAN_LITTLE}
1293 begin
1294   st.writeBuffer(vp^, size);
1295 end;
1296 {$ELSE}
1297 var
1298   p: PByte;
1299 begin
1300   p := PByte(vp)+size-1;
1301   while size > 0 do
1302   begin
1303     st.writeBuffer(p^, 1);
1304     Dec(size);
1305     Dec(p);
1306   end;
1307 end;
1308 {$ENDIF}
1309
1310 procedure writeIntegerBE (st: TStream; vp: Pointer; size: Integer);
1311 {$IFDEF ENDIAN_LITTLE}
1312 var
1313   p: PByte;
1314 begin
1315   p := PByte(vp)+size-1;
1316   while size > 0 do
1317   begin
1318     st.writeBuffer(p^, 1);
1319     Dec(size);
1320     Dec(p);
1321   end;
1322 end;
1323 {$ELSE}
1324 begin
1325   st.writeBuffer(vp^, size);
1326 end;
1327 {$ENDIF}
1328
1329 procedure writeSign (st: TStream; const sign: AnsiString);
1330 begin
1331   if (Length(sign) > 0) then st.WriteBuffer(sign[1], Length(sign));
1332 end;
1333
1334 function checkSign (st: TStream; const sign: AnsiString): Boolean;
1335 var
1336   buf: packed array[0..7] of AnsiChar;
1337   f: Integer;
1338 begin
1339   result := false;
1340   if (Length(sign) > 0) then
1341   begin
1342     if (Length(sign) <= 8) then
1343     begin
1344       st.ReadBuffer(buf[0], Length(sign));
1345       for f := 1 to Length(sign) do if (buf[f-1] <> sign[f]) then exit;
1346     end
1347     else
1348     begin
1349       for f := 1 to Length(sign) do
1350       begin
1351         st.ReadBuffer(buf[0], 1);
1352         if (buf[0] <> sign[f]) then exit;
1353       end;
1354     end;
1355   end;
1356   result := true;
1357 end;
1358
1359 procedure writeInt (st: TStream; v: Byte); overload; begin writeIntegerLE(st, @v, 1); end;
1360 procedure writeInt (st: TStream; v: ShortInt); overload; begin writeIntegerLE(st, @v, 1); end;
1361 procedure writeInt (st: TStream; v: Word); overload; begin writeIntegerLE(st, @v, 2); end;
1362 procedure writeInt (st: TStream; v: SmallInt); overload; begin writeIntegerLE(st, @v, 2); end;
1363 procedure writeInt (st: TStream; v: LongWord); overload; begin writeIntegerLE(st, @v, 4); end;
1364 procedure writeInt (st: TStream; v: LongInt); overload; begin writeIntegerLE(st, @v, 4); end;
1365 procedure writeInt (st: TStream; v: Int64); overload; begin writeIntegerLE(st, @v, 8); end;
1366 procedure writeInt (st: TStream; v: UInt64); overload; begin writeIntegerLE(st, @v, 8); end;
1367
1368 procedure writeIntBE (st: TStream; v: Byte); overload; begin writeIntegerBE(st, @v, 1); end;
1369 procedure writeIntBE (st: TStream; v: ShortInt); overload; begin writeIntegerBE(st, @v, 1); end;
1370 procedure writeIntBE (st: TStream; v: Word); overload; begin writeIntegerBE(st, @v, 2); end;
1371 procedure writeIntBE (st: TStream; v: SmallInt); overload; begin writeIntegerBE(st, @v, 2); end;
1372 procedure writeIntBE (st: TStream; v: LongWord); overload; begin writeIntegerBE(st, @v, 4); end;
1373 procedure writeIntBE (st: TStream; v: LongInt); overload; begin writeIntegerBE(st, @v, 4); end;
1374 procedure writeIntBE (st: TStream; v: Int64); overload; begin writeIntegerBE(st, @v, 8); end;
1375 procedure writeIntBE (st: TStream; v: UInt64); overload; begin writeIntegerBE(st, @v, 8); end;
1376
1377 procedure writeBool (st: TStream; b: Boolean); begin writeInt(st, Byte(b)); end;
1378 function readBool (st: TStream): Boolean; begin result := (readByte(st) <> 0); end;
1379
1380
1381 procedure writeStr (st: TStream; const str: AnsiString; maxlen: LongWord=65535);
1382 begin
1383   if (Length(str) > maxlen) then raise XStreamError.Create('string too long');
1384   if (maxlen <= 65535) then writeInt(st, Word(Length(str))) else writeInt(st, LongWord(Length(str)));
1385   if (Length(str) > 0) then st.WriteBuffer(str[1], Length(str));
1386 end;
1387
1388 function readStr (st: TStream; maxlen: LongWord=65535): AnsiString;
1389 var
1390   len: Integer;
1391 begin
1392   result := '';
1393   if (maxlen <= 65535) then len := readWord(st) else len := Integer(readLongWord(st));
1394   if (len < 0) or (len > maxlen) then raise XStreamError.Create('string too long');
1395   if (len > 0) then
1396   begin
1397     SetLength(result, len);
1398     st.ReadBuffer(result[1], len);
1399   end;
1400 end;
1401
1402
1403 procedure readIntegerLE (st: TStream; vp: Pointer; size: Integer);
1404 {$IFDEF ENDIAN_LITTLE}
1405 begin
1406   st.readBuffer(vp^, size);
1407 end;
1408 {$ELSE}
1409 var
1410   p: PByte;
1411 begin
1412   p := PByte(vp)+size-1;
1413   while size > 0 do
1414   begin
1415     st.readBuffer(p^, 1);
1416     Dec(size);
1417     Dec(p);
1418   end;
1419 end;
1420 {$ENDIF}
1421
1422 procedure readIntegerBE (st: TStream; vp: Pointer; size: Integer);
1423 {$IFDEF ENDIAN_LITTLE}
1424 var
1425   p: PByte;
1426 begin
1427   p := PByte(vp)+size-1;
1428   while size > 0 do
1429   begin
1430     st.readBuffer(p^, 1);
1431     Dec(size);
1432     Dec(p);
1433   end;
1434 end;
1435 {$ELSE}
1436 begin
1437   st.readBuffer(vp^, size);
1438 end;
1439 {$ENDIF}
1440
1441 function readByte (st: TStream): Byte; begin readIntegerLE(st, @result, 1); end;
1442 function readShortInt (st: TStream): ShortInt; begin readIntegerLE(st, @result, 1); end;
1443 function readWord (st: TStream): Word; begin readIntegerLE(st, @result, 2); end;
1444 function readSmallInt (st: TStream): SmallInt; begin readIntegerLE(st, @result, 2); end;
1445 function readLongWord (st: TStream): LongWord; begin readIntegerLE(st, @result, 4); end;
1446 function readLongInt (st: TStream): LongInt; begin readIntegerLE(st, @result, 4); end;
1447 function readInt64 (st: TStream): Int64; begin readIntegerLE(st, @result, 8); end;
1448 function readUInt64 (st: TStream): UInt64; begin readIntegerLE(st, @result, 8); end;
1449
1450 function readByteBE (st: TStream): Byte; begin readIntegerBE(st, @result, 1); end;
1451 function readShortIntBE (st: TStream): ShortInt; begin readIntegerBE(st, @result, 1); end;
1452 function readWordBE (st: TStream): Word; begin readIntegerBE(st, @result, 2); end;
1453 function readSmallIntBE (st: TStream): SmallInt; begin readIntegerBE(st, @result, 2); end;
1454 function readLongWordBE (st: TStream): LongWord; begin readIntegerBE(st, @result, 4); end;
1455 function readLongIntBE (st: TStream): LongInt; begin readIntegerBE(st, @result, 4); end;
1456 function readInt64BE (st: TStream): Int64; begin readIntegerBE(st, @result, 8); end;
1457 function readUInt64BE (st: TStream): UInt64; begin readIntegerBE(st, @result, 8); end;
1458
1459
1460 // ////////////////////////////////////////////////////////////////////////// //
1461 function nmin (a, b: Byte): Byte; inline; overload; begin if (a < b) then result := a else result := b; end;
1462 function nmin (a, b: ShortInt): ShortInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1463 function nmin (a, b: Word): Word; inline; overload; begin if (a < b) then result := a else result := b; end;
1464 function nmin (a, b: SmallInt): SmallInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1465 function nmin (a, b: LongWord): LongWord; inline; overload; begin if (a < b) then result := a else result := b; end;
1466 function nmin (a, b: LongInt): LongInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1467 function nmin (a, b: Int64): Int64; inline; overload; begin if (a < b) then result := a else result := b; end;
1468 function nmin (a, b: UInt64): UInt64; inline; overload; begin if (a < b) then result := a else result := b; end;
1469 function nmin (a, b: Single): Single; inline; overload; begin if (a < b) then result := a else result := b; end;
1470 function nmin (a, b: Double): Double; inline; overload; begin if (a < b) then result := a else result := b; end;
1471 {$IF DEFINED(CPU386) OR DEFINED(CPUAMD64)}
1472 function nmin (a, b: Extended): Extended; inline; overload; begin if (a < b) then result := a else result := b; end;
1473 {$ENDIF}
1474
1475 function nmax (a, b: Byte): Byte; inline; overload; begin if (a > b) then result := a else result := b; end;
1476 function nmax (a, b: ShortInt): ShortInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1477 function nmax (a, b: Word): Word; inline; overload; begin if (a > b) then result := a else result := b; end;
1478 function nmax (a, b: SmallInt): SmallInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1479 function nmax (a, b: LongWord): LongWord; inline; overload; begin if (a > b) then result := a else result := b; end;
1480 function nmax (a, b: LongInt): LongInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1481 function nmax (a, b: Int64): Int64; inline; overload; begin if (a > b) then result := a else result := b; end;
1482 function nmax (a, b: UInt64): UInt64; inline; overload; begin if (a > b) then result := a else result := b; end;
1483 function nmax (a, b: Single): Single; inline; overload; begin if (a > b) then result := a else result := b; end;
1484 function nmax (a, b: Double): Double; inline; overload; begin if (a > b) then result := a else result := b; end;
1485 {$IF DEFINED(CPU386) OR DEFINED(CPUAMD64)}
1486 function nmax (a, b: Extended): Extended; inline; overload; begin if (a > b) then result := a else result := b; end;
1487 {$ENDIF}
1488
1489 function nclamp (v, a, b: Byte): Byte; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1490 function nclamp (v, a, b: ShortInt): ShortInt; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1491 function nclamp (v, a, b: Word): Word; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1492 function nclamp (v, a, b: SmallInt): SmallInt; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1493 function nclamp (v, a, b: LongWord): LongWord; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1494 function nclamp (v, a, b: LongInt): LongInt; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1495 function nclamp (v, a, b: Int64): Int64; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1496 function nclamp (v, a, b: UInt64): UInt64; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1497 function nclamp (v, a, b: Single): Single; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1498 function nclamp (v, a, b: Double): Double; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1499 {$IF DEFINED(CPU386) OR DEFINED(CPUAMD64)}
1500 function nclamp (v, a, b: Extended): Extended; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1501 {$ENDIF}
1502
1503 // ////////////////////////////////////////////////////////////////////////// //
1504 {$IFDEF WINDOWS}
1505 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'msvcrt.dll' name '_snprintf';
1506 {$ELSE}
1507 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'libc' name 'snprintf';
1508 {$ENDIF}
1509
1510
1511 (*
1512 procedure conwriter (constref buf; len: SizeUInt);
1513 var
1514   ss: ShortString;
1515   slen: Integer;
1516   b: PByte;
1517 begin
1518   if (len < 1) then exit;
1519   b := PByte(@buf);
1520   while (len > 0) do
1521   begin
1522     if (len > 255) then slen := 255 else slen := Integer(len);
1523     Move(b^, ss[1], len);
1524     ss[0] := AnsiChar(slen);
1525     write(ss);
1526     b += slen;
1527     len -= slen;
1528   end;
1529 end;
1530 *)
1531
1532
1533 function formatstrf (const fmt: AnsiString; const args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
1534 const
1535   PadSpaces: AnsiString = '                                                                       ';
1536   PadZeroes: AnsiString = '00000000000000000000000000000000000000000000000000000000000000000000000';
1537 var
1538   curarg: Integer = 0; // current arg in `args`
1539   sign, fmtch: AnsiChar;
1540   zeropad: Boolean;
1541   width, prec: Integer; // width and precision
1542   spos, epos: Integer;
1543   ch: AnsiChar;
1544   strbuf: array[0..256] of AnsiChar;
1545   strblen: SizeUInt;
1546   fmtbuf: array[0..256] of AnsiChar;
1547   fmtblen: Integer;
1548   pclen: Integer;
1549   pc: PAnsiChar;
1550   ccname: ShortString;
1551
1552   procedure writer (constref buf; len: SizeUInt);
1553   var
1554     ss: ShortString;
1555     slen: Integer;
1556     b: PByte;
1557   begin
1558     if (len < 1) then exit;
1559     b := PByte(@buf);
1560     if assigned(writerCB) then
1561     begin
1562       writerCB(b^, len);
1563     end
1564     else
1565     begin
1566       while (len > 0) do
1567       begin
1568         if (len > 255) then slen := 255 else slen := Integer(len);
1569         Move(b^, ss[1], slen);
1570         ss[0] := AnsiChar(slen);
1571         result += ss;
1572         b += slen;
1573         len -= slen;
1574       end;
1575     end;
1576   end;
1577
1578   procedure xwrite (const s: AnsiString);
1579   begin
1580     if (Length(s) > 0) then writer(PAnsiChar(s)^, Length(s));
1581   end;
1582
1583   procedure putFmtChar (ch: AnsiChar);
1584   begin
1585     fmtbuf[fmtblen] := ch;
1586     Inc(fmtblen);
1587   end;
1588
1589   procedure putFmtInt (n: Integer);
1590   var
1591     len: SizeUInt;
1592   begin
1593     len := snprintf(@fmtbuf[fmtblen], Length(fmtbuf)-fmtblen, '%d', n);
1594     if (len > 0) then Inc(fmtblen, len);
1595   end;
1596
1597   procedure buildCFormat (const pfx: AnsiString='');
1598   var
1599     f: Integer;
1600   begin
1601     fmtblen := 0;
1602     for f := 1 to Length(pfx) do putFmtChar(pfx[f]);
1603     putFmtChar('%');
1604     if (sign <> ' ') then putFmtChar(sign);
1605     if (width >= 0) then
1606     begin
1607       if (zeropad) then putFmtChar('0');
1608       putFmtInt(width);
1609       if (prec >= 0) then
1610       begin
1611         putFmtChar('.');
1612         putFmtInt(prec);
1613       end;
1614     end;
1615     putFmtChar(fmtch);
1616     fmtbuf[fmtblen] := #0;
1617   end;
1618
1619   procedure writeStrBuf ();
1620   begin
1621     if (strblen > 0) then writer(strbuf, strblen);
1622   end;
1623
1624   function i642str (n: Int64; hex: Boolean; hexup: Boolean): PAnsiChar;
1625   var
1626     neg: Boolean;
1627     xpos: Integer;
1628   begin
1629     if (n = $8000000000000000) then
1630     begin
1631       if hex then snprintf(@strbuf[0], Length(strbuf), '-8000000000000000')
1632       else snprintf(@strbuf[0], Length(strbuf), '-9223372036854775808');
1633       result := @strbuf[0];
1634     end
1635     else
1636     begin
1637       neg := (n < 0);
1638       if neg then n := -n;
1639       xpos := High(strbuf);
1640       strbuf[xpos] := #0; Dec(xpos);
1641       repeat
1642         if not hex then
1643         begin
1644           strbuf[xpos] := AnsiChar((n mod 10)+48);
1645           Dec(xpos);
1646           n := n div 10;
1647         end
1648         else
1649         begin
1650           if (n mod 16 > 9) then
1651           begin
1652             strbuf[xpos] := AnsiChar((n mod 16)+48+7);
1653             if not hexup then Inc(strbuf[xpos], 32);
1654           end
1655           else strbuf[xpos] := AnsiChar((n mod 16)+48);
1656           Dec(xpos);
1657           n := n div 16;
1658         end;
1659       until (n = 0);
1660       if neg then begin strbuf[xpos] := '-'; Dec(xpos); end;
1661       result := @strbuf[xpos+1];
1662     end;
1663   end;
1664
1665   function ui642str (n: UInt64; hex: Boolean; hexup: Boolean): PAnsiChar;
1666   var
1667     xpos: Integer;
1668   begin
1669     xpos := High(strbuf);
1670     strbuf[xpos] := #0; Dec(xpos);
1671     repeat
1672       if not hex then
1673       begin
1674         strbuf[xpos] := AnsiChar((n mod 10)+48);
1675         Dec(xpos);
1676         n := n div 10;
1677       end
1678       else
1679       begin
1680         if (n mod 16 > 9) then
1681         begin
1682           strbuf[xpos] := AnsiChar((n mod 16)+48+7);
1683           if not hexup then Inc(strbuf[xpos], 32);
1684         end
1685         else strbuf[xpos] := AnsiChar((n mod 16)+48);
1686         Dec(xpos);
1687         n := n div 16;
1688       end;
1689     until (n = 0);
1690     result := @strbuf[xpos+1];
1691   end;
1692
1693   procedure indent (len: Integer);
1694   var
1695     ilen: Integer;
1696   begin
1697     while (len > 0) do
1698     begin
1699       if (len > Length(PadSpaces)) then ilen := Length(PadSpaces) else ilen := len;
1700       writer(PAnsiChar(PadSpaces)^, ilen);
1701       Dec(len, ilen);
1702     end;
1703   end;
1704
1705   procedure indent0 (len: Integer);
1706   var
1707     ilen: Integer;
1708   begin
1709     while (len > 0) do
1710     begin
1711       if (len > Length(PadZeroes)) then ilen := Length(PadZeroes) else ilen := len;
1712       writer(PAnsiChar(PadZeroes)^, ilen);
1713       Dec(len, ilen);
1714     end;
1715   end;
1716
1717 begin
1718   result := '';
1719   spos := 1;
1720   while (spos <= Length(fmt)) do
1721   begin
1722     // print literal part
1723     epos := spos;
1724     while (epos <= Length(fmt)) and (fmt[epos] <> '%') do Inc(epos);
1725     // output literal part
1726     if (epos > spos) then
1727     begin
1728       if (epos > Length(fmt)) then
1729       begin
1730         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
1731         break;
1732       end;
1733            if (epos+1 > Length(fmt)) then Inc(epos) // last percent, output literally
1734       else if (fmt[epos+1] = '%') then // special case
1735       begin
1736         Inc(epos);
1737         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
1738         spos := epos+1;
1739       end
1740       else
1741       begin
1742         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
1743         spos := epos;
1744       end;
1745       continue;
1746     end;
1747     // check if we have argument for this format string
1748     if (curarg > High(args)) then
1749     begin
1750       xwrite('<OUT OF ARGS>');
1751       writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1752       break;
1753     end;
1754     // skip percent
1755     if (spos+1 > Length(fmt)) then break; // oops
1756     assert(fmt[spos] = '%');
1757     Inc(spos);
1758     // parse format; check for sign
1759          if (fmt[spos] = '-') then begin sign := '-'; Inc(spos); end
1760     else if (fmt[spos] = '+') then begin sign := '+'; Inc(spos); end
1761     else sign := ' ';
1762     // parse width
1763     if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
1764     if (sign <> ' ') or ((fmt[spos] >= '0') and (fmt[spos] <= '9')) then
1765     begin
1766       if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1767       zeropad := (fmt[spos] = '0');
1768       width := 0;
1769       while (spos <= Length(fmt)) do
1770       begin
1771         ch := fmt[spos];
1772         if (ch < '0') or (ch > '9') then break;
1773         width := width*10+Integer(ch)-48;
1774         Inc(spos);
1775       end;
1776     end
1777     else
1778     begin
1779       width := -1;
1780       zeropad := false;
1781     end;
1782     // parse precision
1783     prec := -1;
1784     if (spos <= Length(fmt)) and (fmt[spos] = '.') then
1785     begin
1786       Inc(spos);
1787       if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
1788       if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1789       prec := 0;
1790       while (spos <= Length(fmt)) do
1791       begin
1792         ch := fmt[spos];
1793         if (ch < '0') or (ch > '9') then break;
1794         prec := prec*10+Integer(ch)-48;
1795         Inc(spos);
1796       end;
1797     end;
1798     // get format char
1799     if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
1800     fmtch := fmt[spos];
1801     Inc(spos);
1802     // done parsing format, check for valid format chars
1803     if not (fmtch in ['s','u','d','x','X','p','f','g','c']) then begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1804     // now write formatted string
1805     case args[curarg].VType of
1806       vtInteger: // args[curarg].VInteger
1807         begin
1808           if not (fmtch in ['s','u','d','x','X']) then begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1809           if (fmtch = 's') then fmtch := 'd';
1810           buildCFormat();
1811           strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], args[curarg].VInteger);
1812           writeStrBuf();
1813         end;
1814       vtBoolean: // args[curarg].VBoolean
1815         case fmtch of
1816           's':
1817             begin
1818               buildCFormat();
1819               if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'true')
1820               else strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'false');
1821               writeStrBuf();
1822             end;
1823           'c':
1824             begin
1825               buildCFormat();
1826               if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('t'))
1827               else strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('f'));
1828               writeStrBuf();
1829             end;
1830           'u', 'd', 'x', 'X':
1831             begin
1832               buildCFormat();
1833               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(args[curarg].VBoolean));
1834               writeStrBuf();
1835             end;
1836           else
1837             begin
1838               xwrite('<INVALID FORMAT CHAR>');
1839               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1840               break;
1841             end;
1842         end;
1843       vtChar: // args[curarg].VChar
1844         case fmtch of
1845           's', 'c':
1846             begin
1847               fmtch := 'c';
1848               buildCFormat();
1849               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], args[curarg].VChar);
1850               writeStrBuf();
1851             end;
1852           'u', 'd', 'x', 'X':
1853             begin
1854               buildCFormat();
1855               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(args[curarg].VChar));
1856               writeStrBuf();
1857             end;
1858           else
1859             begin
1860               xwrite('<INVALID FORMAT CHAR>');
1861               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1862               break;
1863             end;
1864         end;
1865       //vtWideChar: begin end; // args[curarg].VWideChar (WideChar)
1866       vtExtended: // args[curarg].VExtended^
1867         case fmtch of
1868           's', 'g':
1869             begin
1870               fmtch := 'g';
1871               buildCFormat();
1872               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Double(args[curarg].VExtended^));
1873               writeStrBuf();
1874             end;
1875           'f':
1876             begin
1877               buildCFormat();
1878               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Double(args[curarg].VExtended^));
1879               writeStrBuf();
1880             end;
1881           'd':
1882             begin
1883               buildCFormat();
1884               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(trunc(args[curarg].VExtended^)));
1885               writeStrBuf();
1886             end;
1887           'u', 'x', 'X':
1888             begin
1889               buildCFormat();
1890               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], LongWord(trunc(args[curarg].VExtended^)));
1891               writeStrBuf();
1892             end;
1893           else
1894             begin
1895               xwrite('<INVALID FORMAT CHAR>');
1896               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1897               break;
1898             end;
1899         end;
1900       vtString: // args[curarg].VString^ (PShortString)
1901         begin
1902           if (sign <> '-') then indent(width-Length(args[curarg].VString^));
1903           writer(args[curarg].VString^[1], Length(args[curarg].VString^));
1904           if (sign = '-') then indent(width-Length(args[curarg].VString^));
1905         end;
1906       vtPointer: // args[curarg].VPointer
1907         case fmtch of
1908           's':
1909             begin
1910               fmtch := 'x';
1911               if (width < 8) then width := 8;
1912               zeropad := true;
1913               buildCFormat('0x');
1914               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], PtrUInt(args[curarg].VPointer));
1915               writeStrBuf();
1916             end;
1917           'u', 'd', 'x', 'p', 'X':
1918             begin
1919               if (fmtch = 'p') then fmtch := 'x';
1920               if (width < 8) then width := 8;
1921               zeropad := true;
1922               buildCFormat('0x');
1923               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], PtrUInt(args[curarg].VPointer));
1924               writeStrBuf();
1925             end;
1926           else
1927             begin
1928               xwrite('<INVALID FORMAT CHAR>');
1929               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1930               break;
1931             end;
1932         end;
1933       vtPChar: // args[curarg].VPChar
1934         if (args[curarg].VPChar = nil) then
1935         begin
1936           if (sign <> '-') then indent(width-3);
1937           xwrite('nil');
1938           if (sign = '-') then indent(width-3);
1939         end
1940         else
1941         begin
1942           pclen := 0;
1943           while (args[curarg].VPChar[pclen] <> #0) do Inc(pclen);
1944           if (sign <> '-') then indent(width-pclen);
1945           writer(args[curarg].VPChar^, pclen);
1946           if (sign = '-') then indent(width-pclen);
1947         end;
1948       vtObject: // args[curarg].VObject.Classname (TObject)
1949         begin
1950           if (args[curarg].VObject <> nil) then ccname := args[curarg].VObject.Classname else ccname := '<nil>';
1951           if (sign <> '-') then indent(width-Length(ccname));
1952           xwrite(ccname);
1953           if (sign = '-') then indent(width-Length(ccname));
1954         end;
1955       vtClass: // args[curarg].VClass.Classname (TClass)
1956         begin
1957           if (args[curarg].VClass <> nil) then ccname := args[curarg].VClass.Classname else ccname := '<nil>';
1958           if (sign <> '-') then indent(width-Length(ccname));
1959           xwrite(ccname);
1960           if (sign = '-') then indent(width-Length(ccname));
1961         end;
1962       //vtPWideChar: begin end; // args[curarg].VPWideChar (PWideChar)
1963       vtAnsiString: // AnsiString(args[curarg].VAnsiString) (Pointer)
1964         begin
1965           if (sign <> '-') then indent(width-Length(AnsiString(args[curarg].VAnsiString)));
1966           xwrite(AnsiString(args[curarg].VAnsiString));
1967           if (sign = '-') then indent(width-Length(AnsiString(args[curarg].VAnsiString)));
1968         end;
1969       //vtCurrency: begin end; // args[curarg].VCurrency (PCurrency)
1970       //vtVariant: begin end; // args[curarg].VVariant^ (PVariant)
1971       //vtInterface: begin end; // args[curarg].VInterface (Pointer);
1972       //vtWideString: begin end; // args[curarg].VWideString (Pointer);
1973       vtInt64: // args[curarg].VInt64^ (PInt64)
1974         begin
1975           case fmtch of
1976             's','d','u': pc := i642str(args[curarg].VInt64^, false, false);
1977             'x': pc := i642str(args[curarg].VInt64^, true, false);
1978             'X': pc := i642str(args[curarg].VInt64^, true, true);
1979             else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1980           end;
1981           pclen := 0;
1982           while (pc[pclen] <> #0) do Inc(pclen);
1983           if (sign <> '-') and (width > pclen) then
1984           begin
1985             if zeropad then
1986             begin
1987               if (pc[0] = '-') or (pc[0] = '+') then
1988               begin
1989                 writer(pc^, 1);
1990                 indent0(width-pclen-1);
1991                 Inc(pc);
1992                 Dec(pclen);
1993               end
1994               else
1995               begin
1996                 indent0(width-pclen);
1997               end;
1998             end
1999             else
2000             begin
2001               indent(width-pclen);
2002             end;
2003           end;
2004           writer(pc^, pclen);
2005           if (sign = '-') then indent(width-pclen);
2006         end;
2007       vtQWord: // args[curarg].VQWord^ (PQWord)
2008         begin
2009           case fmtch of
2010             's','d','u': pc := ui642str(args[curarg].VInt64^, false, false);
2011             'x': pc := ui642str(args[curarg].VInt64^, true, false);
2012             'X': pc := ui642str(args[curarg].VInt64^, true, true);
2013             else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
2014           end;
2015           pclen := 0;
2016           while (pc[pclen] <> #0) do Inc(pclen);
2017           if (sign <> '-') then begin if zeropad then indent0(width-pclen) else indent(width-pclen); end;
2018           writer(pc^, pclen);
2019           if (sign = '-') then indent(width-pclen);
2020         end;
2021       else
2022         begin
2023           xwrite('<INVALID TYPE>');
2024           writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
2025           break;
2026         end;
2027     end;
2028     Inc(curarg);
2029   end;
2030 end;
2031
2032
2033 function GetDiskFileInfo (fname: AnsiString; var info: TDiskFileInfo): Boolean;
2034 var
2035   age: LongInt;
2036   size: LongInt;
2037   handle: THandle;
2038 begin
2039   result := false;
2040   if (length(fname) = 0) then exit;
2041   if not findFileCI(fname) then exit;
2042   // get age
2043   age := FileAge(fname);
2044   if (age = -1) then exit;
2045   // get size
2046   handle := FileOpen(fname, fmOpenRead or fmShareDenyNone);
2047   if (handle = THandle(-1)) then exit;
2048   size := FileSeek(handle, 0, fsFromEnd);
2049   FileClose(handle);
2050   if (size = -1) then exit;
2051   // fill info
2052   info.diskName := fname;
2053   info.size := size;
2054   info.age := age;
2055   result := true;
2056 end;
2057
2058
2059 (*
2060 var
2061   ss: ShortString;
2062   ls: AnsiString;
2063   i64: Int64 = -$A000000000;
2064   ui64: UInt64 = $A000000000;
2065 begin
2066   writef(conwriter, 'test int:<%s> bool:<%s:%02d:%c> bool:<%s:%02d:%c>; char:<%2s;%c;%d>!'#10, [42, true, true, true, false, false, false, 'A', 'A', 'A']);
2067   writef(conwriter, 'test float:<%s;%u;%f;%g>'#10, [666.6942, 666.6942, 666.6942, 666.6942]);
2068   ss := 'fuckit';
2069   ls := 'FUCKIT';
2070   writef(conwriter, 'test ss:<%5s;%040s>'#10, [ss, ss]);
2071   writef(conwriter, 'test ls:<%5s;%040s>'#10, [ls, ls]);
2072   writef(conwriter, 'test pointer:<%s;%x;%p>'#10, [@ss, @ss, @ss]);
2073   writef(conwriter, 'test i64:<%s;%x;%015d;%u;%X>'#10, [i64, i64, i64, i64, i64]);
2074   writef(conwriter, 'test ui64:<%s;%x;%15d;%015u;%X>'#10, [ui64, ui64, ui64, ui64, ui64]);
2075 *)
2076 end.