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