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, wext: 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         for wext in wadExtensions do
 901         begin
 902           if strEquCI1251(s, wext) then
 903           begin
 904             result := true;
 905             exit;
 906           end;
 907         end;
 908       end;
 909     end;
 910     Inc(pos);
 911   end;
 912 end;
 913
 914
 915 function int64ToStrComma (i: Int64): AnsiString;
 916 var
 917   f: Integer;
 918 begin
 919   Str(i, result);
 920   f := Length(result)+1;
 921   while f > 4 do
 922   begin
 923     Dec(f, 3); Insert(',', result, f);
 924   end;
 925 end;
 926
 927
 928 function upcase1251 (ch: AnsiChar): AnsiChar; inline;
 929 begin
 930   if ch < #128 then
 931   begin
 932     if (ch >= 'a') and (ch <= 'z') then Dec(ch, 32);
 933   end
 934   else
 935   begin
 936     if (ch >= #224) and (ch <= #255) then
 937     begin
 938       Dec(ch, 32);
 939     end
 940     else
 941     begin
 942       case ch of
 943         #184, #186, #191: Dec(ch, 16);
 944         #162, #179: Dec(ch);
 945       end;
 946     end;
 947   end;
 948   result := ch;
 949 end;
 950
 951
 952 function locase1251 (ch: AnsiChar): AnsiChar; inline;
 953 begin
 954   if ch < #128 then
 955   begin
 956     if (ch >= 'A') and (ch <= 'Z') then Inc(ch, 32);
 957   end
 958   else
 959   begin
 960     if (ch >= #192) and (ch <= #223) then
 961     begin
 962       Inc(ch, 32);
 963     end
 964     else
 965     begin
 966       case ch of
 967         #168, #170, #175: Inc(ch, 16);
 968         #161, #178: Inc(ch);
 969       end;
 970     end;
 971   end;
 972   result := ch;
 973 end;
 974
 975 function IsValid1251 (ch: Word): Boolean;
 976 begin
 977   result := (ch = Ord('?')) or (wc2shitmap[ch] <> '?')
 978 end;
 979
 980 function IsPrintable1251 (ch: AnsiChar): Boolean;
 981 begin
 982   result := (ch >= #32) and (ch <> #127)
 983 end;
 984
 985
 986 function strEquCI1251 (const s0, s1: AnsiString): Boolean;
 987 var
 988   i: Integer;
 989 begin
 990   result := false;
 991   if length(s0) <> length(s1) then exit;
 992   for i := 1 to length(s0) do if UpCase1251(s0[i]) <> UpCase1251(s1[i]) then exit;
 993   result := true;
 994 end;
 995
 996
 997 function toLowerCase1251 (const s: AnsiString): AnsiString;
 998 var
 999   f: Integer;
1000   ch: AnsiChar;
1001 begin
1002   for ch in s do
1003   begin
1004     if (ch <> LoCase1251(ch)) then
1005     begin
1006       result := '';
1007       SetLength(result, Length(s));
1008       for f := 1 to Length(s) do result[f] := LoCase1251(s[f]);
1009       exit;
1010     end;
1011   end;
1012   // nothing to do
1013   result := s;
1014 end;
1015
1016
1017 // ////////////////////////////////////////////////////////////////////////// //
1018 // utils
1019 // `ch`: utf8 start
1020 // -1: invalid utf8
1021 function utf8CodeLen (ch: Word): Integer;
1022 begin
1023   if ch < $80 then begin result := 1; exit; end;
1024   if (ch and $FE) = $FC then begin result := 6; exit; end;
1025   if (ch and $FC) = $F8 then begin result := 5; exit; end;
1026   if (ch and $F8) = $F0 then begin result := 4; exit; end;
1027   if (ch and $F0) = $E0 then begin result := 3; exit; end;
1028   if (ch and $E0) = $C0 then begin result := 2; exit; end;
1029   result := -1; // invalid
1030 end;
1031
1032
1033 function utf8Valid (const s: AnsiString): Boolean;
1034 var
1035   pos, len: Integer;
1036 begin
1037   result := false;
1038   pos := 1;
1039   while pos <= length(s) do
1040   begin
1041     len := utf8CodeLen(Byte(s[pos]));
1042     if len < 1 then exit; // invalid sequence start
1043     if pos+len-1 > length(s) then exit; // out of chars in string
1044     Dec(len);
1045     Inc(pos);
1046     // check other sequence bytes
1047     while len > 0 do
1048     begin
1049       if (Byte(s[pos]) and $C0) <> $80 then exit;
1050       Dec(len);
1051       Inc(pos);
1052     end;
1053   end;
1054   result := true;
1055 end;
1056
1057
1058 // ////////////////////////////////////////////////////////////////////////// //
1059 const
1060   uni2wint: array [128..255] of Word = (
1061     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
1062     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
1063     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
1064     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
1065     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
1066     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
1067     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
1068     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
1069   );
1070
1071
1072 function decodeUtf8Char (s: AnsiString; var pos: Integer): AnsiChar;
1073 var
1074   b, c: Integer;
1075 begin
1076   (* The following encodings are valid, except for the 5 and 6 byte
1077    * combinations:
1078    *  0xxxxxxx
1079    *  110xxxxx 10xxxxxx
1080    *  1110xxxx 10xxxxxx 10xxxxxx
1081    *  11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
1082    *  111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
1083    *  1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
1084    *)
1085   result := '?';
1086   if pos > length(s) then exit;
1087
1088   b := Byte(s[pos]);
1089   Inc(pos);
1090   if b < $80 then begin result := AnsiChar(b); exit; end;
1091
1092   // mask out unused bits
1093        if (b and $FE) = $FC then b := b and $01
1094   else if (b and $FC) = $F8 then b := b and $03
1095   else if (b and $F8) = $F0 then b := b and $07
1096   else if (b and $F0) = $E0 then b := b and $0F
1097   else if (b and $E0) = $C0 then b := b and $1F
1098   else exit; // invalid utf8
1099
1100   // now continue
1101   while pos <= length(s) do
1102   begin
1103     c := Byte(s[pos]);
1104     if (c and $C0) <> $80 then break; // no more
1105     b := b shl 6;
1106     b := b or (c and $3F);
1107     Inc(pos);
1108   end;
1109
1110   // done, try 1251
1111   for c := 128 to 255 do if uni2wint[c] = b then begin result := AnsiChar(c and $FF); exit; end;
1112   // alas
1113 end;
1114
1115
1116 function utf8to1251 (s: AnsiString): AnsiString;
1117 var
1118   pos: Integer;
1119 begin
1120   if not utf8Valid(s) then begin result := s; exit; end;
1121   pos := 1;
1122   while pos <= length(s) do
1123   begin
1124     if Byte(s[pos]) >= $80 then break;
1125     Inc(pos);
1126   end;
1127   if pos > length(s) then begin result := s; exit; end; // nothing to do here
1128   result := '';
1129   pos := 1;
1130   while pos <= length(s) do result := result+decodeUtf8Char(s, pos);
1131 end;
1132
1133
1134 // ////////////////////////////////////////////////////////////////////////// //
1135 // findFileCI eats case-insensitive path, traverses it and rewrites it to a
1136 // case-sensetive. result value means success.
1137 // if file/dir not founded than pathname is in undefined state!
1138 function findFileCI (var pathname: AnsiString; lastIsDir: Boolean=false): Boolean;
1139 var
1140   sr: TSearchRec;
1141   npt: AnsiString;
1142   newname: AnsiString = '';
1143   curname: AnsiString;
1144   wantdir: Boolean;
1145   attr: LongInt;
1146   foundher: Boolean;
1147 begin
1148   npt := pathname;
1149   result := (length(npt) > 0);
1150   if (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) then newname := '/';
1151   while length(npt) > 0 do
1152   begin
1153     // remove trailing slashes
1154     while (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) do Delete(npt, 1, 1);
1155     if length(npt) = 0 then break;
1156     // extract name
1157     curname := '';
1158     while (length(npt) > 0) and (npt[1] <> '/') and (npt[1] <> '\') do
1159     begin
1160       curname := curname+npt[1];
1161       Delete(npt, 1, 1);
1162     end;
1163     // remove trailing slashes again
1164     while (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) do Delete(npt, 1, 1);
1165     wantdir := lastIsDir or (length(npt) > 0); // do we want directory here?
1166     //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
1167     // try the easiest case first
1168     attr := FileGetAttr(newname+curname);
1169     if attr <> -1 then
1170     begin
1171       if wantdir = ((attr and faDirectory) <> 0) then
1172       begin
1173         // i found her!
1174         newname := newname+curname;
1175         if wantdir then newname := newname+'/';
1176         continue;
1177       end;
1178     end;
1179     //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
1180     // alas, either not found, or invalid attributes
1181     foundher := false;
1182     try
1183       if FindFirst(newname+'*', faAnyFile, sr) = 0 then
1184       repeat
1185         if (wantdir = ((sr.attr and faDirectory) <> 0)) and StrEquCI1251(sr.name, curname) then
1186         begin
1187           // i found her!
1188           newname := newname+sr.name;
1189           if wantdir then newname := newname+'/';
1190           foundher := true;
1191           break;
1192         end;
1193       until FindNext(sr) <> 0;
1194     finally
1195       FindClose(sr);
1196     end;
1197     if not foundher then begin newname := ''; result := false; break; end;
1198   end;
1199   if result then pathname := newname;
1200 end;
1201
1202
1203 function isWadNamesEqu (wna, wnb: AnsiString): Boolean;
1204 var
1205   ext, newExt: AnsiString;
1206   found: Boolean;
1207 begin
1208   result := StrEquCI1251(wna, wnb);
1209   if result then exit;
1210   // check first ext
1211   ext := getFilenameExt(wna);
1212   found := false;
1213   for newExt in wadExtensions do if (StrEquCI1251(ext, newExt)) then begin found := true; break; end;
1214   if not found then exit;
1215   // check second ext
1216   ext := getFilenameExt(wnb);
1217   found := false;
1218   for newExt in wadExtensions do if (StrEquCI1251(ext, newExt)) then begin found := true; break; end;
1219   if not found then exit;
1220   wna := forceFilenameExt(wna, '');
1221   wnb := forceFilenameExt(wnb, '');
1222   result := StrEquCI1251(wna, wnb);
1223 end;
1224
1225 function findDiskWad (fname: AnsiString): AnsiString;
1226 var
1227   origExt: AnsiString = '';
1228   newExt: AnsiString = '';
1229 begin
1230   result := '';
1231   //writeln('findDiskWad00: fname=<', fname, '>');
1232   if (findFileCI(fname)) then begin result := fname; exit; end;
1233   origExt := getFilenameExt(fname);
1234   fname := forceFilenameExt(fname, '');
1235   //writeln(' findDiskWad01: fname=<', fname, '>; origExt=<', origExt, '>');
1236   for newExt in wadExtensions do
1237   begin
1238     //writeln(' findDiskWad02: fname=<', fname, '>; origExt=<', origExt, '>; newExt=<', newExt, '>');
1239     if (StrEquCI1251(newExt, origExt)) then
1240     begin
1241       //writeln('   SKIP');
1242       continue;
1243     end;
1244     result := fname+newExt;
1245     if (findFileCI(result)) then exit;
1246   end;
1247   result := '';
1248 end;
1249
1250
1251 function openDiskFileRO (pathname: AnsiString): TStream;
1252 begin
1253   if not findFileCI(pathname) then raise EFileNotFoundException.Create('can''t open file "'+pathname+'"');
1254   result := TFileStream.Create(pathname, fmOpenRead or {fmShareDenyWrite}fmShareDenyNone);
1255 end;
1256
1257 function createDiskFile (pathname: AnsiString): TStream;
1258 var
1259   path: AnsiString;
1260 begin
1261   path := ExtractFilePath(pathname);
1262   if length(path) > 0 then
1263   begin
1264     if not findFileCI(path, true) then raise Exception.Create('can''t create file "'+pathname+'"');
1265   end;
1266   result := TFileStream.Create(path+ExtractFileName(pathname), fmCreate);
1267 end;
1268
1269
1270 function openDiskFileRW (pathname: AnsiString): TStream;
1271 var
1272   path: AnsiString;
1273   oldname: AnsiString;
1274 begin
1275   //writeln('*** TRYING R/W FILE "', pathname, '"');
1276   path := ExtractFilePath(pathname);
1277   if length(path) > 0 then
1278   begin
1279     if not findFileCI(path, true) then raise Exception.Create('can''t create file "'+pathname+'"');
1280   end;
1281   oldname := pathname;
1282   if findFileCI(oldname) then
1283   begin
1284     //writeln('*** found old file "', oldname, '"');
1285     result := TFileStream.Create(oldname, fmOpenReadWrite or fmShareDenyWrite);
1286   end
1287   else
1288   begin
1289     result := TFileStream.Create(path+ExtractFileName(pathname), fmCreate);
1290   end;
1291 end;
1292
1293
1294 procedure writeIntegerLE (st: TStream; vp: Pointer; size: Integer);
1295 {$IFDEF ENDIAN_LITTLE}
1296 begin
1297   st.writeBuffer(vp^, size);
1298 end;
1299 {$ELSE}
1300 var
1301   p: PByte;
1302 begin
1303   p := PByte(vp)+size-1;
1304   while size > 0 do
1305   begin
1306     st.writeBuffer(p^, 1);
1307     Dec(size);
1308     Dec(p);
1309   end;
1310 end;
1311 {$ENDIF}
1312
1313 procedure writeIntegerBE (st: TStream; vp: Pointer; size: Integer);
1314 {$IFDEF ENDIAN_LITTLE}
1315 var
1316   p: PByte;
1317 begin
1318   p := PByte(vp)+size-1;
1319   while size > 0 do
1320   begin
1321     st.writeBuffer(p^, 1);
1322     Dec(size);
1323     Dec(p);
1324   end;
1325 end;
1326 {$ELSE}
1327 begin
1328   st.writeBuffer(vp^, size);
1329 end;
1330 {$ENDIF}
1331
1332 procedure writeSign (st: TStream; const sign: AnsiString);
1333 begin
1334   if (Length(sign) > 0) then st.WriteBuffer(sign[1], Length(sign));
1335 end;
1336
1337 function checkSign (st: TStream; const sign: AnsiString): Boolean;
1338 var
1339   buf: packed array[0..7] of AnsiChar;
1340   f: Integer;
1341 begin
1342   result := false;
1343   if (Length(sign) > 0) then
1344   begin
1345     if (Length(sign) <= 8) then
1346     begin
1347       st.ReadBuffer(buf[0], Length(sign));
1348       for f := 1 to Length(sign) do if (buf[f-1] <> sign[f]) then exit;
1349     end
1350     else
1351     begin
1352       for f := 1 to Length(sign) do
1353       begin
1354         st.ReadBuffer(buf[0], 1);
1355         if (buf[0] <> sign[f]) then exit;
1356       end;
1357     end;
1358   end;
1359   result := true;
1360 end;
1361
1362 procedure writeInt (st: TStream; v: Byte); overload; begin writeIntegerLE(st, @v, 1); end;
1363 procedure writeInt (st: TStream; v: ShortInt); overload; begin writeIntegerLE(st, @v, 1); end;
1364 procedure writeInt (st: TStream; v: Word); overload; begin writeIntegerLE(st, @v, 2); end;
1365 procedure writeInt (st: TStream; v: SmallInt); overload; begin writeIntegerLE(st, @v, 2); end;
1366 procedure writeInt (st: TStream; v: LongWord); overload; begin writeIntegerLE(st, @v, 4); end;
1367 procedure writeInt (st: TStream; v: LongInt); overload; begin writeIntegerLE(st, @v, 4); end;
1368 procedure writeInt (st: TStream; v: Int64); overload; begin writeIntegerLE(st, @v, 8); end;
1369 procedure writeInt (st: TStream; v: UInt64); overload; begin writeIntegerLE(st, @v, 8); end;
1370
1371 procedure writeIntBE (st: TStream; v: Byte); overload; begin writeIntegerBE(st, @v, 1); end;
1372 procedure writeIntBE (st: TStream; v: ShortInt); overload; begin writeIntegerBE(st, @v, 1); end;
1373 procedure writeIntBE (st: TStream; v: Word); overload; begin writeIntegerBE(st, @v, 2); end;
1374 procedure writeIntBE (st: TStream; v: SmallInt); overload; begin writeIntegerBE(st, @v, 2); end;
1375 procedure writeIntBE (st: TStream; v: LongWord); overload; begin writeIntegerBE(st, @v, 4); end;
1376 procedure writeIntBE (st: TStream; v: LongInt); overload; begin writeIntegerBE(st, @v, 4); end;
1377 procedure writeIntBE (st: TStream; v: Int64); overload; begin writeIntegerBE(st, @v, 8); end;
1378 procedure writeIntBE (st: TStream; v: UInt64); overload; begin writeIntegerBE(st, @v, 8); end;
1379
1380 procedure writeBool (st: TStream; b: Boolean); begin writeInt(st, Byte(b)); end;
1381 function readBool (st: TStream): Boolean; begin result := (readByte(st) <> 0); end;
1382
1383
1384 procedure writeStr (st: TStream; const str: AnsiString; maxlen: LongWord=65535);
1385 begin
1386   if (Length(str) > maxlen) then raise XStreamError.Create('string too long');
1387   if (maxlen <= 65535) then writeInt(st, Word(Length(str))) else writeInt(st, LongWord(Length(str)));
1388   if (Length(str) > 0) then st.WriteBuffer(str[1], Length(str));
1389 end;
1390
1391 function readStr (st: TStream; maxlen: LongWord=65535): AnsiString;
1392 var
1393   len: Integer;
1394 begin
1395   result := '';
1396   if (maxlen <= 65535) then len := readWord(st) else len := Integer(readLongWord(st));
1397   if (len < 0) or (len > maxlen) then raise XStreamError.Create('string too long');
1398   if (len > 0) then
1399   begin
1400     SetLength(result, len);
1401     st.ReadBuffer(result[1], len);
1402   end;
1403 end;
1404
1405
1406 procedure readIntegerLE (st: TStream; vp: Pointer; size: Integer);
1407 {$IFDEF ENDIAN_LITTLE}
1408 begin
1409   st.readBuffer(vp^, size);
1410 end;
1411 {$ELSE}
1412 var
1413   p: PByte;
1414 begin
1415   p := PByte(vp)+size-1;
1416   while size > 0 do
1417   begin
1418     st.readBuffer(p^, 1);
1419     Dec(size);
1420     Dec(p);
1421   end;
1422 end;
1423 {$ENDIF}
1424
1425 procedure readIntegerBE (st: TStream; vp: Pointer; size: Integer);
1426 {$IFDEF ENDIAN_LITTLE}
1427 var
1428   p: PByte;
1429 begin
1430   p := PByte(vp)+size-1;
1431   while size > 0 do
1432   begin
1433     st.readBuffer(p^, 1);
1434     Dec(size);
1435     Dec(p);
1436   end;
1437 end;
1438 {$ELSE}
1439 begin
1440   st.readBuffer(vp^, size);
1441 end;
1442 {$ENDIF}
1443
1444 function readByte (st: TStream): Byte; begin readIntegerLE(st, @result, 1); end;
1445 function readShortInt (st: TStream): ShortInt; begin readIntegerLE(st, @result, 1); end;
1446 function readWord (st: TStream): Word; begin readIntegerLE(st, @result, 2); end;
1447 function readSmallInt (st: TStream): SmallInt; begin readIntegerLE(st, @result, 2); end;
1448 function readLongWord (st: TStream): LongWord; begin readIntegerLE(st, @result, 4); end;
1449 function readLongInt (st: TStream): LongInt; begin readIntegerLE(st, @result, 4); end;
1450 function readInt64 (st: TStream): Int64; begin readIntegerLE(st, @result, 8); end;
1451 function readUInt64 (st: TStream): UInt64; begin readIntegerLE(st, @result, 8); end;
1452
1453 function readByteBE (st: TStream): Byte; begin readIntegerBE(st, @result, 1); end;
1454 function readShortIntBE (st: TStream): ShortInt; begin readIntegerBE(st, @result, 1); end;
1455 function readWordBE (st: TStream): Word; begin readIntegerBE(st, @result, 2); end;
1456 function readSmallIntBE (st: TStream): SmallInt; begin readIntegerBE(st, @result, 2); end;
1457 function readLongWordBE (st: TStream): LongWord; begin readIntegerBE(st, @result, 4); end;
1458 function readLongIntBE (st: TStream): LongInt; begin readIntegerBE(st, @result, 4); end;
1459 function readInt64BE (st: TStream): Int64; begin readIntegerBE(st, @result, 8); end;
1460 function readUInt64BE (st: TStream): UInt64; begin readIntegerBE(st, @result, 8); end;
1461
1462
1463 // ////////////////////////////////////////////////////////////////////////// //
1464 function nmin (a, b: Byte): Byte; inline; overload; begin if (a < b) then result := a else result := b; end;
1465 function nmin (a, b: ShortInt): ShortInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1466 function nmin (a, b: Word): Word; inline; overload; begin if (a < b) then result := a else result := b; end;
1467 function nmin (a, b: SmallInt): SmallInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1468 function nmin (a, b: LongWord): LongWord; inline; overload; begin if (a < b) then result := a else result := b; end;
1469 function nmin (a, b: LongInt): LongInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1470 function nmin (a, b: Int64): Int64; inline; overload; begin if (a < b) then result := a else result := b; end;
1471 function nmin (a, b: UInt64): UInt64; inline; overload; begin if (a < b) then result := a else result := b; end;
1472 function nmin (a, b: Single): Single; inline; overload; begin if (a < b) then result := a else result := b; end;
1473 function nmin (a, b: Double): Double; inline; overload; begin if (a < b) then result := a else result := b; end;
1474 {$IF DEFINED(CPU386) OR DEFINED(CPUAMD64)}
1475 function nmin (a, b: Extended): Extended; inline; overload; begin if (a < b) then result := a else result := b; end;
1476 {$ENDIF}
1477
1478 function nmax (a, b: Byte): Byte; inline; overload; begin if (a > b) then result := a else result := b; end;
1479 function nmax (a, b: ShortInt): ShortInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1480 function nmax (a, b: Word): Word; inline; overload; begin if (a > b) then result := a else result := b; end;
1481 function nmax (a, b: SmallInt): SmallInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1482 function nmax (a, b: LongWord): LongWord; inline; overload; begin if (a > b) then result := a else result := b; end;
1483 function nmax (a, b: LongInt): LongInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1484 function nmax (a, b: Int64): Int64; inline; overload; begin if (a > b) then result := a else result := b; end;
1485 function nmax (a, b: UInt64): UInt64; inline; overload; begin if (a > b) then result := a else result := b; end;
1486 function nmax (a, b: Single): Single; inline; overload; begin if (a > b) then result := a else result := b; end;
1487 function nmax (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 nmax (a, b: Extended): Extended; inline; overload; begin if (a > b) then result := a else result := b; end;
1490 {$ENDIF}
1491
1492 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;
1493 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;
1494 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;
1495 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;
1496 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;
1497 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;
1498 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;
1499 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;
1500 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;
1501 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;
1502 {$IF DEFINED(CPU386) OR DEFINED(CPUAMD64)}
1503 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;
1504 {$ENDIF}
1505
1506 // ////////////////////////////////////////////////////////////////////////// //
1507 {$IFDEF WINDOWS}
1508 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'msvcrt.dll' name '_snprintf';
1509 {$ELSE}
1510 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'libc' name 'snprintf';
1511 {$ENDIF}
1512
1513
1514 (*
1515 procedure conwriter (constref buf; len: SizeUInt);
1516 var
1517   ss: ShortString;
1518   slen: Integer;
1519   b: PByte;
1520 begin
1521   if (len < 1) then exit;
1522   b := PByte(@buf);
1523   while (len > 0) do
1524   begin
1525     if (len > 255) then slen := 255 else slen := Integer(len);
1526     Move(b^, ss[1], len);
1527     ss[0] := AnsiChar(slen);
1528     write(ss);
1529     b += slen;
1530     len -= slen;
1531   end;
1532 end;
1533 *)
1534
1535
1536 function formatstrf (const fmt: AnsiString; const args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
1537 const
1538   PadSpaces: AnsiString = '                                                                       ';
1539   PadZeroes: AnsiString = '00000000000000000000000000000000000000000000000000000000000000000000000';
1540 var
1541   curarg: Integer = 0; // current arg in `args`
1542   sign, fmtch: AnsiChar;
1543   zeropad: Boolean;
1544   width, prec: Integer; // width and precision
1545   spos, epos: Integer;
1546   ch: AnsiChar;
1547   strbuf: array[0..256] of AnsiChar;
1548   strblen: SizeUInt;
1549   fmtbuf: array[0..256] of AnsiChar;
1550   fmtblen: Integer;
1551   pclen: Integer;
1552   pc: PAnsiChar;
1553   ccname: ShortString;
1554
1555   procedure writer (constref buf; len: SizeUInt);
1556   var
1557     ss: ShortString;
1558     slen: Integer;
1559     b: PByte;
1560   begin
1561     if (len < 1) then exit;
1562     b := PByte(@buf);
1563     if assigned(writerCB) then
1564     begin
1565       writerCB(b^, len);
1566     end
1567     else
1568     begin
1569       while (len > 0) do
1570       begin
1571         if (len > 255) then slen := 255 else slen := Integer(len);
1572         Move(b^, ss[1], slen);
1573         ss[0] := AnsiChar(slen);
1574         result += ss;
1575         b += slen;
1576         len -= slen;
1577       end;
1578     end;
1579   end;
1580
1581   procedure xwrite (const s: AnsiString);
1582   begin
1583     if (Length(s) > 0) then writer(PAnsiChar(s)^, Length(s));
1584   end;
1585
1586   procedure putFmtChar (ch: AnsiChar);
1587   begin
1588     fmtbuf[fmtblen] := ch;
1589     Inc(fmtblen);
1590   end;
1591
1592   procedure putFmtInt (n: Integer);
1593   var
1594     len: SizeUInt;
1595   begin
1596     len := snprintf(@fmtbuf[fmtblen], Length(fmtbuf)-fmtblen, '%d', n);
1597     if (len > 0) then Inc(fmtblen, len);
1598   end;
1599
1600   procedure buildCFormat (const pfx: AnsiString='');
1601   var
1602     f: Integer;
1603   begin
1604     fmtblen := 0;
1605     for f := 1 to Length(pfx) do putFmtChar(pfx[f]);
1606     putFmtChar('%');
1607     if (sign <> ' ') then putFmtChar(sign);
1608     if (width >= 0) then
1609     begin
1610       if (zeropad) then putFmtChar('0');
1611       putFmtInt(width);
1612       if (prec >= 0) then
1613       begin
1614         putFmtChar('.');
1615         putFmtInt(prec);
1616       end;
1617     end;
1618     putFmtChar(fmtch);
1619     fmtbuf[fmtblen] := #0;
1620   end;
1621
1622   procedure writeStrBuf ();
1623   begin
1624     if (strblen > 0) then writer(strbuf, strblen);
1625   end;
1626
1627   function i642str (n: Int64; hex: Boolean; hexup: Boolean): PAnsiChar;
1628   var
1629     neg: Boolean;
1630     xpos: Integer;
1631   begin
1632     if (n = $8000000000000000) then
1633     begin
1634       if hex then snprintf(@strbuf[0], Length(strbuf), '-8000000000000000')
1635       else snprintf(@strbuf[0], Length(strbuf), '-9223372036854775808');
1636       result := @strbuf[0];
1637     end
1638     else
1639     begin
1640       neg := (n < 0);
1641       if neg then n := -n;
1642       xpos := High(strbuf);
1643       strbuf[xpos] := #0; Dec(xpos);
1644       repeat
1645         if not hex then
1646         begin
1647           strbuf[xpos] := AnsiChar((n mod 10)+48);
1648           Dec(xpos);
1649           n := n div 10;
1650         end
1651         else
1652         begin
1653           if (n mod 16 > 9) then
1654           begin
1655             strbuf[xpos] := AnsiChar((n mod 16)+48+7);
1656             if not hexup then Inc(strbuf[xpos], 32);
1657           end
1658           else strbuf[xpos] := AnsiChar((n mod 16)+48);
1659           Dec(xpos);
1660           n := n div 16;
1661         end;
1662       until (n = 0);
1663       if neg then begin strbuf[xpos] := '-'; Dec(xpos); end;
1664       result := @strbuf[xpos+1];
1665     end;
1666   end;
1667
1668   function ui642str (n: UInt64; hex: Boolean; hexup: Boolean): PAnsiChar;
1669   var
1670     xpos: Integer;
1671   begin
1672     xpos := High(strbuf);
1673     strbuf[xpos] := #0; Dec(xpos);
1674     repeat
1675       if not hex then
1676       begin
1677         strbuf[xpos] := AnsiChar((n mod 10)+48);
1678         Dec(xpos);
1679         n := n div 10;
1680       end
1681       else
1682       begin
1683         if (n mod 16 > 9) then
1684         begin
1685           strbuf[xpos] := AnsiChar((n mod 16)+48+7);
1686           if not hexup then Inc(strbuf[xpos], 32);
1687         end
1688         else strbuf[xpos] := AnsiChar((n mod 16)+48);
1689         Dec(xpos);
1690         n := n div 16;
1691       end;
1692     until (n = 0);
1693     result := @strbuf[xpos+1];
1694   end;
1695
1696   procedure indent (len: Integer);
1697   var
1698     ilen: Integer;
1699   begin
1700     while (len > 0) do
1701     begin
1702       if (len > Length(PadSpaces)) then ilen := Length(PadSpaces) else ilen := len;
1703       writer(PAnsiChar(PadSpaces)^, ilen);
1704       Dec(len, ilen);
1705     end;
1706   end;
1707
1708   procedure indent0 (len: Integer);
1709   var
1710     ilen: Integer;
1711   begin
1712     while (len > 0) do
1713     begin
1714       if (len > Length(PadZeroes)) then ilen := Length(PadZeroes) else ilen := len;
1715       writer(PAnsiChar(PadZeroes)^, ilen);
1716       Dec(len, ilen);
1717     end;
1718   end;
1719
1720 begin
1721   result := '';
1722   spos := 1;
1723   while (spos <= Length(fmt)) do
1724   begin
1725     // print literal part
1726     epos := spos;
1727     while (epos <= Length(fmt)) and (fmt[epos] <> '%') do Inc(epos);
1728     // output literal part
1729     if (epos > spos) then
1730     begin
1731       if (epos > Length(fmt)) then
1732       begin
1733         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
1734         break;
1735       end;
1736            if (epos+1 > Length(fmt)) then Inc(epos) // last percent, output literally
1737       else if (fmt[epos+1] = '%') then // special case
1738       begin
1739         Inc(epos);
1740         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
1741         spos := epos+1;
1742       end
1743       else
1744       begin
1745         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
1746         spos := epos;
1747       end;
1748       continue;
1749     end;
1750     // check if we have argument for this format string
1751     if (curarg > High(args)) then
1752     begin
1753       xwrite('<OUT OF ARGS>');
1754       writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1755       break;
1756     end;
1757     // skip percent
1758     if (spos+1 > Length(fmt)) then break; // oops
1759     assert(fmt[spos] = '%');
1760     Inc(spos);
1761     // parse format; check for sign
1762          if (fmt[spos] = '-') then begin sign := '-'; Inc(spos); end
1763     else if (fmt[spos] = '+') then begin sign := '+'; Inc(spos); end
1764     else sign := ' ';
1765     // parse width
1766     if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
1767     if (sign <> ' ') or ((fmt[spos] >= '0') and (fmt[spos] <= '9')) then
1768     begin
1769       if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1770       zeropad := (fmt[spos] = '0');
1771       width := 0;
1772       while (spos <= Length(fmt)) do
1773       begin
1774         ch := fmt[spos];
1775         if (ch < '0') or (ch > '9') then break;
1776         width := width*10+Integer(ch)-48;
1777         Inc(spos);
1778       end;
1779     end
1780     else
1781     begin
1782       width := -1;
1783       zeropad := false;
1784     end;
1785     // parse precision
1786     prec := -1;
1787     if (spos <= Length(fmt)) and (fmt[spos] = '.') then
1788     begin
1789       Inc(spos);
1790       if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
1791       if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1792       prec := 0;
1793       while (spos <= Length(fmt)) do
1794       begin
1795         ch := fmt[spos];
1796         if (ch < '0') or (ch > '9') then break;
1797         prec := prec*10+Integer(ch)-48;
1798         Inc(spos);
1799       end;
1800     end;
1801     // get format char
1802     if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
1803     fmtch := fmt[spos];
1804     Inc(spos);
1805     // done parsing format, check for valid format chars
1806     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;
1807     // now write formatted string
1808     case args[curarg].VType of
1809       vtInteger: // args[curarg].VInteger
1810         begin
1811           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;
1812           if (fmtch = 's') then fmtch := 'd';
1813           buildCFormat();
1814           strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], args[curarg].VInteger);
1815           writeStrBuf();
1816         end;
1817       vtBoolean: // args[curarg].VBoolean
1818         case fmtch of
1819           's':
1820             begin
1821               buildCFormat();
1822               if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'true')
1823               else strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'false');
1824               writeStrBuf();
1825             end;
1826           'c':
1827             begin
1828               buildCFormat();
1829               if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('t'))
1830               else strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('f'));
1831               writeStrBuf();
1832             end;
1833           'u', 'd', 'x', 'X':
1834             begin
1835               buildCFormat();
1836               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(args[curarg].VBoolean));
1837               writeStrBuf();
1838             end;
1839           else
1840             begin
1841               xwrite('<INVALID FORMAT CHAR>');
1842               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1843               break;
1844             end;
1845         end;
1846       vtChar: // args[curarg].VChar
1847         case fmtch of
1848           's', 'c':
1849             begin
1850               fmtch := 'c';
1851               buildCFormat();
1852               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], args[curarg].VChar);
1853               writeStrBuf();
1854             end;
1855           'u', 'd', 'x', 'X':
1856             begin
1857               buildCFormat();
1858               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(args[curarg].VChar));
1859               writeStrBuf();
1860             end;
1861           else
1862             begin
1863               xwrite('<INVALID FORMAT CHAR>');
1864               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1865               break;
1866             end;
1867         end;
1868       //vtWideChar: begin end; // args[curarg].VWideChar (WideChar)
1869       vtExtended: // args[curarg].VExtended^
1870         case fmtch of
1871           's', 'g':
1872             begin
1873               fmtch := 'g';
1874               buildCFormat();
1875               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Double(args[curarg].VExtended^));
1876               writeStrBuf();
1877             end;
1878           'f':
1879             begin
1880               buildCFormat();
1881               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Double(args[curarg].VExtended^));
1882               writeStrBuf();
1883             end;
1884           'd':
1885             begin
1886               buildCFormat();
1887               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(trunc(args[curarg].VExtended^)));
1888               writeStrBuf();
1889             end;
1890           'u', 'x', 'X':
1891             begin
1892               buildCFormat();
1893               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], LongWord(trunc(args[curarg].VExtended^)));
1894               writeStrBuf();
1895             end;
1896           else
1897             begin
1898               xwrite('<INVALID FORMAT CHAR>');
1899               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1900               break;
1901             end;
1902         end;
1903       vtString: // args[curarg].VString^ (PShortString)
1904         begin
1905           if (sign <> '-') then indent(width-Length(args[curarg].VString^));
1906           writer(args[curarg].VString^[1], Length(args[curarg].VString^));
1907           if (sign = '-') then indent(width-Length(args[curarg].VString^));
1908         end;
1909       vtPointer: // args[curarg].VPointer
1910         case fmtch of
1911           's':
1912             begin
1913               fmtch := 'x';
1914               if (width < 8) then width := 8;
1915               zeropad := true;
1916               buildCFormat('0x');
1917               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], PtrUInt(args[curarg].VPointer));
1918               writeStrBuf();
1919             end;
1920           'u', 'd', 'x', 'p', 'X':
1921             begin
1922               if (fmtch = 'p') then fmtch := 'x';
1923               if (width < 8) then width := 8;
1924               zeropad := true;
1925               buildCFormat('0x');
1926               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], PtrUInt(args[curarg].VPointer));
1927               writeStrBuf();
1928             end;
1929           else
1930             begin
1931               xwrite('<INVALID FORMAT CHAR>');
1932               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1933               break;
1934             end;
1935         end;
1936       vtPChar: // args[curarg].VPChar
1937         if (args[curarg].VPChar = nil) then
1938         begin
1939           if (sign <> '-') then indent(width-3);
1940           xwrite('nil');
1941           if (sign = '-') then indent(width-3);
1942         end
1943         else
1944         begin
1945           pclen := 0;
1946           while (args[curarg].VPChar[pclen] <> #0) do Inc(pclen);
1947           if (sign <> '-') then indent(width-pclen);
1948           writer(args[curarg].VPChar^, pclen);
1949           if (sign = '-') then indent(width-pclen);
1950         end;
1951       vtObject: // args[curarg].VObject.Classname (TObject)
1952         begin
1953           if (args[curarg].VObject <> nil) then ccname := args[curarg].VObject.Classname else ccname := '<nil>';
1954           if (sign <> '-') then indent(width-Length(ccname));
1955           xwrite(ccname);
1956           if (sign = '-') then indent(width-Length(ccname));
1957         end;
1958       vtClass: // args[curarg].VClass.Classname (TClass)
1959         begin
1960           if (args[curarg].VClass <> nil) then ccname := args[curarg].VClass.Classname else ccname := '<nil>';
1961           if (sign <> '-') then indent(width-Length(ccname));
1962           xwrite(ccname);
1963           if (sign = '-') then indent(width-Length(ccname));
1964         end;
1965       //vtPWideChar: begin end; // args[curarg].VPWideChar (PWideChar)
1966       vtAnsiString: // AnsiString(args[curarg].VAnsiString) (Pointer)
1967         begin
1968           if (sign <> '-') then indent(width-Length(AnsiString(args[curarg].VAnsiString)));
1969           xwrite(AnsiString(args[curarg].VAnsiString));
1970           if (sign = '-') then indent(width-Length(AnsiString(args[curarg].VAnsiString)));
1971         end;
1972       //vtCurrency: begin end; // args[curarg].VCurrency (PCurrency)
1973       //vtVariant: begin end; // args[curarg].VVariant^ (PVariant)
1974       //vtInterface: begin end; // args[curarg].VInterface (Pointer);
1975       //vtWideString: begin end; // args[curarg].VWideString (Pointer);
1976       vtInt64: // args[curarg].VInt64^ (PInt64)
1977         begin
1978           case fmtch of
1979             's','d','u': pc := i642str(args[curarg].VInt64^, false, false);
1980             'x': pc := i642str(args[curarg].VInt64^, true, false);
1981             'X': pc := i642str(args[curarg].VInt64^, true, true);
1982             else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1983           end;
1984           pclen := 0;
1985           while (pc[pclen] <> #0) do Inc(pclen);
1986           if (sign <> '-') and (width > pclen) then
1987           begin
1988             if zeropad then
1989             begin
1990               if (pc[0] = '-') or (pc[0] = '+') then
1991               begin
1992                 writer(pc^, 1);
1993                 indent0(width-pclen-1);
1994                 Inc(pc);
1995                 Dec(pclen);
1996               end
1997               else
1998               begin
1999                 indent0(width-pclen);
2000               end;
2001             end
2002             else
2003             begin
2004               indent(width-pclen);
2005             end;
2006           end;
2007           writer(pc^, pclen);
2008           if (sign = '-') then indent(width-pclen);
2009         end;
2010       vtQWord: // args[curarg].VQWord^ (PQWord)
2011         begin
2012           case fmtch of
2013             's','d','u': pc := ui642str(args[curarg].VInt64^, false, false);
2014             'x': pc := ui642str(args[curarg].VInt64^, true, false);
2015             'X': pc := ui642str(args[curarg].VInt64^, true, true);
2016             else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
2017           end;
2018           pclen := 0;
2019           while (pc[pclen] <> #0) do Inc(pclen);
2020           if (sign <> '-') then begin if zeropad then indent0(width-pclen) else indent(width-pclen); end;
2021           writer(pc^, pclen);
2022           if (sign = '-') then indent(width-pclen);
2023         end;
2024       else
2025         begin
2026           xwrite('<INVALID TYPE>');
2027           writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
2028           break;
2029         end;
2030     end;
2031     Inc(curarg);
2032   end;
2033 end;
2034
2035
2036 function GetDiskFileInfo (fname: AnsiString; var info: TDiskFileInfo): Boolean;
2037 var
2038   age: LongInt;
2039   size: LongInt;
2040   handle: THandle;
2041 begin
2042   result := false;
2043   if (length(fname) = 0) then exit;
2044   if not findFileCI(fname) then exit;
2045   // get age
2046   age := FileAge(fname);
2047   if (age = -1) then exit;
2048   // get size
2049   handle := FileOpen(fname, fmOpenRead or fmShareDenyNone);
2050   if (handle = THandle(-1)) then exit;
2051   size := FileSeek(handle, 0, fsFromEnd);
2052   FileClose(handle);
2053   if (size = -1) then exit;
2054   // fill info
2055   info.diskName := fname;
2056   info.size := size;
2057   info.age := age;
2058   result := true;
2059 end;
2060
2061
2062 (*
2063 var
2064   ss: ShortString;
2065   ls: AnsiString;
2066   i64: Int64 = -$A000000000;
2067   ui64: UInt64 = $A000000000;
2068 begin
2069   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']);
2070   writef(conwriter, 'test float:<%s;%u;%f;%g>'#10, [666.6942, 666.6942, 666.6942, 666.6942]);
2071   ss := 'fuckit';
2072   ls := 'FUCKIT';
2073   writef(conwriter, 'test ss:<%5s;%040s>'#10, [ss, ss]);
2074   writef(conwriter, 'test ls:<%5s;%040s>'#10, [ls, ls]);
2075   writef(conwriter, 'test pointer:<%s;%x;%p>'#10, [@ss, @ss, @ss]);
2076   writef(conwriter, 'test i64:<%s;%x;%015d;%u;%X>'#10, [i64, i64, i64, i64, i64]);
2077   writef(conwriter, 'test ui64:<%s;%x;%15d;%015u;%X>'#10, [ui64, ui64, ui64, ui64, ui64]);
2078 *)
2079 end.