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