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