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, either version 3 of the License, or
   6  * (at your option) any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15  *)
  16 {$INCLUDE a_modes.inc}
  17 unit utils;
  18
  19 interface
  20
  21 uses
  22   SysUtils, Classes;
  23
  24
  25 // ////////////////////////////////////////////////////////////////////////// //
  26 type
  27   TUtf8DecoderFast = packed record
  28   public
  29     const Replacement = $FFFD; // replacement char for invalid unicode
  30     const Accept = 0;
  31     const Reject = 12;
  32
  33   private
  34     state: LongWord;
  35
  36   public
  37     codepoint: LongWord; // decoded codepoint (valid only when decoder is in "complete" state)
  38
  39   public
  40     constructor Create (v: Boolean{fuck you, fpc});
  41
  42     procedure reset (); inline;
  43
  44     function complete (): Boolean; inline; // is current character complete? take `codepoint` then
  45     function invalid (): Boolean; inline;
  46     function completeOrInvalid (): Boolean; inline;
  47
  48     // process one byte, return `true` if codepoint is ready
  49     function decode (b: Byte): Boolean; inline; overload;
  50     function decode (c: AnsiChar): Boolean; inline; overload;
  51   end;
  52
  53
  54 // ////////////////////////////////////////////////////////////////////////// //
  55 // does filename have one of ".wad", ".pk3", ".zip" extensions?
  56 function hasWadExtension (fn: AnsiString): Boolean;
  57
  58 // does filepath have ".XXX:\" in it?
  59 function isWadPath (fn: AnsiString): Boolean;
  60
  61 // adds ".wad" extension if filename doesn't have one of ".wad", ".pk3", ".zip"
  62 function addWadExtension (fn: AnsiString): AnsiString;
  63
  64 // convert number to strig with nice commas
  65 function Int64ToStrComma (i: Int64): AnsiString;
  66
  67 function UpCase1251 (ch: Char): Char;
  68 function LoCase1251 (ch: Char): Char;
  69
  70 // `true` if strings are equal; ignoring case for cp1251
  71 function StrEquCI1251 (const s0, s1: AnsiString): Boolean;
  72
  73 function utf8Valid (const s: AnsiString): Boolean;
  74
  75 function utf8to1251 (s: AnsiString): AnsiString;
  76
  77 // `pathname` will be modified if path is valid
  78 // `lastIsDir` should be `true` if we are searching for directory
  79 // nobody cares about shitdoze, so i'll use the same code path for it
  80 function findFileCI (var pathname: AnsiString; lastIsDir: Boolean=false): Boolean;
  81
  82 // they throws
  83 function openDiskFileRO (pathname: AnsiString): TStream;
  84 function createDiskFile (pathname: AnsiString): TStream;
  85
  86 // little endian
  87 procedure writeInt (st: TStream; v: Byte); overload;
  88 procedure writeInt (st: TStream; v: ShortInt); overload;
  89 procedure writeInt (st: TStream; v: Word); overload;
  90 procedure writeInt (st: TStream; v: SmallInt); overload;
  91 procedure writeInt (st: TStream; v: LongWord); overload;
  92 procedure writeInt (st: TStream; v: LongInt); overload;
  93 procedure writeInt (st: TStream; v: Int64); overload;
  94 procedure writeInt (st: TStream; v: UInt64); overload;
  95
  96 function readByte (st: TStream): Byte;
  97 function readShortInt (st: TStream): ShortInt;
  98 function readWord (st: TStream): Word;
  99 function readSmallInt (st: TStream): SmallInt;
 100 function readLongWord (st: TStream): LongWord;
 101 function readLongInt (st: TStream): LongInt;
 102 function readInt64 (st: TStream): Int64;
 103 function readUInt64 (st: TStream): UInt64;
 104
 105 // big endian
 106 procedure writeIntBE (st: TStream; v: Byte); overload;
 107 procedure writeIntBE (st: TStream; v: ShortInt); overload;
 108 procedure writeIntBE (st: TStream; v: Word); overload;
 109 procedure writeIntBE (st: TStream; v: SmallInt); overload;
 110 procedure writeIntBE (st: TStream; v: LongWord); overload;
 111 procedure writeIntBE (st: TStream; v: LongInt); overload;
 112 procedure writeIntBE (st: TStream; v: Int64); overload;
 113 procedure writeIntBE (st: TStream; v: UInt64); overload;
 114
 115 function readByteBE (st: TStream): Byte;
 116 function readShortIntBE (st: TStream): ShortInt;
 117 function readWordBE (st: TStream): Word;
 118 function readSmallIntBE (st: TStream): SmallInt;
 119 function readLongWordBE (st: TStream): LongWord;
 120 function readLongIntBE (st: TStream): LongInt;
 121 function readInt64BE (st: TStream): Int64;
 122 function readUInt64BE (st: TStream): UInt64;
 123
 124
 125 function nmin (a, b: Byte): Byte; inline; overload;
 126 function nmin (a, b: ShortInt): ShortInt; inline; overload;
 127 function nmin (a, b: Word): Word; inline; overload;
 128 function nmin (a, b: SmallInt): SmallInt; inline; overload;
 129 function nmin (a, b: LongWord): LongWord; inline; overload;
 130 function nmin (a, b: LongInt): LongInt; inline; overload;
 131 function nmin (a, b: Int64): Int64; inline; overload;
 132 function nmin (a, b: UInt64): UInt64; inline; overload;
 133 function nmin (a, b: Single): Single; inline; overload;
 134 function nmin (a, b: Double): Double; inline; overload;
 135 function nmin (a, b: Extended): Extended; inline; overload;
 136
 137 function nmax (a, b: Byte): Byte; inline; overload;
 138 function nmax (a, b: ShortInt): ShortInt; inline; overload;
 139 function nmax (a, b: Word): Word; inline; overload;
 140 function nmax (a, b: SmallInt): SmallInt; inline; overload;
 141 function nmax (a, b: LongWord): LongWord; inline; overload;
 142 function nmax (a, b: LongInt): LongInt; inline; overload;
 143 function nmax (a, b: Int64): Int64; inline; overload;
 144 function nmax (a, b: UInt64): UInt64; inline; overload;
 145 function nmax (a, b: Single): Single; inline; overload;
 146 function nmax (a, b: Double): Double; inline; overload;
 147 function nmax (a, b: Extended): Extended; inline; overload;
 148
 149 function nclamp (v, a, b: Byte): Byte; inline; overload;
 150 function nclamp (v, a, b: ShortInt): ShortInt; inline; overload;
 151 function nclamp (v, a, b: Word): Word; inline; overload;
 152 function nclamp (v, a, b: SmallInt): SmallInt; inline; overload;
 153 function nclamp (v, a, b: LongWord): LongWord; inline; overload;
 154 function nclamp (v, a, b: LongInt): LongInt; inline; overload;
 155 function nclamp (v, a, b: Int64): Int64; inline; overload;
 156 function nclamp (v, a, b: UInt64): UInt64; inline; overload;
 157 function nclamp (v, a, b: Single): Single; inline; overload;
 158 function nclamp (v, a, b: Double): Double; inline; overload;
 159 function nclamp (v, a, b: Extended): Extended; inline; overload;
 160
 161
 162 type
 163   TFormatStrFCallback = procedure (constref buf; len: SizeUInt);
 164
 165 // returns formatted string if `writerCB` is `nil`, empty string otherwise
 166 function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
 167
 168 function wchar2win (wc: WideChar): AnsiChar; inline;
 169 function utf2win (const s: AnsiString): AnsiString;
 170 function win2utf (const s: AnsiString): AnsiString;
 171 function digitInBase (ch: AnsiChar; base: Integer): Integer;
 172
 173 // returns string in single or double quotes
 174 // single quotes supports only pascal-style '' for single quote char
 175 // double quotes supports c-style escapes
 176 // function will select quote mode automatically
 177 function quoteStr (const s: AnsiString): AnsiString;
 178
 179
 180 type
 181   generic TSimpleList<ItemT> = class
 182   private
 183     //type PItemT = ^ItemT;
 184     type TItemArr = array of ItemT;
 185
 186   public
 187     type
 188       TEnumerator = record
 189       private
 190         mItems: TItemArr;
 191         mCount: Integer;
 192         mCurrent: Integer;
 193       public
 194         constructor Create (const aitems: TItemArr; acount: Integer);
 195         function MoveNext: Boolean;
 196         function getCurrent (): ItemT;
 197         property Current: ItemT read getCurrent;
 198       end;
 199
 200   private
 201     mItems: TItemArr;
 202     mCount: Integer; // can be less than `mItems` size
 203
 204   private
 205     function getAt (idx: Integer): ItemT; inline;
 206     procedure setAt (idx: Integer; const it: ItemT); inline;
 207
 208     function getCapacity (): Integer; inline;
 209     procedure setCapacity (v: Integer); inline;
 210
 211   public
 212     constructor Create (acapacity: Integer=-1);
 213     destructor Destroy (); override;
 214
 215     //WARNING! don't change list contents in `for ... in`!
 216     function GetEnumerator (): TEnumerator;
 217
 218     procedure reset (); inline; // won't resize `mItems`
 219     procedure clear (); inline;
 220
 221     procedure append (constref it: ItemT); inline;
 222
 223   public
 224     property count: Integer read mCount;
 225     property capacity: Integer read getCapacity write setCapacity;
 226     property at[idx: Integer]: ItemT read getAt write setAt; default;
 227   end;
 228
 229
 230 implementation
 231
 232
 233 // ////////////////////////////////////////////////////////////////////////// //
 234 constructor TSimpleList.TEnumerator.Create (const aitems: TItemArr; acount: Integer);
 235 begin
 236   mItems := aitems;
 237   mCurrent := -1;
 238   mCount := acount;
 239 end;
 240
 241 function TSimpleList.TEnumerator.MoveNext: Boolean;
 242 begin
 243   Inc(mCurrent);
 244   result := (mCurrent < mCount);
 245 end;
 246
 247 function TSimpleList.TEnumerator.getCurrent (): ItemT;
 248 begin
 249   result := mItems[mCurrent];
 250 end;
 251
 252
 253 // ////////////////////////////////////////////////////////////////////////// //
 254 constructor TSimpleList.Create (acapacity: Integer=-1);
 255 begin
 256   mItems := nil;
 257   if (acapacity > 0) then SetLength(mItems, acapacity);
 258   mCount := 0;
 259 end;
 260
 261
 262 destructor TSimpleList.Destroy ();
 263 begin
 264   mItems := nil;
 265   inherited;
 266 end;
 267
 268
 269 function TSimpleList.getCapacity (): Integer; inline;
 270 begin
 271   result := Length(mItems);
 272 end;
 273
 274
 275 procedure TSimpleList.setCapacity (v: Integer); inline;
 276 begin
 277   if (v < mCount) then v := mCount;
 278   if (v <> Length(mItems)) then SetLength(mItems, v);
 279 end;
 280
 281
 282 function TSimpleList.GetEnumerator (): TEnumerator;
 283 begin
 284   if (Length(mItems) > 0) then result := TEnumerator.Create(mItems, mCount)
 285   else result := TEnumerator.Create(nil, -1);
 286 end;
 287
 288
 289 procedure TSimpleList.reset (); inline;
 290 begin
 291   mCount := 0;
 292 end;
 293
 294
 295 procedure TSimpleList.clear (); inline;
 296 begin
 297   mItems := nil;
 298   mCount := 0;
 299 end;
 300
 301
 302 function TSimpleList.getAt (idx: Integer): ItemT; inline;
 303 begin
 304   if (idx >= 0) and (idx < mCount) then result := mItems[idx] else result := Default(ItemT);
 305 end;
 306
 307
 308 procedure TSimpleList.setAt (idx: Integer; const it: ItemT); inline;
 309 begin
 310   if (idx >= 0) and (idx < mCount) then mItems[idx] := it;
 311 end;
 312
 313
 314 procedure TSimpleList.append (constref it: ItemT); inline;
 315 begin
 316   if (mCount = Length(mItems)) then
 317   begin
 318     if (mCount = 0) then SetLength(mItems, 128) else SetLength(mItems, mCount*2);
 319   end;
 320   mItems[mCount] := it;
 321   Inc(mCount);
 322 end;
 323
 324
 325 // ////////////////////////////////////////////////////////////////////////// //
 326 var
 327   wc2shitmap: array[0..65535] of AnsiChar;
 328   wc2shitmapInited: Boolean = false;
 329
 330
 331 // ////////////////////////////////////////////////////////////////////////// //
 332 const
 333   cp1251: array[0..127] of Word = (
 334     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
 335     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
 336     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
 337     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
 338     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
 339     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
 340     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
 341     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
 342   );
 343
 344
 345 procedure initShitMap ();
 346 var
 347   f: Integer;
 348 begin
 349   for f := 0 to High(wc2shitmap) do wc2shitmap[f] := '?';
 350   for f := 0 to 127 do wc2shitmap[f] := AnsiChar(f);
 351   for f := 0 to 127 do wc2shitmap[cp1251[f]] := AnsiChar(f+128);
 352   wc2shitmapInited := true;
 353 end;
 354
 355
 356 // ////////////////////////////////////////////////////////////////////////// //
 357 // fast state-machine based UTF-8 decoder; using 8 bytes of memory
 358 // code points from invalid range will never be valid, this is the property of the state machine
 359 const
 360   // see http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
 361   utf8dfa: array[0..$16c-1] of Byte = (
 362     // maps bytes to character classes
 363     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 00-0f
 364     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 10-1f
 365     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 20-2f
 366     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 30-3f
 367     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 40-4f
 368     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 50-5f
 369     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 60-6f
 370     $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00, // 70-7f
 371     $01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01, // 80-8f
 372     $09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09,$09, // 90-9f
 373     $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07, // a0-af
 374     $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07, // b0-bf
 375     $08,$08,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02, // c0-cf
 376     $02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02, // d0-df
 377     $0a,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$04,$03,$03, // e0-ef
 378     $0b,$06,$06,$06,$05,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08, // f0-ff
 379     // maps a combination of a state of the automaton and a character class to a state
 380     $00,$0c,$18,$24,$3c,$60,$54,$0c,$0c,$0c,$30,$48,$0c,$0c,$0c,$0c, // 100-10f
 381     $0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$00,$0c,$0c,$0c,$0c,$0c,$00, // 110-11f
 382     $0c,$00,$0c,$0c,$0c,$18,$0c,$0c,$0c,$0c,$0c,$18,$0c,$18,$0c,$0c, // 120-12f
 383     $0c,$0c,$0c,$0c,$0c,$0c,$0c,$18,$0c,$0c,$0c,$0c,$0c,$18,$0c,$0c, // 130-13f
 384     $0c,$0c,$0c,$0c,$0c,$18,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$24, // 140-14f
 385     $0c,$24,$0c,$0c,$0c,$24,$0c,$0c,$0c,$0c,$0c,$24,$0c,$24,$0c,$0c, // 150-15f
 386     $0c,$24,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c,$0c);
 387
 388
 389 // ////////////////////////////////////////////////////////////////////////// //
 390 constructor TUtf8DecoderFast.Create (v: Boolean{fuck you, fpc}); begin state := Accept; codepoint := 0; end;
 391
 392 procedure TUtf8DecoderFast.reset (); inline; begin state := Accept; codepoint := 0; end;
 393
 394 function TUtf8DecoderFast.complete (): Boolean; inline; begin result := (state = Accept); end;
 395 function TUtf8DecoderFast.invalid (): Boolean; inline; begin result := (state = Reject); end;
 396 function TUtf8DecoderFast.completeOrInvalid (): Boolean; inline; begin result := (state = Accept) or (state = Reject); end;
 397
 398 function TUtf8DecoderFast.decode (c: AnsiChar): Boolean; inline; overload; begin result := decode(Byte(c)); end;
 399
 400 function TUtf8DecoderFast.decode (b: Byte): Boolean; inline; overload;
 401 var
 402   tp: LongWord;
 403 begin
 404   if (state = Reject) then begin state := Accept; codepoint := 0; end;
 405   tp := utf8dfa[b];
 406   if (state <> Accept) then codepoint := (b and $3f) or (codepoint shl 6) else codepoint := ($ff shr tp) and b;
 407   state := utf8dfa[256+state+tp];
 408   if (state = Reject) then begin codepoint := Replacement; state := Accept; end;
 409   result := (state = Accept);
 410 end;
 411
 412
 413 // ////////////////////////////////////////////////////////////////////////// //
 414 function wchar2win (wc: WideChar): AnsiChar; inline;
 415 begin
 416   if not wc2shitmapInited then initShitMap();
 417   if (LongWord(wc) > 65535) then result := '?' else result := wc2shitmap[LongWord(wc)];
 418 end;
 419
 420
 421 // ////////////////////////////////////////////////////////////////////////// //
 422 function utf2win (const s: AnsiString): AnsiString;
 423 var
 424   f, c: Integer;
 425   ud: TUtf8DecoderFast;
 426 begin
 427   for f := 1 to Length(s) do
 428   begin
 429     if (Byte(s[f]) > 127) then
 430     begin
 431       ud := TUtf8DecoderFast.Create(true);
 432       result := '';
 433       for c := 1 to Length(s) do
 434       begin
 435         if ud.decode(s[c]) then result += wchar2win(WideChar(ud.codepoint));
 436       end;
 437       exit;
 438     end;
 439   end;
 440   result := s;
 441 end;
 442
 443
 444 function win2utf (const s: AnsiString): AnsiString;
 445 var
 446   f, c: Integer;
 447
 448   function utf8Encode (code: Integer): AnsiString;
 449   begin
 450     if (code < 0) or (code > $10FFFF) then begin result := '?'; exit; end;
 451     if (code <= $7f) then
 452     begin
 453       result := Char(code and $ff);
 454     end
 455     else if (code <= $7FF) then
 456     begin
 457       result := Char($C0 or (code shr 6));
 458       result += Char($80 or (code and $3F));
 459     end
 460     else if (code <= $FFFF) then
 461     begin
 462       result := Char($E0 or (code shr 12));
 463       result += Char($80 or ((code shr 6) and $3F));
 464       result += Char($80 or (code and $3F));
 465     end
 466     else if (code <= $10FFFF) then
 467     begin
 468       result := Char($F0 or (code shr 18));
 469       result += Char($80 or ((code shr 12) and $3F));
 470       result += Char($80 or ((code shr 6) and $3F));
 471       result += Char($80 or (code and $3F));
 472     end
 473     else
 474     begin
 475       result := '?';
 476     end;
 477   end;
 478
 479 begin
 480   for f := 1 to Length(s) do
 481   begin
 482     if (Byte(s[f]) > 127) then
 483     begin
 484       result := '';
 485       for c := 1 to Length(s) do
 486       begin
 487         if (Byte(s[c]) < 128) then
 488         begin
 489           result += s[c];
 490         end
 491         else
 492         begin
 493           result += utf8Encode(cp1251[Byte(s[c])-128])
 494         end;
 495       end;
 496       exit;
 497     end;
 498   end;
 499   result := s;
 500 end;
 501
 502
 503 // ////////////////////////////////////////////////////////////////////////// //
 504 function digitInBase (ch: AnsiChar; base: Integer): Integer;
 505 begin
 506   result := -1;
 507   if (base < 1) or (base > 36) then exit;
 508   if (ch < '0') then exit;
 509   if (base <= 10) then
 510   begin
 511     if (Integer(ch) >= 48+base) then exit;
 512     result := Integer(ch)-48;
 513   end
 514   else
 515   begin
 516     if (ch >= '0') and (ch <= '9') then begin result := Integer(ch)-48; exit; end;
 517     if (ch >= 'a') and (ch <= 'z') then Dec(ch, 32); // poor man's tolower()
 518     if (ch < 'A') or (Integer(ch) >= 65+(base-10)) then exit;
 519     result := Integer(ch)-65+10;
 520   end;
 521 end;
 522
 523
 524 // ////////////////////////////////////////////////////////////////////////// //
 525 function quoteStr (const s: AnsiString): AnsiString;
 526
 527   function squote (const s: AnsiString): AnsiString;
 528   var
 529     f: Integer;
 530   begin
 531     result := '''';
 532     for f := 1 to Length(s) do
 533     begin
 534       if (s[f] = '''') then result += '''';
 535       result += s[f];
 536     end;
 537     result += '''';
 538   end;
 539
 540   function dquote (const s: AnsiString): AnsiString;
 541   var
 542     f: Integer;
 543     ch: AnsiChar;
 544   begin
 545     result := '"';
 546     for f := 1 to Length(s) do
 547     begin
 548       ch := s[f];
 549            if (ch = #0) then result += '\z'
 550       else if (ch = #9) then result += '\t'
 551       else if (ch = #10) then result += '\n'
 552       else if (ch = #13) then result += '\r'
 553       else if (ch = #27) then result += '\e'
 554       else if (ch < ' ') or (ch = #127) then
 555       begin
 556         result += '\x';
 557         result += LowerCase(IntToHex(Integer(ch), 2));
 558       end
 559       else if (ch = '"') or (ch = '\') then
 560       begin
 561         result += '\';
 562         result += ch;
 563       end
 564       else
 565       begin
 566         result += ch;
 567       end;
 568     end;
 569     result += '"';
 570   end;
 571
 572 var
 573   needSingle: Boolean = false;
 574   f: Integer;
 575 begin
 576   for f := 1 to Length(s) do
 577   begin
 578     if (s[f] = '''') then begin needSingle := true; continue; end;
 579     if (s[f] < ' ') or (s[f] = #127) then begin result := dquote(s); exit; end;
 580   end;
 581   if needSingle then result := squote(s) else result := ''''+s+'''';
 582 end;
 583
 584
 585 // ////////////////////////////////////////////////////////////////////////// //
 586 function hasWadExtension (fn: AnsiString): Boolean;
 587 begin
 588   fn := ExtractFileExt(fn);
 589   result := StrEquCI1251(fn, '.wad') or StrEquCI1251(fn, '.pk3') or StrEquCI1251(fn, '.zip');
 590 end;
 591
 592
 593 function addWadExtension (fn: AnsiString): AnsiString;
 594 begin
 595   result := fn;
 596   if not hasWadExtension(result) then result := result+'.wad';
 597 end;
 598
 599
 600 function isWadPath (fn: AnsiString): Boolean;
 601 var
 602   p: Integer;
 603   s: AnsiString;
 604 begin
 605   result := false;
 606   while true do
 607   begin
 608     p := Pos(':', fn);
 609     if (p = 0) or (length(fn)-p < 1) then break;
 610     if (p-4 > 1) and (fn[p-4] = '.') and ((fn[p+1] = '\') or (fn[p+1] = '/')) then
 611     begin
 612       s := Copy(fn, p-4, 4);
 613       if StrEquCI1251(s, '.wad') or StrEquCI1251(s, '.pk3') or StrEquCI1251(s, '.zip') then
 614       begin
 615         result := true;
 616         exit;
 617       end;
 618     end;
 619     Delete(fn, 1, p);
 620   end;
 621 end;
 622
 623
 624 function Int64ToStrComma (i: Int64): AnsiString;
 625 var
 626   f: Integer;
 627 begin
 628   Str(i, result);
 629   f := Length(result)+1;
 630   while f > 4 do
 631   begin
 632     Dec(f, 3); Insert(',', result, f);
 633   end;
 634 end;
 635
 636
 637 function UpCase1251 (ch: Char): Char;
 638 begin
 639   if ch < #128 then
 640   begin
 641     if (ch >= 'a') and (ch <= 'z') then Dec(ch, 32);
 642   end
 643   else
 644   begin
 645     if (ch >= #224) and (ch <= #255) then
 646     begin
 647       Dec(ch, 32);
 648     end
 649     else
 650     begin
 651       case ch of
 652         #184, #186, #191: Dec(ch, 16);
 653         #162, #179: Dec(ch);
 654       end;
 655     end;
 656   end;
 657   result := ch;
 658 end;
 659
 660
 661 function LoCase1251 (ch: Char): Char;
 662 begin
 663   if ch < #128 then
 664   begin
 665     if (ch >= 'A') and (ch <= 'Z') then Inc(ch, 32);
 666   end
 667   else
 668   begin
 669     if (ch >= #192) and (ch <= #223) then
 670     begin
 671       Inc(ch, 32);
 672     end
 673     else
 674     begin
 675       case ch of
 676         #168, #170, #175: Inc(ch, 16);
 677         #161, #178: Inc(ch);
 678       end;
 679     end;
 680   end;
 681   result := ch;
 682 end;
 683
 684
 685 function StrEquCI1251 (const s0, s1: AnsiString): Boolean;
 686 var
 687   i: Integer;
 688 begin
 689   result := false;
 690   if length(s0) <> length(s1) then exit;
 691   for i := 1 to length(s0) do if UpCase1251(s0[i]) <> UpCase1251(s1[i]) then exit;
 692   result := true;
 693 end;
 694
 695
 696 // ////////////////////////////////////////////////////////////////////////// //
 697 // utils
 698 // `ch`: utf8 start
 699 // -1: invalid utf8
 700 function utf8CodeLen (ch: Word): Integer;
 701 begin
 702   if ch < $80 then begin result := 1; exit; end;
 703   if (ch and $FE) = $FC then begin result := 6; exit; end;
 704   if (ch and $FC) = $F8 then begin result := 5; exit; end;
 705   if (ch and $F8) = $F0 then begin result := 4; exit; end;
 706   if (ch and $F0) = $E0 then begin result := 3; exit; end;
 707   if (ch and $E0) = $C0 then begin result := 2; exit; end;
 708   result := -1; // invalid
 709 end;
 710
 711
 712 function utf8Valid (const s: AnsiString): Boolean;
 713 var
 714   pos, len: Integer;
 715 begin
 716   result := false;
 717   pos := 1;
 718   while pos <= length(s) do
 719   begin
 720     len := utf8CodeLen(Byte(s[pos]));
 721     if len < 1 then exit; // invalid sequence start
 722     if pos+len-1 > length(s) then exit; // out of chars in string
 723     Dec(len);
 724     Inc(pos);
 725     // check other sequence bytes
 726     while len > 0 do
 727     begin
 728       if (Byte(s[pos]) and $C0) <> $80 then exit;
 729       Dec(len);
 730       Inc(pos);
 731     end;
 732   end;
 733   result := true;
 734 end;
 735
 736
 737 // ////////////////////////////////////////////////////////////////////////// //
 738 const
 739   uni2wint: array [128..255] of Word = (
 740     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
 741     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
 742     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
 743     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
 744     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
 745     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
 746     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
 747     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
 748   );
 749
 750
 751 function decodeUtf8Char (s: AnsiString; var pos: Integer): char;
 752 var
 753   b, c: Integer;
 754 begin
 755   (* The following encodings are valid, except for the 5 and 6 byte
 756    * combinations:
 757    *  0xxxxxxx
 758    *  110xxxxx 10xxxxxx
 759    *  1110xxxx 10xxxxxx 10xxxxxx
 760    *  11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
 761    *  111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
 762    *  1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
 763    *)
 764   result := '?';
 765   if pos > length(s) then exit;
 766
 767   b := Byte(s[pos]);
 768   Inc(pos);
 769   if b < $80 then begin result := char(b); exit; end;
 770
 771   // mask out unused bits
 772        if (b and $FE) = $FC then b := b and $01
 773   else if (b and $FC) = $F8 then b := b and $03
 774   else if (b and $F8) = $F0 then b := b and $07
 775   else if (b and $F0) = $E0 then b := b and $0F
 776   else if (b and $E0) = $C0 then b := b and $1F
 777   else exit; // invalid utf8
 778
 779   // now continue
 780   while pos <= length(s) do
 781   begin
 782     c := Byte(s[pos]);
 783     if (c and $C0) <> $80 then break; // no more
 784     b := b shl 6;
 785     b := b or (c and $3F);
 786     Inc(pos);
 787   end;
 788
 789   // done, try 1251
 790   for c := 128 to 255 do if uni2wint[c] = b then begin result := char(c and $FF); exit; end;
 791   // alas
 792 end;
 793
 794
 795 function utf8to1251 (s: AnsiString): AnsiString;
 796 var
 797   pos: Integer;
 798 begin
 799   if not utf8Valid(s) then begin result := s; exit; end;
 800   pos := 1;
 801   while pos <= length(s) do
 802   begin
 803     if Byte(s[pos]) >= $80 then break;
 804     Inc(pos);
 805   end;
 806   if pos > length(s) then begin result := s; exit; end; // nothing to do here
 807   result := '';
 808   pos := 1;
 809   while pos <= length(s) do result := result+decodeUtf8Char(s, pos);
 810 end;
 811
 812
 813 // ////////////////////////////////////////////////////////////////////////// //
 814 // `pathname` will be modified if path is valid
 815 // `lastIsDir` should be `true` if we are searching for directory
 816 // nobody cares about shitdoze, so i'll use the same code path for it
 817 function findFileCI (var pathname: AnsiString; lastIsDir: Boolean=false): Boolean;
 818 var
 819   sr: TSearchRec;
 820   npt: AnsiString;
 821   newname: AnsiString = '';
 822   curname: AnsiString;
 823   wantdir: Boolean;
 824   attr: LongInt;
 825   foundher: Boolean;
 826 begin
 827   npt := pathname;
 828   result := (length(npt) > 0);
 829   if (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) then newname := '/';
 830   while length(npt) > 0 do
 831   begin
 832     // remove trailing slashes
 833     while (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) do Delete(npt, 1, 1);
 834     if length(npt) = 0 then break;
 835     // extract name
 836     curname := '';
 837     while (length(npt) > 0) and (npt[1] <> '/') and (npt[1] <> '\') do
 838     begin
 839       curname := curname+npt[1];
 840       Delete(npt, 1, 1);
 841     end;
 842     // remove trailing slashes again
 843     while (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) do Delete(npt, 1, 1);
 844     wantdir := lastIsDir or (length(npt) > 0); // do we want directory here?
 845     //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
 846     // try the easiest case first
 847     attr := FileGetAttr(newname+curname);
 848     if attr <> -1 then
 849     begin
 850       if wantdir = ((attr and faDirectory) <> 0) then
 851       begin
 852         // i found her!
 853         newname := newname+curname;
 854         if wantdir then newname := newname+'/';
 855         continue;
 856       end;
 857     end;
 858     //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
 859     // alas, either not found, or invalid attributes
 860     foundher := false;
 861     try
 862       if FindFirst(newname+'*', faAnyFile, sr) = 0 then
 863       repeat
 864         if (wantdir = ((sr.attr and faDirectory) <> 0)) and StrEquCI1251(sr.name, curname) then
 865         begin
 866           // i found her!
 867           newname := newname+sr.name;
 868           if wantdir then newname := newname+'/';
 869           foundher := true;
 870           break;
 871         end;
 872       until FindNext(sr) <> 0;
 873     finally
 874       FindClose(sr);
 875     end;
 876     if not foundher then begin newname := ''; result := false; break; end;
 877   end;
 878   if result then pathname := newname;
 879 end;
 880
 881
 882 function openDiskFileRO (pathname: AnsiString): TStream;
 883 begin
 884   if not findFileCI(pathname) then raise Exception.Create('can''t open file "'+pathname+'"');
 885   result := TFileStream.Create(pathname, fmOpenRead or {fmShareDenyWrite}fmShareDenyNone);
 886 end;
 887
 888 function createDiskFile (pathname: AnsiString): TStream;
 889 var
 890   path: AnsiString;
 891 begin
 892   path := ExtractFilePath(pathname);
 893   if length(path) > 0 then
 894   begin
 895     if not findFileCI(path, true) then raise Exception.Create('can''t create file "'+pathname+'"');
 896   end;
 897   result := TFileStream.Create(path+ExtractFileName(pathname), fmCreate);
 898 end;
 899
 900
 901 procedure writeIntegerLE (st: TStream; vp: Pointer; size: Integer);
 902 {$IFDEF ENDIAN_LITTLE}
 903 begin
 904   st.writeBuffer(vp^, size);
 905 end;
 906 {$ELSE}
 907 var
 908   p: PByte;
 909 begin
 910   p := PByte(vp)+size-1;
 911   while size > 0 do
 912   begin
 913     st.writeBuffer(p^, 1);
 914     Dec(size);
 915     Dec(p);
 916   end;
 917 end;
 918 {$ENDIF}
 919
 920 procedure writeIntegerBE (st: TStream; vp: Pointer; size: Integer);
 921 {$IFDEF ENDIAN_LITTLE}
 922 var
 923   p: PByte;
 924 begin
 925   p := PByte(vp)+size-1;
 926   while size > 0 do
 927   begin
 928     st.writeBuffer(p^, 1);
 929     Dec(size);
 930     Dec(p);
 931   end;
 932 end;
 933 {$ELSE}
 934 begin
 935   st.writeBuffer(vp^, size);
 936 end;
 937 {$ENDIF}
 938
 939 procedure writeInt (st: TStream; v: Byte); overload; begin writeIntegerLE(st, @v, 1); end;
 940 procedure writeInt (st: TStream; v: ShortInt); overload; begin writeIntegerLE(st, @v, 1); end;
 941 procedure writeInt (st: TStream; v: Word); overload; begin writeIntegerLE(st, @v, 2); end;
 942 procedure writeInt (st: TStream; v: SmallInt); overload; begin writeIntegerLE(st, @v, 2); end;
 943 procedure writeInt (st: TStream; v: LongWord); overload; begin writeIntegerLE(st, @v, 4); end;
 944 procedure writeInt (st: TStream; v: LongInt); overload; begin writeIntegerLE(st, @v, 4); end;
 945 procedure writeInt (st: TStream; v: Int64); overload; begin writeIntegerLE(st, @v, 8); end;
 946 procedure writeInt (st: TStream; v: UInt64); overload; begin writeIntegerLE(st, @v, 8); end;
 947
 948 procedure writeIntBE (st: TStream; v: Byte); overload; begin writeIntegerBE(st, @v, 1); end;
 949 procedure writeIntBE (st: TStream; v: ShortInt); overload; begin writeIntegerBE(st, @v, 1); end;
 950 procedure writeIntBE (st: TStream; v: Word); overload; begin writeIntegerBE(st, @v, 2); end;
 951 procedure writeIntBE (st: TStream; v: SmallInt); overload; begin writeIntegerBE(st, @v, 2); end;
 952 procedure writeIntBE (st: TStream; v: LongWord); overload; begin writeIntegerBE(st, @v, 4); end;
 953 procedure writeIntBE (st: TStream; v: LongInt); overload; begin writeIntegerBE(st, @v, 4); end;
 954 procedure writeIntBE (st: TStream; v: Int64); overload; begin writeIntegerBE(st, @v, 8); end;
 955 procedure writeIntBE (st: TStream; v: UInt64); overload; begin writeIntegerBE(st, @v, 8); end;
 956
 957
 958 procedure readIntegerLE (st: TStream; vp: Pointer; size: Integer);
 959 {$IFDEF ENDIAN_LITTLE}
 960 begin
 961   st.readBuffer(vp^, size);
 962 end;
 963 {$ELSE}
 964 var
 965   p: PByte;
 966 begin
 967   p := PByte(vp)+size-1;
 968   while size > 0 do
 969   begin
 970     st.readBuffer(p^, 1);
 971     Dec(size);
 972     Dec(p);
 973   end;
 974 end;
 975 {$ENDIF}
 976
 977 procedure readIntegerBE (st: TStream; vp: Pointer; size: Integer);
 978 {$IFDEF ENDIAN_LITTLE}
 979 var
 980   p: PByte;
 981 begin
 982   p := PByte(vp)+size-1;
 983   while size > 0 do
 984   begin
 985     st.readBuffer(p^, 1);
 986     Dec(size);
 987     Dec(p);
 988   end;
 989 end;
 990 {$ELSE}
 991 begin
 992   st.readBuffer(vp^, size);
 993 end;
 994 {$ENDIF}
 995
 996 function readByte (st: TStream): Byte; begin readIntegerLE(st, @result, 1); end;
 997 function readShortInt (st: TStream): ShortInt; begin readIntegerLE(st, @result, 1); end;
 998 function readWord (st: TStream): Word; begin readIntegerLE(st, @result, 2); end;
 999 function readSmallInt (st: TStream): SmallInt; begin readIntegerLE(st, @result, 2); end;
1000 function readLongWord (st: TStream): LongWord; begin readIntegerLE(st, @result, 4); end;
1001 function readLongInt (st: TStream): LongInt; begin readIntegerLE(st, @result, 4); end;
1002 function readInt64 (st: TStream): Int64; begin readIntegerLE(st, @result, 8); end;
1003 function readUInt64 (st: TStream): UInt64; begin readIntegerLE(st, @result, 8); end;
1004
1005 function readByteBE (st: TStream): Byte; begin readIntegerBE(st, @result, 1); end;
1006 function readShortIntBE (st: TStream): ShortInt; begin readIntegerBE(st, @result, 1); end;
1007 function readWordBE (st: TStream): Word; begin readIntegerBE(st, @result, 2); end;
1008 function readSmallIntBE (st: TStream): SmallInt; begin readIntegerBE(st, @result, 2); end;
1009 function readLongWordBE (st: TStream): LongWord; begin readIntegerBE(st, @result, 4); end;
1010 function readLongIntBE (st: TStream): LongInt; begin readIntegerBE(st, @result, 4); end;
1011 function readInt64BE (st: TStream): Int64; begin readIntegerBE(st, @result, 8); end;
1012 function readUInt64BE (st: TStream): UInt64; begin readIntegerBE(st, @result, 8); end;
1013
1014
1015 // ////////////////////////////////////////////////////////////////////////// //
1016 function nmin (a, b: Byte): Byte; inline; overload; begin if (a < b) then result := a else result := b; end;
1017 function nmin (a, b: ShortInt): ShortInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1018 function nmin (a, b: Word): Word; inline; overload; begin if (a < b) then result := a else result := b; end;
1019 function nmin (a, b: SmallInt): SmallInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1020 function nmin (a, b: LongWord): LongWord; inline; overload; begin if (a < b) then result := a else result := b; end;
1021 function nmin (a, b: LongInt): LongInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1022 function nmin (a, b: Int64): Int64; inline; overload; begin if (a < b) then result := a else result := b; end;
1023 function nmin (a, b: UInt64): UInt64; inline; overload; begin if (a < b) then result := a else result := b; end;
1024 function nmin (a, b: Single): Single; inline; overload; begin if (a < b) then result := a else result := b; end;
1025 function nmin (a, b: Double): Double; inline; overload; begin if (a < b) then result := a else result := b; end;
1026 function nmin (a, b: Extended): Extended; inline; overload; begin if (a < b) then result := a else result := b; end;
1027
1028 function nmax (a, b: Byte): Byte; inline; overload; begin if (a > b) then result := a else result := b; end;
1029 function nmax (a, b: ShortInt): ShortInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1030 function nmax (a, b: Word): Word; inline; overload; begin if (a > b) then result := a else result := b; end;
1031 function nmax (a, b: SmallInt): SmallInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1032 function nmax (a, b: LongWord): LongWord; inline; overload; begin if (a > b) then result := a else result := b; end;
1033 function nmax (a, b: LongInt): LongInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1034 function nmax (a, b: Int64): Int64; inline; overload; begin if (a > b) then result := a else result := b; end;
1035 function nmax (a, b: UInt64): UInt64; inline; overload; begin if (a > b) then result := a else result := b; end;
1036 function nmax (a, b: Single): Single; inline; overload; begin if (a > b) then result := a else result := b; end;
1037 function nmax (a, b: Double): Double; inline; overload; begin if (a > b) then result := a else result := b; end;
1038 function nmax (a, b: Extended): Extended; inline; overload; begin if (a > b) then result := a else result := b; end;
1039
1040 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;
1041 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;
1042 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;
1043 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;
1044 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;
1045 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;
1046 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;
1047 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;
1048 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;
1049 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;
1050 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;
1051
1052
1053 // ////////////////////////////////////////////////////////////////////////// //
1054 {$IFDEF WINDOWS}
1055 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'msvcrt.dll' name '_snprintf';
1056 {$ELSE}
1057 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'libc' name 'snprintf';
1058 {$ENDIF}
1059
1060
1061 (*
1062 procedure conwriter (constref buf; len: SizeUInt);
1063 var
1064   ss: ShortString;
1065   slen: Integer;
1066   b: PByte;
1067 begin
1068   if (len < 1) then exit;
1069   b := PByte(@buf);
1070   while (len > 0) do
1071   begin
1072     if (len > 255) then slen := 255 else slen := Integer(len);
1073     Move(b^, ss[1], len);
1074     ss[0] := AnsiChar(slen);
1075     write(ss);
1076     b += slen;
1077     len -= slen;
1078   end;
1079 end;
1080 *)
1081
1082
1083 function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
1084 const
1085   PadSpaces: AnsiString = '                                                                       ';
1086   PadZeroes: AnsiString = '00000000000000000000000000000000000000000000000000000000000000000000000';
1087 var
1088   curarg: Integer = 0; // current arg in `args`
1089   sign, fmtch: AnsiChar;
1090   zeropad: Boolean;
1091   width, prec: Integer; // width and precision
1092   spos, epos: Integer;
1093   ch: AnsiChar;
1094   strbuf: array[0..256] of AnsiChar;
1095   strblen: SizeUInt;
1096   fmtbuf: array[0..256] of AnsiChar;
1097   fmtblen: Integer;
1098   pclen: Integer;
1099   pc: PAnsiChar;
1100
1101   procedure writer (constref buf; len: SizeUInt);
1102   var
1103     ss: ShortString;
1104     slen: Integer;
1105     b: PByte;
1106   begin
1107     if (len < 1) then exit;
1108     b := PByte(@buf);
1109     if assigned(writerCB) then
1110     begin
1111       writerCB(b^, len);
1112     end
1113     else
1114     begin
1115       while (len > 0) do
1116       begin
1117         if (len > 255) then slen := 255 else slen := Integer(len);
1118         Move(b^, ss[1], slen);
1119         ss[0] := AnsiChar(slen);
1120         result += ss;
1121         b += slen;
1122         len -= slen;
1123       end;
1124     end;
1125   end;
1126
1127   procedure xwrite (const s: AnsiString);
1128   begin
1129     if (Length(s) > 0) then writer(PAnsiChar(s)^, Length(s));
1130   end;
1131
1132   procedure putFmtChar (ch: AnsiChar);
1133   begin
1134     fmtbuf[fmtblen] := ch;
1135     Inc(fmtblen);
1136   end;
1137
1138   procedure putFmtInt (n: Integer);
1139   var
1140     len: SizeUInt;
1141   begin
1142     len := snprintf(@fmtbuf[fmtblen], Length(fmtbuf)-fmtblen, '%d', n);
1143     if (len > 0) then Inc(fmtblen, len);
1144   end;
1145
1146   procedure buildCFormat (const pfx: AnsiString='');
1147   var
1148     f: Integer;
1149   begin
1150     fmtblen := 0;
1151     for f := 1 to Length(pfx) do putFmtChar(pfx[f]);
1152     putFmtChar('%');
1153     if (sign <> ' ') then putFmtChar(sign);
1154     if (width >= 0) then
1155     begin
1156       if (zeropad) then putFmtChar('0');
1157       putFmtInt(width);
1158       if (prec >= 0) then
1159       begin
1160         putFmtChar('.');
1161         putFmtInt(prec);
1162       end;
1163     end;
1164     putFmtChar(fmtch);
1165     fmtbuf[fmtblen] := #0;
1166   end;
1167
1168   procedure writeStrBuf ();
1169   begin
1170     if (strblen > 0) then writer(strbuf, strblen);
1171   end;
1172
1173   function i642str (n: Int64; hex: Boolean; hexup: Boolean): PAnsiChar;
1174   var
1175     neg: Boolean;
1176     xpos: Integer;
1177   begin
1178     if (n = $8000000000000000) then
1179     begin
1180       if hex then snprintf(@strbuf[0], Length(strbuf), '-8000000000000000')
1181       else snprintf(@strbuf[0], Length(strbuf), '-9223372036854775808');
1182       result := @strbuf[0];
1183     end
1184     else
1185     begin
1186       neg := (n < 0);
1187       if neg then n := -n;
1188       xpos := High(strbuf);
1189       strbuf[xpos] := #0; Dec(xpos);
1190       repeat
1191         if hex then
1192         begin
1193           strbuf[xpos] := AnsiChar((n mod 10)+48);
1194           Dec(xpos);
1195           n := n div 10;
1196         end
1197         else
1198         begin
1199           if (n mod 16 > 9) then
1200           begin
1201             strbuf[xpos] := AnsiChar((n mod 16)+48+7);
1202             if not hexup then Inc(strbuf[xpos], 32);
1203           end
1204           else strbuf[xpos] := AnsiChar((n mod 16)+48);
1205           Dec(xpos);
1206           n := n div 16;
1207         end;
1208       until (n = 0);
1209       if neg then begin strbuf[xpos] := '-'; Dec(xpos); end;
1210       result := @strbuf[xpos+1];
1211     end;
1212   end;
1213
1214   function ui642str (n: UInt64; hex: Boolean; hexup: Boolean): PAnsiChar;
1215   var
1216     xpos: Integer;
1217   begin
1218     xpos := High(strbuf);
1219     strbuf[xpos] := #0; Dec(xpos);
1220     repeat
1221       if hex then
1222       begin
1223         strbuf[xpos] := AnsiChar((n mod 10)+48);
1224         Dec(xpos);
1225         n := n div 10;
1226       end
1227       else
1228       begin
1229         if (n mod 16 > 9) then
1230         begin
1231           strbuf[xpos] := AnsiChar((n mod 16)+48+7);
1232           if not hexup then Inc(strbuf[xpos], 32);
1233         end
1234         else strbuf[xpos] := AnsiChar((n mod 16)+48);
1235         Dec(xpos);
1236         n := n div 16;
1237       end;
1238     until (n = 0);
1239     result := @strbuf[xpos+1];
1240   end;
1241
1242   procedure indent (len: Integer);
1243   var
1244     ilen: Integer;
1245   begin
1246     while (len > 0) do
1247     begin
1248       if (len > Length(PadSpaces)) then ilen := Length(PadSpaces) else ilen := len;
1249       writer(PAnsiChar(PadSpaces)^, ilen);
1250       Dec(len, ilen);
1251     end;
1252   end;
1253
1254   procedure indent0 (len: Integer);
1255   var
1256     ilen: Integer;
1257   begin
1258     while (len > 0) do
1259     begin
1260       if (len > Length(PadZeroes)) then ilen := Length(PadZeroes) else ilen := len;
1261       writer(PAnsiChar(PadZeroes)^, ilen);
1262       Dec(len, ilen);
1263     end;
1264   end;
1265
1266 begin
1267   result := '';
1268   spos := 1;
1269   while (spos <= Length(fmt)) do
1270   begin
1271     // print literal part
1272     epos := spos;
1273     while (epos <= Length(fmt)) and (fmt[epos] <> '%') do Inc(epos);
1274     // output literal part
1275     if (epos > spos) then
1276     begin
1277       if (epos > Length(fmt)) then
1278       begin
1279         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
1280         break;
1281       end;
1282            if (epos+1 > Length(fmt)) then Inc(epos) // last percent, output literally
1283       else if (fmt[epos+1] = '%') then // special case
1284       begin
1285         Inc(epos);
1286         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
1287         spos := epos+1;
1288       end
1289       else
1290       begin
1291         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
1292         spos := epos;
1293       end;
1294       continue;
1295     end;
1296     // check if we have argument for this format string
1297     if (curarg > High(args)) then
1298     begin
1299       xwrite('<OUT OF ARGS>');
1300       writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1301       break;
1302     end;
1303     // skip percent
1304     if (spos+1 > Length(fmt)) then break; // oops
1305     assert(fmt[spos] = '%');
1306     Inc(spos);
1307     // parse format; check for sign
1308          if (fmt[spos] = '-') then begin sign := '-'; Inc(spos); end
1309     else if (fmt[spos] = '+') then begin sign := '+'; Inc(spos); end
1310     else sign := ' ';
1311     // parse width
1312     if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
1313     if (sign <> ' ') or ((fmt[spos] >= '0') and (fmt[spos] <= '9')) then
1314     begin
1315       if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1316       zeropad := (fmt[spos] = '0');
1317       width := 0;
1318       while (spos <= Length(fmt)) do
1319       begin
1320         ch := fmt[spos];
1321         if (ch < '0') or (ch > '9') then break;
1322         width := width*10+Integer(ch)-48;
1323         Inc(spos);
1324       end;
1325     end
1326     else
1327     begin
1328       width := -1;
1329       zeropad := false;
1330     end;
1331     // parse precision
1332     prec := -1;
1333     if (spos <= Length(fmt)) and (fmt[spos] = '.') then
1334     begin
1335       Inc(spos);
1336       if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
1337       if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1338       prec := 0;
1339       while (spos <= Length(fmt)) do
1340       begin
1341         ch := fmt[spos];
1342         if (ch < '0') or (ch > '9') then break;
1343         prec := prec*10+Integer(ch)-48;
1344         Inc(spos);
1345       end;
1346     end;
1347     // get format char
1348     if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
1349     fmtch := fmt[spos];
1350     Inc(spos);
1351     // done parsing format, check for valid format chars
1352     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;
1353     // now write formatted string
1354     case args[curarg].VType of
1355       vtInteger: // args[curarg].VInteger
1356         begin
1357           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;
1358           if (fmtch = 's') then fmtch := 'd';
1359           buildCFormat();
1360           strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], args[curarg].VInteger);
1361           writeStrBuf();
1362         end;
1363       vtBoolean: // args[curarg].VBoolean
1364         case fmtch of
1365           's':
1366             begin
1367               buildCFormat();
1368               if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'true')
1369               else strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'false');
1370               writeStrBuf();
1371             end;
1372           'c':
1373             begin
1374               buildCFormat();
1375               if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('t'))
1376               else strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('f'));
1377               writeStrBuf();
1378             end;
1379           'u', 'd', 'x', 'X':
1380             begin
1381               buildCFormat();
1382               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(args[curarg].VBoolean));
1383               writeStrBuf();
1384             end;
1385           else
1386             begin
1387               xwrite('<INVALID FORMAT CHAR>');
1388               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1389               break;
1390             end;
1391         end;
1392       vtChar: // args[curarg].VChar
1393         case fmtch of
1394           's', 'c':
1395             begin
1396               fmtch := 'c';
1397               buildCFormat();
1398               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], args[curarg].VChar);
1399               writeStrBuf();
1400             end;
1401           'u', 'd', 'x', 'X':
1402             begin
1403               buildCFormat();
1404               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(args[curarg].VChar));
1405               writeStrBuf();
1406             end;
1407           else
1408             begin
1409               xwrite('<INVALID FORMAT CHAR>');
1410               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1411               break;
1412             end;
1413         end;
1414       //vtWideChar: begin end; // args[curarg].VWideChar (WideChar)
1415       vtExtended: // args[curarg].VExtended^
1416         case fmtch of
1417           's', 'g':
1418             begin
1419               fmtch := 'g';
1420               buildCFormat();
1421               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Double(args[curarg].VExtended^));
1422               writeStrBuf();
1423             end;
1424           'f':
1425             begin
1426               buildCFormat();
1427               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Double(args[curarg].VExtended^));
1428               writeStrBuf();
1429             end;
1430           'd':
1431             begin
1432               buildCFormat();
1433               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(trunc(args[curarg].VExtended^)));
1434               writeStrBuf();
1435             end;
1436           'u', 'x', 'X':
1437             begin
1438               buildCFormat();
1439               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], LongWord(trunc(args[curarg].VExtended^)));
1440               writeStrBuf();
1441             end;
1442           else
1443             begin
1444               xwrite('<INVALID FORMAT CHAR>');
1445               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1446               break;
1447             end;
1448         end;
1449       vtString: // args[curarg].VString^ (PShortString)
1450         begin
1451           if (sign <> '-') then indent(width-Length(args[curarg].VString^));
1452           writer(args[curarg].VString^[1], Length(args[curarg].VString^));
1453           if (sign = '-') then indent(width-Length(args[curarg].VString^));
1454         end;
1455       vtPointer: // args[curarg].VPointer
1456         case fmtch of
1457           's':
1458             begin
1459               fmtch := 'x';
1460               if (width < 8) then width := 8;
1461               zeropad := true;
1462               buildCFormat('0x');
1463               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], PtrUInt(args[curarg].VPointer));
1464               writeStrBuf();
1465             end;
1466           'u', 'd', 'x', 'p', 'X':
1467             begin
1468               if (fmtch = 'p') then fmtch := 'x';
1469               if (width < 8) then width := 8;
1470               zeropad := true;
1471               buildCFormat('0x');
1472               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], PtrUInt(args[curarg].VPointer));
1473               writeStrBuf();
1474             end;
1475           else
1476             begin
1477               xwrite('<INVALID FORMAT CHAR>');
1478               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1479               break;
1480             end;
1481         end;
1482       vtPChar: // args[curarg].VPChar
1483         if (args[curarg].VPChar = nil) then
1484         begin
1485           if (sign <> '-') then indent(width-3);
1486           xwrite('nil');
1487           if (sign = '-') then indent(width-3);
1488         end
1489         else
1490         begin
1491           pclen := 0;
1492           while (args[curarg].VPChar[pclen] <> #0) do Inc(pclen);
1493           if (sign <> '-') then indent(width-pclen);
1494           writer(args[curarg].VPChar^, pclen);
1495           if (sign = '-') then indent(width-pclen);
1496         end;
1497       vtObject: // args[curarg].VObject.Classname (TObject)
1498         begin
1499           if (sign <> '-') then indent(width-Length(args[curarg].VObject.Classname));
1500           xwrite(args[curarg].VObject.Classname);
1501           if (sign = '-') then indent(width-Length(args[curarg].VObject.Classname));
1502         end;
1503       vtClass: // args[curarg].VClass.Classname (TClass)
1504         begin
1505           if (sign <> '-') then indent(width-Length(args[curarg].VClass.Classname));
1506           xwrite(args[curarg].VClass.Classname);
1507           if (sign = '-') then indent(width-Length(args[curarg].VClass.Classname));
1508         end;
1509       //vtPWideChar: begin end; // args[curarg].VPWideChar (PWideChar)
1510       vtAnsiString: // AnsiString(args[curarg].VAnsiString) (Pointer)
1511         begin
1512           if (sign <> '-') then indent(width-Length(AnsiString(args[curarg].VAnsiString)));
1513           xwrite(AnsiString(args[curarg].VAnsiString));
1514           if (sign = '-') then indent(width-Length(AnsiString(args[curarg].VAnsiString)));
1515         end;
1516       //vtCurrency: begin end; // args[curarg].VCurrency (PCurrency)
1517       //vtVariant: begin end; // args[curarg].VVariant^ (PVariant)
1518       //vtInterface: begin end; // args[curarg].VInterface (Pointer);
1519       //vtWideString: begin end; // args[curarg].VWideString (Pointer);
1520       vtInt64: // args[curarg].VInt64^ (PInt64)
1521         begin
1522           case fmtch of
1523             's','d','u': pc := i642str(args[curarg].VInt64^, false, false);
1524             'x': pc := i642str(args[curarg].VInt64^, true, false);
1525             'X': pc := i642str(args[curarg].VInt64^, true, true);
1526             else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1527           end;
1528           pclen := 0;
1529           while (pc[pclen] <> #0) do Inc(pclen);
1530           if (sign <> '-') and (width > pclen) then
1531           begin
1532             if zeropad then
1533             begin
1534               if (pc[0] = '-') or (pc[0] = '+') then
1535               begin
1536                 writer(pc^, 1);
1537                 indent0(width-pclen-1);
1538                 Inc(pc);
1539                 Dec(pclen);
1540               end
1541               else
1542               begin
1543                 indent0(width-pclen);
1544               end;
1545             end
1546             else
1547             begin
1548               indent(width-pclen);
1549             end;
1550           end;
1551           writer(pc^, pclen);
1552           if (sign = '-') then indent(width-pclen);
1553         end;
1554       vtQWord: // args[curarg].VQWord^ (PQWord)
1555         begin
1556           case fmtch of
1557             's','d','u': pc := ui642str(args[curarg].VInt64^, false, false);
1558             'x': pc := ui642str(args[curarg].VInt64^, true, false);
1559             'X': pc := ui642str(args[curarg].VInt64^, true, true);
1560             else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1561           end;
1562           pclen := 0;
1563           while (pc[pclen] <> #0) do Inc(pclen);
1564           if (sign <> '-') then begin if zeropad then indent0(width-pclen) else indent(width-pclen); end;
1565           writer(pc^, pclen);
1566           if (sign = '-') then indent(width-pclen);
1567         end;
1568       else
1569         begin
1570           xwrite('<INVALID TYPE>');
1571           writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1572           break;
1573         end;
1574     end;
1575     Inc(curarg);
1576   end;
1577 end;
1578
1579
1580 (*
1581 var
1582   ss: ShortString;
1583   ls: AnsiString;
1584   i64: Int64 = -$A000000000;
1585   ui64: UInt64 = $A000000000;
1586 begin
1587   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']);
1588   writef(conwriter, 'test float:<%s;%u;%f;%g>'#10, [666.6942, 666.6942, 666.6942, 666.6942]);
1589   ss := 'fuckit';
1590   ls := 'FUCKIT';
1591   writef(conwriter, 'test ss:<%5s;%040s>'#10, [ss, ss]);
1592   writef(conwriter, 'test ls:<%5s;%040s>'#10, [ls, ls]);
1593   writef(conwriter, 'test pointer:<%s;%x;%p>'#10, [@ss, @ss, @ss]);
1594   writef(conwriter, 'test i64:<%s;%x;%015d;%u;%X>'#10, [i64, i64, i64, i64, i64]);
1595   writef(conwriter, 'test ui64:<%s;%x;%15d;%015u;%X>'#10, [ui64, ui64, ui64, ui64, ui64]);
1596 *)
1597 end.