DEADSOFTWARE

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