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