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