1 (* Copyright (C) DooM 2D:Forever Developers
2 *
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, either version 3 of the License, or
6 * (at your option) any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
15 *)
16 {$INCLUDE a_modes.inc}
19 interface
21 uses
25 // ////////////////////////////////////////////////////////////////////////// //
26 type
28 public
33 private
36 public
39 public
48 // process one byte, return `true` if codepoint is ready
54 // ////////////////////////////////////////////////////////////////////////// //
59 // strips out name from `fn`, leaving trailing slash
62 // ends with '/' or '\'?
65 // strips extra trailing slashes in `path, and extra leading slashes in `fn`
66 // will add slash to `path`, even if `fn` is empty!
69 // does filename have one of ".wad", ".pk3", ".zip" extensions?
72 // does filepath have ".XXX:\" in it?
75 // adds ".wad" extension if filename doesn't have one of ".wad", ".pk3", ".zip"
78 // convert number to strig with nice commas
84 // `true` if strings are equal; ignoring case for cp1251
91 // `pathname` will be modified if path is valid
92 // `lastIsDir` should be `true` if we are searching for directory
93 // nobody cares about shitdoze, so i'll use the same code path for it
96 // they throws
100 // little endian
119 // big endian
176 type
179 // returns formatted string if `writerCB` is `nil`, empty string otherwise
180 function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
187 // returns string in single or double quotes
188 // single quotes supports only pascal-style '' for single quote char
189 // double quotes supports c-style escapes
190 // function will select quote mode automatically
194 type
196 private
197 //type PItemT = ^ItemT;
200 public
201 type
203 private
207 public
214 private
218 private
225 public
229 //WARNING! don't change list contents in `for ... in`!
237 public
244 implementation
247 // ////////////////////////////////////////////////////////////////////////// //
249 begin
256 begin
262 begin
267 // ////////////////////////////////////////////////////////////////////////// //
269 begin
277 begin
284 begin
290 begin
297 begin
304 begin
310 begin
317 begin
323 begin
329 begin
331 begin
339 // ////////////////////////////////////////////////////////////////////////// //
340 var
345 // ////////////////////////////////////////////////////////////////////////// //
346 const
348 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
349 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
350 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
351 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
352 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
353 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
354 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
356 );
360 var
362 begin
370 // ////////////////////////////////////////////////////////////////////////// //
371 // fast state-machine based UTF-8 decoder; using 8 bytes of memory
372 // code points from invalid range will never be valid, this is the property of the state machine
373 const
374 // see http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
376 // maps bytes to character classes
393 // maps a combination of a state of the automaton and a character class to a state
403 // ////////////////////////////////////////////////////////////////////////// //
404 constructor TUtf8DecoderFast.Create (v: Boolean{fuck you, fpc}); begin state := Accept; codepoint := 0; end;
410 function TUtf8DecoderFast.completeOrInvalid (): Boolean; inline; begin result := (state = Accept) or (state = Reject); end;
412 function TUtf8DecoderFast.decode (c: AnsiChar): Boolean; inline; overload; begin result := decode(Byte(c)); end;
415 var
417 begin
420 if (state <> Accept) then codepoint := (b and $3f) or (codepoint shl 6) else codepoint := ($ff shr tp) and b;
427 // ////////////////////////////////////////////////////////////////////////// //
429 begin
435 // ////////////////////////////////////////////////////////////////////////// //
437 var
440 begin
442 begin
444 begin
448 begin
451 exit;
459 var
463 begin
466 begin
468 end
470 begin
473 end
475 begin
479 end
481 begin
486 end
487 else
488 begin
493 begin
495 begin
497 begin
500 begin
502 begin
504 end
505 else
506 begin
510 exit;
517 // ////////////////////////////////////////////////////////////////////////// //
519 begin
524 begin
527 end
528 else
529 begin
538 // ////////////////////////////////////////////////////////////////////////// //
542 var
544 begin
547 begin
555 var
558 begin
561 begin
569 begin
572 end
574 begin
577 end
578 else
579 begin
586 var
589 begin
591 begin
599 // ////////////////////////////////////////////////////////////////////////// //
601 var
604 begin
607 begin
610 begin
612 exit;
622 var
625 begin
630 begin
642 var
645 begin
649 begin
652 begin
654 begin
656 end
657 else
658 begin
661 exit;
668 begin
675 // strips out name from `fn`, leaving trailing slash
677 var
680 begin
685 begin
694 // ends with '/' or '\'?
696 begin
698 begin
700 end
701 else
702 begin
708 // strips extra trailing slashes in `path, and extra leading slashes in `fn`
709 // will add slash to `path`, even if `fn` is empty!
711 var
713 begin
717 if (Length(result) > 0) and ((result[Length(result)] <> '/') and (result[Length(result)] <> '\')) then result += '/';
719 begin
721 //FIXME: make this faster!
722 while (Length(result) > 0) and ((result[Length(result)] = '/') or (result[Length(result)] = '\')) do
723 begin
732 var
734 begin
741 begin
748 var
751 begin
755 begin
757 begin
760 begin
763 begin
765 exit;
775 var
777 begin
781 begin
788 begin
790 begin
792 end
793 else
794 begin
796 begin
798 end
799 else
800 begin
812 begin
814 begin
816 end
817 else
818 begin
820 begin
822 end
823 else
824 begin
836 var
838 begin
846 // ////////////////////////////////////////////////////////////////////////// //
847 // utils
848 // `ch`: utf8 start
849 // -1: invalid utf8
851 begin
863 var
865 begin
869 begin
875 // check other sequence bytes
877 begin
887 // ////////////////////////////////////////////////////////////////////////// //
888 const
890 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
891 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
892 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
893 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
894 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
895 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
896 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
898 );
902 var
904 begin
905 (* The following encodings are valid, except for the 5 and 6 byte
906 * combinations:
907 * 0xxxxxxx
908 * 110xxxxx 10xxxxxx
909 * 1110xxxx 10xxxxxx 10xxxxxx
910 * 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
911 * 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
912 * 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
913 *)
921 // mask out unused bits
929 // now continue
931 begin
939 // done, try 1251
941 // alas
946 var
948 begin
952 begin
963 // ////////////////////////////////////////////////////////////////////////// //
964 // `pathname` will be modified if path is valid
965 // `lastIsDir` should be `true` if we are searching for directory
966 // nobody cares about shitdoze, so i'll use the same code path for it
968 var
976 begin
981 begin
982 // remove trailing slashes
985 // extract name
988 begin
992 // remove trailing slashes again
995 //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
996 // try the easiest case first
999 begin
1001 begin
1002 // i found her!
1005 continue;
1008 //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
1009 // alas, either not found, or invalid attributes
1011 try
1013 repeat
1015 begin
1016 // i found her!
1020 break;
1023 finally
1033 begin
1039 var
1041 begin
1044 begin
1045 if not findFileCI(path, true) then raise Exception.Create('can''t create file "'+pathname+'"');
1052 {$IFDEF ENDIAN_LITTLE}
1053 begin
1056 {$ELSE}
1057 var
1059 begin
1062 begin
1068 {$ENDIF}
1071 {$IFDEF ENDIAN_LITTLE}
1072 var
1074 begin
1077 begin
1083 {$ELSE}
1084 begin
1087 {$ENDIF}
1099 procedure writeIntBE (st: TStream; v: ShortInt); overload; begin writeIntegerBE(st, @v, 1); end;
1101 procedure writeIntBE (st: TStream; v: SmallInt); overload; begin writeIntegerBE(st, @v, 2); end;
1102 procedure writeIntBE (st: TStream; v: LongWord); overload; begin writeIntegerBE(st, @v, 4); end;
1103 procedure writeIntBE (st: TStream; v: LongInt); overload; begin writeIntegerBE(st, @v, 4); end;
1109 {$IFDEF ENDIAN_LITTLE}
1110 begin
1113 {$ELSE}
1114 var
1116 begin
1119 begin
1125 {$ENDIF}
1128 {$IFDEF ENDIAN_LITTLE}
1129 var
1131 begin
1134 begin
1140 {$ELSE}
1141 begin
1144 {$ENDIF}
1165 // ////////////////////////////////////////////////////////////////////////// //
1166 function nmin (a, b: Byte): Byte; inline; overload; begin if (a < b) then result := a else result := b; end;
1167 function nmin (a, b: ShortInt): ShortInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1168 function nmin (a, b: Word): Word; inline; overload; begin if (a < b) then result := a else result := b; end;
1169 function nmin (a, b: SmallInt): SmallInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1170 function nmin (a, b: LongWord): LongWord; inline; overload; begin if (a < b) then result := a else result := b; end;
1171 function nmin (a, b: LongInt): LongInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1172 function nmin (a, b: Int64): Int64; inline; overload; begin if (a < b) then result := a else result := b; end;
1173 function nmin (a, b: UInt64): UInt64; inline; overload; begin if (a < b) then result := a else result := b; end;
1174 function nmin (a, b: Single): Single; inline; overload; begin if (a < b) then result := a else result := b; end;
1175 function nmin (a, b: Double): Double; inline; overload; begin if (a < b) then result := a else result := b; end;
1176 function nmin (a, b: Extended): Extended; inline; overload; begin if (a < b) then result := a else result := b; end;
1178 function nmax (a, b: Byte): Byte; inline; overload; begin if (a > b) then result := a else result := b; end;
1179 function nmax (a, b: ShortInt): ShortInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1180 function nmax (a, b: Word): Word; inline; overload; begin if (a > b) then result := a else result := b; end;
1181 function nmax (a, b: SmallInt): SmallInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1182 function nmax (a, b: LongWord): LongWord; inline; overload; begin if (a > b) then result := a else result := b; end;
1183 function nmax (a, b: LongInt): LongInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1184 function nmax (a, b: Int64): Int64; inline; overload; begin if (a > b) then result := a else result := b; end;
1185 function nmax (a, b: UInt64): UInt64; inline; overload; begin if (a > b) then result := a else result := b; end;
1186 function nmax (a, b: Single): Single; inline; overload; begin if (a > b) then result := a else result := b; end;
1187 function nmax (a, b: Double): Double; inline; overload; begin if (a > b) then result := a else result := b; end;
1188 function nmax (a, b: Extended): Extended; inline; overload; begin if (a > b) then result := a else result := b; end;
1190 function nclamp (v, a, b: Byte): Byte; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1191 function nclamp (v, a, b: ShortInt): ShortInt; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1192 function nclamp (v, a, b: Word): Word; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1193 function nclamp (v, a, b: SmallInt): SmallInt; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1194 function nclamp (v, a, b: LongWord): LongWord; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1195 function nclamp (v, a, b: LongInt): LongInt; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1196 function nclamp (v, a, b: Int64): Int64; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1197 function nclamp (v, a, b: UInt64): UInt64; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1198 function nclamp (v, a, b: Single): Single; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1199 function nclamp (v, a, b: Double): Double; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1200 function nclamp (v, a, b: Extended): Extended; inline; overload; begin if (v < a) then result := a else if (v > b) then result := b else result := v; end;
1203 // ////////////////////////////////////////////////////////////////////////// //
1204 {$IFDEF WINDOWS}
1205 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'msvcrt.dll' name '_snprintf';
1206 {$ELSE}
1207 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'libc' name 'snprintf';
1208 {$ENDIF}
1211 (*
1212 procedure conwriter (constref buf; len: SizeUInt);
1213 var
1214 ss: ShortString;
1215 slen: Integer;
1216 b: PByte;
1217 begin
1218 if (len < 1) then exit;
1219 b := PByte(@buf);
1220 while (len > 0) do
1221 begin
1222 if (len > 255) then slen := 255 else slen := Integer(len);
1223 Move(b^, ss[1], len);
1224 ss[0] := AnsiChar(slen);
1225 write(ss);
1226 b += slen;
1227 len -= slen;
1228 end;
1229 end;
1230 *)
1233 function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
1234 const
1236 PadZeroes: AnsiString = '00000000000000000000000000000000000000000000000000000000000000000000000';
1237 var
1253 var
1257 begin
1261 begin
1263 end
1264 else
1265 begin
1267 begin
1279 begin
1284 begin
1290 var
1292 begin
1298 var
1300 begin
1306 begin
1310 begin
1320 begin
1325 var
1328 begin
1330 begin
1334 end
1335 else
1336 begin
1341 repeat
1343 begin
1347 end
1348 else
1349 begin
1351 begin
1354 end
1366 var
1368 begin
1371 repeat
1373 begin
1377 end
1378 else
1379 begin
1381 begin
1384 end
1394 var
1396 begin
1398 begin
1406 var
1408 begin
1410 begin
1417 begin
1421 begin
1422 // print literal part
1425 // output literal part
1427 begin
1429 begin
1431 break;
1435 begin
1439 end
1440 else
1441 begin
1445 continue;
1447 // check if we have argument for this format string
1449 begin
1452 break;
1454 // skip percent
1458 // parse format; check for sign
1462 // parse width
1465 begin
1466 if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1470 begin
1476 end
1477 else
1478 begin
1482 // parse precision
1485 begin
1488 if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1491 begin
1498 // get format char
1502 // done parsing format, check for valid format chars
1503 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;
1504 // now write formatted string
1507 begin
1508 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;
1517 begin
1519 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'true')
1524 begin
1526 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('t'))
1531 begin
1536 else
1537 begin
1540 break;
1546 begin
1553 begin
1558 else
1559 begin
1562 break;
1565 //vtWideChar: begin end; // args[curarg].VWideChar (WideChar)
1569 begin
1576 begin
1582 begin
1584 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(trunc(args[curarg].VExtended^)));
1588 begin
1590 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], LongWord(trunc(args[curarg].VExtended^)));
1593 else
1594 begin
1597 break;
1601 begin
1609 begin
1618 begin
1626 else
1627 begin
1630 break;
1635 begin
1639 end
1640 else
1641 begin
1649 begin
1650 if (args[curarg].VObject <> nil) then ccname := args[curarg].VObject.Classname else ccname := '<nil>';
1656 begin
1657 if (args[curarg].VClass <> nil) then ccname := args[curarg].VClass.Classname else ccname := '<nil>';
1662 //vtPWideChar: begin end; // args[curarg].VPWideChar (PWideChar)
1664 begin
1669 //vtCurrency: begin end; // args[curarg].VCurrency (PCurrency)
1670 //vtVariant: begin end; // args[curarg].VVariant^ (PVariant)
1671 //vtInterface: begin end; // args[curarg].VInterface (Pointer);
1672 //vtWideString: begin end; // args[curarg].VWideString (Pointer);
1674 begin
1679 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1684 begin
1686 begin
1688 begin
1693 end
1694 else
1695 begin
1698 end
1699 else
1700 begin
1708 begin
1713 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1717 if (sign <> '-') then begin if zeropad then indent0(width-pclen) else indent(width-pclen); end;
1721 else
1722 begin
1725 break;
1733 (*
1734 var
1735 ss: ShortString;
1736 ls: AnsiString;
1737 i64: Int64 = -$A000000000;
1738 ui64: UInt64 = $A000000000;
1739 begin
1740 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']);
1741 writef(conwriter, 'test float:<%s;%u;%f;%g>'#10, [666.6942, 666.6942, 666.6942, 666.6942]);
1742 ss := 'fuckit';
1743 ls := 'FUCKIT';
1744 writef(conwriter, 'test ss:<%5s;%040s>'#10, [ss, ss]);
1745 writef(conwriter, 'test ls:<%5s;%040s>'#10, [ls, ls]);
1746 writef(conwriter, 'test pointer:<%s;%x;%p>'#10, [@ss, @ss, @ss]);
1747 writef(conwriter, 'test i64:<%s;%x;%015d;%u;%X>'#10, [i64, i64, i64, i64, i64]);
1748 writef(conwriter, 'test ui64:<%s;%x;%15d;%015u;%X>'#10, [ui64, ui64, ui64, ui64, ui64]);
1749 *)