DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / d2df-sdl.git / blob


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