DEADSOFTWARE

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