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 // does filename have one of ".wad", ".pk3", ".zip" extensions?
  26 function hasWadExtension (fn: AnsiString): Boolean;
  27
  28 // does filepath have ".XXX:\" in it?
  29 function isWadPath (fn: AnsiString): Boolean;
  30
  31 // adds ".wad" extension if filename doesn't have one of ".wad", ".pk3", ".zip"
  32 function addWadExtension (fn: AnsiString): AnsiString;
  33
  34 // convert number to strig with nice commas
  35 function Int64ToStrComma (i: Int64): AnsiString;
  36
  37 function UpCase1251 (ch: Char): Char;
  38 function LoCase1251 (ch: Char): Char;
  39
  40 // `true` if strings are equal; ignoring case for cp1251
  41 function StrEquCI1251 (const s0, s1: AnsiString): Boolean;
  42
  43 function utf8Valid (const s: AnsiString): Boolean;
  44
  45 function utf8to1251 (s: AnsiString): AnsiString;
  46
  47 // `pathname` will be modified if path is valid
  48 // `lastIsDir` should be `true` if we are searching for directory
  49 // nobody cares about shitdoze, so i'll use the same code path for it
  50 function findFileCI (var pathname: AnsiString; lastIsDir: Boolean=false): Boolean;
  51
  52 // they throws
  53 function openDiskFileRO (pathname: AnsiString): TStream;
  54 function createDiskFile (pathname: AnsiString): TStream;
  55
  56 // little endian
  57 procedure writeInt (st: TStream; v: Byte); overload;
  58 procedure writeInt (st: TStream; v: ShortInt); overload;
  59 procedure writeInt (st: TStream; v: Word); overload;
  60 procedure writeInt (st: TStream; v: SmallInt); overload;
  61 procedure writeInt (st: TStream; v: LongWord); overload;
  62 procedure writeInt (st: TStream; v: LongInt); overload;
  63 procedure writeInt (st: TStream; v: Int64); overload;
  64 procedure writeInt (st: TStream; v: UInt64); overload;
  65
  66 function readByte (st: TStream): Byte;
  67 function readShortInt (st: TStream): ShortInt;
  68 function readWord (st: TStream): Word;
  69 function readSmallInt (st: TStream): SmallInt;
  70 function readLongWord (st: TStream): LongWord;
  71 function readLongInt (st: TStream): LongInt;
  72 function readInt64 (st: TStream): Int64;
  73 function readUInt64 (st: TStream): UInt64;
  74
  75 // big endian
  76 procedure writeIntBE (st: TStream; v: Byte); overload;
  77 procedure writeIntBE (st: TStream; v: ShortInt); overload;
  78 procedure writeIntBE (st: TStream; v: Word); overload;
  79 procedure writeIntBE (st: TStream; v: SmallInt); overload;
  80 procedure writeIntBE (st: TStream; v: LongWord); overload;
  81 procedure writeIntBE (st: TStream; v: LongInt); overload;
  82 procedure writeIntBE (st: TStream; v: Int64); overload;
  83 procedure writeIntBE (st: TStream; v: UInt64); overload;
  84
  85 function readByteBE (st: TStream): Byte;
  86 function readShortIntBE (st: TStream): ShortInt;
  87 function readWordBE (st: TStream): Word;
  88 function readSmallIntBE (st: TStream): SmallInt;
  89 function readLongWordBE (st: TStream): LongWord;
  90 function readLongIntBE (st: TStream): LongInt;
  91 function readInt64BE (st: TStream): Int64;
  92 function readUInt64BE (st: TStream): UInt64;
  93
  94
  95 type
  96   TFormatStrFCallback = procedure (constref buf; len: SizeUInt);
  97
  98 // returns formatted string if `writerCB` is `nil`, empty string otherwise
  99 function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
 100
 101
 102 implementation
 103
 104
 105 function hasWadExtension (fn: AnsiString): Boolean;
 106 begin
 107   fn := ExtractFileExt(fn);
 108   result := StrEquCI1251(fn, '.wad') or StrEquCI1251(fn, '.pk3') or StrEquCI1251(fn, '.zip');
 109 end;
 110
 111
 112 function addWadExtension (fn: AnsiString): AnsiString;
 113 begin
 114   result := fn;
 115   if not hasWadExtension(result) then result := result+'.wad';
 116 end;
 117
 118
 119 function isWadPath (fn: AnsiString): Boolean;
 120 var
 121   p: Integer;
 122   s: AnsiString;
 123 begin
 124   result := false;
 125   while true do
 126   begin
 127     p := Pos(':', fn);
 128     if (p = 0) or (length(fn)-p < 1) then break;
 129     if (p-4 > 1) and (fn[p-4] = '.') and ((fn[p+1] = '\') or (fn[p+1] = '/')) then
 130     begin
 131       s := Copy(fn, p-4, 4);
 132       if StrEquCI1251(s, '.wad') or StrEquCI1251(s, '.pk3') or StrEquCI1251(s, '.zip') then
 133       begin
 134         result := true;
 135         exit;
 136       end;
 137     end;
 138     Delete(fn, 1, p);
 139   end;
 140 end;
 141
 142
 143 function Int64ToStrComma (i: Int64): AnsiString;
 144 var
 145   f: Integer;
 146 begin
 147   Str(i, result);
 148   f := Length(result)+1;
 149   while f > 4 do
 150   begin
 151     Dec(f, 3); Insert(',', result, f);
 152   end;
 153 end;
 154
 155
 156 function UpCase1251 (ch: Char): Char;
 157 begin
 158   if ch < #128 then
 159   begin
 160     if (ch >= 'a') and (ch <= 'z') then Dec(ch, 32);
 161   end
 162   else
 163   begin
 164     if (ch >= #224) and (ch <= #255) then
 165     begin
 166       Dec(ch, 32);
 167     end
 168     else
 169     begin
 170       case ch of
 171         #184, #186, #191: Dec(ch, 16);
 172         #162, #179: Dec(ch);
 173       end;
 174     end;
 175   end;
 176   result := ch;
 177 end;
 178
 179
 180 function LoCase1251 (ch: Char): Char;
 181 begin
 182   if ch < #128 then
 183   begin
 184     if (ch >= 'A') and (ch <= 'Z') then Inc(ch, 32);
 185   end
 186   else
 187   begin
 188     if (ch >= #192) and (ch <= #223) then
 189     begin
 190       Inc(ch, 32);
 191     end
 192     else
 193     begin
 194       case ch of
 195         #168, #170, #175: Inc(ch, 16);
 196         #161, #178: Inc(ch);
 197       end;
 198     end;
 199   end;
 200   result := ch;
 201 end;
 202
 203
 204 function StrEquCI1251 (const s0, s1: AnsiString): Boolean;
 205 var
 206   i: Integer;
 207 begin
 208   result := false;
 209   if length(s0) <> length(s1) then exit;
 210   for i := 1 to length(s0) do if UpCase1251(s0[i]) <> UpCase1251(s1[i]) then exit;
 211   result := true;
 212 end;
 213
 214
 215 // ////////////////////////////////////////////////////////////////////////// //
 216 // utils
 217 // `ch`: utf8 start
 218 // -1: invalid utf8
 219 function utf8CodeLen (ch: Word): Integer;
 220 begin
 221   if ch < $80 then begin result := 1; exit; end;
 222   if (ch and $FE) = $FC then begin result := 6; exit; end;
 223   if (ch and $FC) = $F8 then begin result := 5; exit; end;
 224   if (ch and $F8) = $F0 then begin result := 4; exit; end;
 225   if (ch and $F0) = $E0 then begin result := 3; exit; end;
 226   if (ch and $E0) = $C0 then begin result := 2; exit; end;
 227   result := -1; // invalid
 228 end;
 229
 230
 231 function utf8Valid (const s: AnsiString): Boolean;
 232 var
 233   pos, len: Integer;
 234 begin
 235   result := false;
 236   pos := 1;
 237   while pos <= length(s) do
 238   begin
 239     len := utf8CodeLen(Byte(s[pos]));
 240     if len < 1 then exit; // invalid sequence start
 241     if pos+len-1 > length(s) then exit; // out of chars in string
 242     Dec(len);
 243     Inc(pos);
 244     // check other sequence bytes
 245     while len > 0 do
 246     begin
 247       if (Byte(s[pos]) and $C0) <> $80 then exit;
 248       Dec(len);
 249       Inc(pos);
 250     end;
 251   end;
 252   result := true;
 253 end;
 254
 255
 256 // ////////////////////////////////////////////////////////////////////////// //
 257 const
 258   uni2wint: array [128..255] of Word = (
 259     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
 260     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
 261     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
 262     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
 263     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
 264     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
 265     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
 266     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
 267   );
 268
 269
 270 function decodeUtf8Char (s: AnsiString; var pos: Integer): char;
 271 var
 272   b, c: Integer;
 273 begin
 274   (* The following encodings are valid, except for the 5 and 6 byte
 275    * combinations:
 276    *  0xxxxxxx
 277    *  110xxxxx 10xxxxxx
 278    *  1110xxxx 10xxxxxx 10xxxxxx
 279    *  11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
 280    *  111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
 281    *  1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
 282    *)
 283   result := '?';
 284   if pos > length(s) then exit;
 285
 286   b := Byte(s[pos]);
 287   Inc(pos);
 288   if b < $80 then begin result := char(b); exit; end;
 289
 290   // mask out unused bits
 291        if (b and $FE) = $FC then b := b and $01
 292   else if (b and $FC) = $F8 then b := b and $03
 293   else if (b and $F8) = $F0 then b := b and $07
 294   else if (b and $F0) = $E0 then b := b and $0F
 295   else if (b and $E0) = $C0 then b := b and $1F
 296   else exit; // invalid utf8
 297
 298   // now continue
 299   while pos <= length(s) do
 300   begin
 301     c := Byte(s[pos]);
 302     if (c and $C0) <> $80 then break; // no more
 303     b := b shl 6;
 304     b := b or (c and $3F);
 305     Inc(pos);
 306   end;
 307
 308   // done, try 1251
 309   for c := 128 to 255 do if uni2wint[c] = b then begin result := char(c and $FF); exit; end;
 310   // alas
 311 end;
 312
 313
 314 function utf8to1251 (s: AnsiString): AnsiString;
 315 var
 316   pos: Integer;
 317 begin
 318   if not utf8Valid(s) then begin result := s; exit; end;
 319   pos := 1;
 320   while pos <= length(s) do
 321   begin
 322     if Byte(s[pos]) >= $80 then break;
 323     Inc(pos);
 324   end;
 325   if pos > length(s) then begin result := s; exit; end; // nothing to do here
 326   result := '';
 327   pos := 1;
 328   while pos <= length(s) do result := result+decodeUtf8Char(s, pos);
 329 end;
 330
 331
 332 // ////////////////////////////////////////////////////////////////////////// //
 333 // `pathname` will be modified if path is valid
 334 // `lastIsDir` should be `true` if we are searching for directory
 335 // nobody cares about shitdoze, so i'll use the same code path for it
 336 function findFileCI (var pathname: AnsiString; lastIsDir: Boolean=false): Boolean;
 337 var
 338   sr: TSearchRec;
 339   npt: AnsiString;
 340   newname: AnsiString = '';
 341   curname: AnsiString;
 342   wantdir: Boolean;
 343   attr: LongInt;
 344   foundher: Boolean;
 345 begin
 346   npt := pathname;
 347   result := (length(npt) > 0);
 348   if (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) then newname := '/';
 349   while length(npt) > 0 do
 350   begin
 351     // remove trailing slashes
 352     while (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) do Delete(npt, 1, 1);
 353     if length(npt) = 0 then break;
 354     // extract name
 355     curname := '';
 356     while (length(npt) > 0) and (npt[1] <> '/') and (npt[1] <> '\') do
 357     begin
 358       curname := curname+npt[1];
 359       Delete(npt, 1, 1);
 360     end;
 361     // remove trailing slashes again
 362     while (length(npt) > 0) and ((npt[1] = '/') or (npt[1] = '\')) do Delete(npt, 1, 1);
 363     wantdir := lastIsDir or (length(npt) > 0); // do we want directory here?
 364     //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
 365     // try the easiest case first
 366     attr := FileGetAttr(newname+curname);
 367     if attr <> -1 then
 368     begin
 369       if wantdir = ((attr and faDirectory) <> 0) then
 370       begin
 371         // i found her!
 372         newname := newname+curname;
 373         if wantdir then newname := newname+'/';
 374         continue;
 375       end;
 376     end;
 377     //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
 378     // alas, either not found, or invalid attributes
 379     foundher := false;
 380     try
 381       if FindFirst(newname+'*', faAnyFile, sr) = 0 then
 382       repeat
 383         if (wantdir = ((sr.attr and faDirectory) <> 0)) and StrEquCI1251(sr.name, curname) then
 384         begin
 385           // i found her!
 386           newname := newname+sr.name;
 387           if wantdir then newname := newname+'/';
 388           foundher := true;
 389           break;
 390         end;
 391       until FindNext(sr) <> 0;
 392     finally
 393       FindClose(sr);
 394     end;
 395     if not foundher then begin newname := ''; result := false; break; end;
 396   end;
 397   if result then pathname := newname;
 398 end;
 399
 400
 401 function openDiskFileRO (pathname: AnsiString): TStream;
 402 begin
 403   if not findFileCI(pathname) then raise Exception.Create('can''t open file "'+pathname+'"');
 404   result := TFileStream.Create(pathname, fmOpenRead or {fmShareDenyWrite}fmShareDenyNone);
 405 end;
 406
 407 function createDiskFile (pathname: AnsiString): TStream;
 408 var
 409   path: AnsiString;
 410 begin
 411   path := ExtractFilePath(pathname);
 412   if length(path) > 0 then
 413   begin
 414     if not findFileCI(path, true) then raise Exception.Create('can''t create file "'+pathname+'"');
 415   end;
 416   result := TFileStream.Create(path+ExtractFileName(pathname), fmCreate);
 417 end;
 418
 419
 420 procedure writeIntegerLE (st: TStream; vp: Pointer; size: Integer);
 421 {$IFDEF ENDIAN_LITTLE}
 422 begin
 423   st.writeBuffer(vp^, size);
 424 end;
 425 {$ELSE}
 426 var
 427   p: PByte;
 428 begin
 429   p := PByte(vp)+size-1;
 430   while size > 0 do
 431   begin
 432     st.writeBuffer(p^, 1);
 433     Dec(size);
 434     Dec(p);
 435   end;
 436 end;
 437 {$ENDIF}
 438
 439 procedure writeIntegerBE (st: TStream; vp: Pointer; size: Integer);
 440 {$IFDEF ENDIAN_LITTLE}
 441 var
 442   p: PByte;
 443 begin
 444   p := PByte(vp)+size-1;
 445   while size > 0 do
 446   begin
 447     st.writeBuffer(p^, 1);
 448     Dec(size);
 449     Dec(p);
 450   end;
 451 end;
 452 {$ELSE}
 453 begin
 454   st.writeBuffer(vp^, size);
 455 end;
 456 {$ENDIF}
 457
 458 procedure writeInt (st: TStream; v: Byte); overload; begin writeIntegerLE(st, @v, 1); end;
 459 procedure writeInt (st: TStream; v: ShortInt); overload; begin writeIntegerLE(st, @v, 1); end;
 460 procedure writeInt (st: TStream; v: Word); overload; begin writeIntegerLE(st, @v, 2); end;
 461 procedure writeInt (st: TStream; v: SmallInt); overload; begin writeIntegerLE(st, @v, 2); end;
 462 procedure writeInt (st: TStream; v: LongWord); overload; begin writeIntegerLE(st, @v, 4); end;
 463 procedure writeInt (st: TStream; v: LongInt); overload; begin writeIntegerLE(st, @v, 4); end;
 464 procedure writeInt (st: TStream; v: Int64); overload; begin writeIntegerLE(st, @v, 8); end;
 465 procedure writeInt (st: TStream; v: UInt64); overload; begin writeIntegerLE(st, @v, 8); end;
 466
 467 procedure writeIntBE (st: TStream; v: Byte); overload; begin writeIntegerBE(st, @v, 1); end;
 468 procedure writeIntBE (st: TStream; v: ShortInt); overload; begin writeIntegerBE(st, @v, 1); end;
 469 procedure writeIntBE (st: TStream; v: Word); overload; begin writeIntegerBE(st, @v, 2); end;
 470 procedure writeIntBE (st: TStream; v: SmallInt); overload; begin writeIntegerBE(st, @v, 2); end;
 471 procedure writeIntBE (st: TStream; v: LongWord); overload; begin writeIntegerBE(st, @v, 4); end;
 472 procedure writeIntBE (st: TStream; v: LongInt); overload; begin writeIntegerBE(st, @v, 4); end;
 473 procedure writeIntBE (st: TStream; v: Int64); overload; begin writeIntegerBE(st, @v, 8); end;
 474 procedure writeIntBE (st: TStream; v: UInt64); overload; begin writeIntegerBE(st, @v, 8); end;
 475
 476
 477 procedure readIntegerLE (st: TStream; vp: Pointer; size: Integer);
 478 {$IFDEF ENDIAN_LITTLE}
 479 begin
 480   st.readBuffer(vp^, size);
 481 end;
 482 {$ELSE}
 483 var
 484   p: PByte;
 485 begin
 486   p := PByte(vp)+size-1;
 487   while size > 0 do
 488   begin
 489     st.readBuffer(p^, 1);
 490     Dec(size);
 491     Dec(p);
 492   end;
 493 end;
 494 {$ENDIF}
 495
 496 procedure readIntegerBE (st: TStream; vp: Pointer; size: Integer);
 497 {$IFDEF ENDIAN_LITTLE}
 498 var
 499   p: PByte;
 500 begin
 501   p := PByte(vp)+size-1;
 502   while size > 0 do
 503   begin
 504     st.readBuffer(p^, 1);
 505     Dec(size);
 506     Dec(p);
 507   end;
 508 end;
 509 {$ELSE}
 510 begin
 511   st.readBuffer(vp^, size);
 512 end;
 513 {$ENDIF}
 514
 515 function readByte (st: TStream): Byte; begin readIntegerLE(st, @result, 1); end;
 516 function readShortInt (st: TStream): ShortInt; begin readIntegerLE(st, @result, 1); end;
 517 function readWord (st: TStream): Word; begin readIntegerLE(st, @result, 2); end;
 518 function readSmallInt (st: TStream): SmallInt; begin readIntegerLE(st, @result, 2); end;
 519 function readLongWord (st: TStream): LongWord; begin readIntegerLE(st, @result, 4); end;
 520 function readLongInt (st: TStream): LongInt; begin readIntegerLE(st, @result, 4); end;
 521 function readInt64 (st: TStream): Int64; begin readIntegerLE(st, @result, 8); end;
 522 function readUInt64 (st: TStream): UInt64; begin readIntegerLE(st, @result, 8); end;
 523
 524 function readByteBE (st: TStream): Byte; begin readIntegerBE(st, @result, 1); end;
 525 function readShortIntBE (st: TStream): ShortInt; begin readIntegerBE(st, @result, 1); end;
 526 function readWordBE (st: TStream): Word; begin readIntegerBE(st, @result, 2); end;
 527 function readSmallIntBE (st: TStream): SmallInt; begin readIntegerBE(st, @result, 2); end;
 528 function readLongWordBE (st: TStream): LongWord; begin readIntegerBE(st, @result, 4); end;
 529 function readLongIntBE (st: TStream): LongInt; begin readIntegerBE(st, @result, 4); end;
 530 function readInt64BE (st: TStream): Int64; begin readIntegerBE(st, @result, 8); end;
 531 function readUInt64BE (st: TStream): UInt64; begin readIntegerBE(st, @result, 8); end;
 532
 533
 534 // ////////////////////////////////////////////////////////////////////////// //
 535 {$IFDEF WINDOWS}
 536 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'msvcrt.dll' name '_snprintf';
 537 {$ELSE}
 538 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'libc' name 'snprintf';
 539 {$ENDIF}
 540
 541
 542 (*
 543 procedure conwriter (constref buf; len: SizeUInt);
 544 var
 545   ss: ShortString;
 546   slen: Integer;
 547   b: PByte;
 548 begin
 549   if (len < 1) then exit;
 550   b := PByte(@buf);
 551   while (len > 0) do
 552   begin
 553     if (len > 255) then slen := 255 else slen := Integer(len);
 554     Move(b^, ss[1], len);
 555     ss[0] := AnsiChar(slen);
 556     write(ss);
 557     b += slen;
 558     len -= slen;
 559   end;
 560 end;
 561 *)
 562
 563
 564 function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
 565 const
 566   PadSpaces: AnsiString = '                                                                       ';
 567   PadZeroes: AnsiString = '00000000000000000000000000000000000000000000000000000000000000000000000';
 568 var
 569   curarg: Integer = 0; // current arg in `args`
 570   sign, fmtch: AnsiChar;
 571   zeropad: Boolean;
 572   width, prec: Integer; // width and precision
 573   spos, epos: Integer;
 574   ch: AnsiChar;
 575   strbuf: array[0..256] of AnsiChar;
 576   strblen: SizeUInt;
 577   fmtbuf: array[0..256] of AnsiChar;
 578   fmtblen: Integer;
 579   pclen: Integer;
 580   pc: PAnsiChar;
 581
 582   procedure writer (constref buf; len: SizeUInt);
 583   var
 584     ss: ShortString;
 585     slen: Integer;
 586     b: PByte;
 587   begin
 588     if (len < 1) then exit;
 589     b := PByte(@buf);
 590     if assigned(writerCB) then
 591     begin
 592       writerCB(b^, len);
 593     end
 594     else
 595     begin
 596       while (len > 0) do
 597       begin
 598         if (len > 255) then slen := 255 else slen := Integer(len);
 599         Move(b^, ss[1], len);
 600         ss[0] := AnsiChar(slen);
 601         result += ss;
 602         b += slen;
 603         len -= slen;
 604       end;
 605     end;
 606   end;
 607
 608   procedure xwrite (const s: AnsiString);
 609   begin
 610     if (Length(s) > 0) then writer(PAnsiChar(s)^, Length(s));
 611   end;
 612
 613   procedure putFmtChar (ch: AnsiChar);
 614   begin
 615     fmtbuf[fmtblen] := ch;
 616     Inc(fmtblen);
 617   end;
 618
 619   procedure putFmtInt (n: Integer);
 620   var
 621     len: SizeUInt;
 622   begin
 623     len := snprintf(@fmtbuf[fmtblen], Length(fmtbuf)-fmtblen, '%d', n);
 624     if (len > 0) then Inc(fmtblen, len);
 625   end;
 626
 627   procedure buildCFormat (const pfx: AnsiString='');
 628   var
 629     f: Integer;
 630   begin
 631     fmtblen := 0;
 632     for f := 1 to Length(pfx) do putFmtChar(pfx[f]);
 633     putFmtChar('%');
 634     if (sign <> ' ') then putFmtChar(sign);
 635     if (width >= 0) then
 636     begin
 637       if (zeropad) then putFmtChar('0');
 638       putFmtInt(width);
 639       if (prec >= 0) then
 640       begin
 641         putFmtChar('.');
 642         putFmtInt(prec);
 643       end;
 644     end;
 645     putFmtChar(fmtch);
 646     fmtbuf[fmtblen] := #0;
 647   end;
 648
 649   procedure writeStrBuf ();
 650   begin
 651     if (strblen > 0) then writer(strbuf, strblen);
 652   end;
 653
 654   function i642str (n: Int64; hex: Boolean; hexup: Boolean): PAnsiChar;
 655   var
 656     neg: Boolean;
 657     xpos: Integer;
 658   begin
 659     if (n = $8000000000000000) then
 660     begin
 661       if hex then snprintf(@strbuf[0], Length(strbuf), '-8000000000000000')
 662       else snprintf(@strbuf[0], Length(strbuf), '-9223372036854775808');
 663       result := @strbuf[0];
 664     end
 665     else
 666     begin
 667       neg := (n < 0);
 668       if neg then n := -n;
 669       xpos := High(strbuf);
 670       strbuf[xpos] := #0; Dec(xpos);
 671       repeat
 672         if hex then
 673         begin
 674           strbuf[xpos] := AnsiChar((n mod 10)+48);
 675           Dec(xpos);
 676           n := n div 10;
 677         end
 678         else
 679         begin
 680           if (n mod 16 > 9) then
 681           begin
 682             strbuf[xpos] := AnsiChar((n mod 16)+48+7);
 683             if not hexup then Inc(strbuf[xpos], 32);
 684           end
 685           else strbuf[xpos] := AnsiChar((n mod 16)+48);
 686           Dec(xpos);
 687           n := n div 16;
 688         end;
 689       until (n = 0);
 690       if neg then begin strbuf[xpos] := '-'; Dec(xpos); end;
 691       result := @strbuf[xpos+1];
 692     end;
 693   end;
 694
 695   function ui642str (n: UInt64; hex: Boolean; hexup: Boolean): PAnsiChar;
 696   var
 697     xpos: Integer;
 698   begin
 699     xpos := High(strbuf);
 700     strbuf[xpos] := #0; Dec(xpos);
 701     repeat
 702       if hex then
 703       begin
 704         strbuf[xpos] := AnsiChar((n mod 10)+48);
 705         Dec(xpos);
 706         n := n div 10;
 707       end
 708       else
 709       begin
 710         if (n mod 16 > 9) then
 711         begin
 712           strbuf[xpos] := AnsiChar((n mod 16)+48+7);
 713           if not hexup then Inc(strbuf[xpos], 32);
 714         end
 715         else strbuf[xpos] := AnsiChar((n mod 16)+48);
 716         Dec(xpos);
 717         n := n div 16;
 718       end;
 719     until (n = 0);
 720     result := @strbuf[xpos+1];
 721   end;
 722
 723   procedure indent (len: Integer);
 724   var
 725     ilen: Integer;
 726   begin
 727     while (len > 0) do
 728     begin
 729       if (len > Length(PadSpaces)) then ilen := Length(PadSpaces) else ilen := len;
 730       writer(PAnsiChar(PadSpaces)^, ilen);
 731       Dec(len, ilen);
 732     end;
 733   end;
 734
 735   procedure indent0 (len: Integer);
 736   var
 737     ilen: Integer;
 738   begin
 739     while (len > 0) do
 740     begin
 741       if (len > Length(PadZeroes)) then ilen := Length(PadZeroes) else ilen := len;
 742       writer(PAnsiChar(PadZeroes)^, ilen);
 743       Dec(len, ilen);
 744     end;
 745   end;
 746
 747 begin
 748   result := '';
 749   spos := 1;
 750   while (spos <= Length(fmt)) do
 751   begin
 752     // print literal part
 753     epos := spos;
 754     while (epos <= Length(fmt)) and (fmt[epos] <> '%') do Inc(epos);
 755     // output literal part
 756     if (epos > spos) then
 757     begin
 758       if (epos > Length(fmt)) then
 759       begin
 760         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
 761         break;
 762       end;
 763            if (epos+1 > Length(fmt)) then Inc(epos) // last percent, output literally
 764       else if (fmt[epos+1] = '%') then // special case
 765       begin
 766         Inc(epos);
 767         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
 768         spos := epos+1;
 769       end
 770       else
 771       begin
 772         writer((PAnsiChar(fmt)+spos-1)^, epos-spos);
 773         spos := epos;
 774       end;
 775       continue;
 776     end;
 777     // check if we have argument for this format string
 778     if (curarg > High(args)) then
 779     begin
 780       xwrite('<OUT OF ARGS>');
 781       writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
 782       break;
 783     end;
 784     // skip percent
 785     if (spos+1 > Length(fmt)) then break; // oops
 786     assert(fmt[spos] = '%');
 787     Inc(spos);
 788     // parse format; check for sign
 789          if (fmt[spos] = '-') then begin sign := '-'; Inc(spos); end
 790     else if (fmt[spos] = '+') then begin sign := '+'; Inc(spos); end
 791     else sign := ' ';
 792     // parse width
 793     if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
 794     if (sign <> ' ') or ((fmt[spos] >= '0') and (fmt[spos] <= '9')) then
 795     begin
 796       if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
 797       zeropad := (fmt[spos] = '0');
 798       width := 0;
 799       while (spos <= Length(fmt)) do
 800       begin
 801         ch := fmt[spos];
 802         if (ch < '0') or (ch > '9') then break;
 803         width := width*10+Integer(ch)-48;
 804         Inc(spos);
 805       end;
 806     end
 807     else
 808     begin
 809       width := -1;
 810       zeropad := false;
 811     end;
 812     // parse precision
 813     prec := -1;
 814     if (spos <= Length(fmt)) and (fmt[spos] = '.') then
 815     begin
 816       Inc(spos);
 817       if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
 818       if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
 819       prec := 0;
 820       while (spos <= Length(fmt)) do
 821       begin
 822         ch := fmt[spos];
 823         if (ch < '0') or (ch > '9') then break;
 824         prec := prec*10+Integer(ch)-48;
 825         Inc(spos);
 826       end;
 827     end;
 828     // get format char
 829     if (spos > Length(fmt)) then begin xwrite('<INVALID FORMAT>'); break; end;
 830     fmtch := fmt[spos];
 831     Inc(spos);
 832     // done parsing format, check for valid format chars
 833     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;
 834     // now write formatted string
 835     case args[curarg].VType of
 836       vtInteger: // args[curarg].VInteger
 837         begin
 838           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;
 839           if (fmtch = 's') then fmtch := 'd';
 840           buildCFormat();
 841           strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], args[curarg].VInteger);
 842           writeStrBuf();
 843         end;
 844       vtBoolean: // args[curarg].VBoolean
 845         case fmtch of
 846           's':
 847             begin
 848               buildCFormat();
 849               if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'true')
 850               else strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'false');
 851               writeStrBuf();
 852             end;
 853           'c':
 854             begin
 855               buildCFormat();
 856               if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('t'))
 857               else strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('f'));
 858               writeStrBuf();
 859             end;
 860           'u', 'd', 'x', 'X':
 861             begin
 862               buildCFormat();
 863               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(args[curarg].VBoolean));
 864               writeStrBuf();
 865             end;
 866           else
 867             begin
 868               xwrite('<INVALID FORMAT CHAR>');
 869               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
 870               break;
 871             end;
 872         end;
 873       vtChar: // args[curarg].VChar
 874         case fmtch of
 875           's', 'c':
 876             begin
 877               fmtch := 'c';
 878               buildCFormat();
 879               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], args[curarg].VChar);
 880               writeStrBuf();
 881             end;
 882           'u', 'd', 'x', 'X':
 883             begin
 884               buildCFormat();
 885               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(args[curarg].VChar));
 886               writeStrBuf();
 887             end;
 888           else
 889             begin
 890               xwrite('<INVALID FORMAT CHAR>');
 891               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
 892               break;
 893             end;
 894         end;
 895       //vtWideChar: begin end; // args[curarg].VWideChar (WideChar)
 896       vtExtended: // args[curarg].VExtended^
 897         case fmtch of
 898           's', 'g':
 899             begin
 900               fmtch := 'g';
 901               buildCFormat();
 902               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Double(args[curarg].VExtended^));
 903               writeStrBuf();
 904             end;
 905           'f':
 906             begin
 907               buildCFormat();
 908               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Double(args[curarg].VExtended^));
 909               writeStrBuf();
 910             end;
 911           'd':
 912             begin
 913               buildCFormat();
 914               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(trunc(args[curarg].VExtended^)));
 915               writeStrBuf();
 916             end;
 917           'u', 'x', 'X':
 918             begin
 919               buildCFormat();
 920               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], LongWord(trunc(args[curarg].VExtended^)));
 921               writeStrBuf();
 922             end;
 923           else
 924             begin
 925               xwrite('<INVALID FORMAT CHAR>');
 926               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
 927               break;
 928             end;
 929         end;
 930       vtString: // args[curarg].VString^ (PShortString)
 931         begin
 932           if (sign <> '-') then indent(width-Length(args[curarg].VString^));
 933           writer(args[curarg].VString^[1], Length(args[curarg].VString^));
 934           if (sign = '-') then indent(width-Length(args[curarg].VString^));
 935         end;
 936       vtPointer: // args[curarg].VPointer
 937         case fmtch of
 938           's':
 939             begin
 940               fmtch := 'x';
 941               if (width < 8) then width := 8;
 942               zeropad := true;
 943               buildCFormat('0x');
 944               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], PtrUInt(args[curarg].VPointer));
 945               writeStrBuf();
 946             end;
 947           'u', 'd', 'x', 'p', 'X':
 948             begin
 949               if (fmtch = 'p') then fmtch := 'x';
 950               if (width < 8) then width := 8;
 951               zeropad := true;
 952               buildCFormat('0x');
 953               strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], PtrUInt(args[curarg].VPointer));
 954               writeStrBuf();
 955             end;
 956           else
 957             begin
 958               xwrite('<INVALID FORMAT CHAR>');
 959               writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
 960               break;
 961             end;
 962         end;
 963       vtPChar: // args[curarg].VPChar
 964         if (args[curarg].VPChar = nil) then
 965         begin
 966           if (sign <> '-') then indent(width-3);
 967           xwrite('nil');
 968           if (sign = '-') then indent(width-3);
 969         end
 970         else
 971         begin
 972           pclen := 0;
 973           while (args[curarg].VPChar[pclen] <> #0) do Inc(pclen);
 974           if (sign <> '-') then indent(width-pclen);
 975           writer(args[curarg].VPChar^, pclen);
 976           if (sign = '-') then indent(width-pclen);
 977         end;
 978       vtObject: // args[curarg].VObject.Classname (TObject)
 979         begin
 980           if (sign <> '-') then indent(width-Length(args[curarg].VObject.Classname));
 981           xwrite(args[curarg].VObject.Classname);
 982           if (sign = '-') then indent(width-Length(args[curarg].VObject.Classname));
 983         end;
 984       vtClass: // args[curarg].VClass.Classname (TClass)
 985         begin
 986           if (sign <> '-') then indent(width-Length(args[curarg].VClass.Classname));
 987           xwrite(args[curarg].VClass.Classname);
 988           if (sign = '-') then indent(width-Length(args[curarg].VClass.Classname));
 989         end;
 990       //vtPWideChar: begin end; // args[curarg].VPWideChar (PWideChar)
 991       vtAnsiString: // AnsiString(args[curarg].VAnsiString) (Pointer)
 992         begin
 993           if (sign <> '-') then indent(width-Length(AnsiString(args[curarg].VAnsiString)));
 994           xwrite(AnsiString(args[curarg].VAnsiString));
 995           if (sign = '-') then indent(width-Length(AnsiString(args[curarg].VAnsiString)));
 996         end;
 997       //vtCurrency: begin end; // args[curarg].VCurrency (PCurrency)
 998       //vtVariant: begin end; // args[curarg].VVariant^ (PVariant)
 999       //vtInterface: begin end; // args[curarg].VInterface (Pointer);
1000       //vtWideString: begin end; // args[curarg].VWideString (Pointer);
1001       vtInt64: // args[curarg].VInt64^ (PInt64)
1002         begin
1003           case fmtch of
1004             's','d','u': pc := i642str(args[curarg].VInt64^, false, false);
1005             'x': pc := i642str(args[curarg].VInt64^, true, false);
1006             'X': pc := i642str(args[curarg].VInt64^, true, true);
1007             else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1008           end;
1009           pclen := 0;
1010           while (pc[pclen] <> #0) do Inc(pclen);
1011           if (sign <> '-') and (width > pclen) then
1012           begin
1013             if zeropad then
1014             begin
1015               if (pc[0] = '-') or (pc[0] = '+') then
1016               begin
1017                 writer(pc^, 1);
1018                 indent0(width-pclen-1);
1019                 Inc(pc);
1020                 Dec(pclen);
1021               end
1022               else
1023               begin
1024                 indent0(width-pclen);
1025               end;
1026             end
1027             else
1028             begin
1029               indent(width-pclen);
1030             end;
1031           end;
1032           writer(pc^, pclen);
1033           if (sign = '-') then indent(width-pclen);
1034         end;
1035       vtQWord: // args[curarg].VQWord^ (PQWord)
1036         begin
1037           case fmtch of
1038             's','d','u': pc := ui642str(args[curarg].VInt64^, false, false);
1039             'x': pc := ui642str(args[curarg].VInt64^, true, false);
1040             'X': pc := ui642str(args[curarg].VInt64^, true, true);
1041             else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1042           end;
1043           pclen := 0;
1044           while (pc[pclen] <> #0) do Inc(pclen);
1045           if (sign <> '-') then begin if zeropad then indent0(width-pclen) else indent(width-pclen); end;
1046           writer(pc^, pclen);
1047           if (sign = '-') then indent(width-pclen);
1048         end;
1049       else
1050         begin
1051           xwrite('<INVALID TYPE>');
1052           writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1);
1053           break;
1054         end;
1055     end;
1056     Inc(curarg);
1057   end;
1058 end;
1059
1060
1061 (*
1062 var
1063   ss: ShortString;
1064   ls: AnsiString;
1065   i64: Int64 = -$A000000000;
1066   ui64: UInt64 = $A000000000;
1067 begin
1068   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']);
1069   writef(conwriter, 'test float:<%s;%u;%f;%g>'#10, [666.6942, 666.6942, 666.6942, 666.6942]);
1070   ss := 'fuckit';
1071   ls := 'FUCKIT';
1072   writef(conwriter, 'test ss:<%5s;%040s>'#10, [ss, ss]);
1073   writef(conwriter, 'test ls:<%5s;%040s>'#10, [ls, ls]);
1074   writef(conwriter, 'test pointer:<%s;%x;%p>'#10, [@ss, @ss, @ss]);
1075   writef(conwriter, 'test i64:<%s;%x;%015d;%u;%X>'#10, [i64, i64, i64, i64, i64]);
1076   writef(conwriter, 'test ui64:<%s;%x;%15d;%015u;%X>'#10, [ui64, ui64, ui64, ui64, ui64]);
1077 *)
1078 end.