DEADSOFTWARE

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