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