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
1252 var
1256 begin
1260 begin
1262 end
1263 else
1264 begin
1266 begin
1278 begin
1283 begin
1289 var
1291 begin
1297 var
1299 begin
1305 begin
1309 begin
1319 begin
1324 var
1327 begin
1329 begin
1333 end
1334 else
1335 begin
1340 repeat
1342 begin
1346 end
1347 else
1348 begin
1350 begin
1353 end
1365 var
1367 begin
1370 repeat
1372 begin
1376 end
1377 else
1378 begin
1380 begin
1383 end
1393 var
1395 begin
1397 begin
1405 var
1407 begin
1409 begin
1416 begin
1420 begin
1421 // print literal part
1424 // output literal part
1426 begin
1428 begin
1430 break;
1434 begin
1438 end
1439 else
1440 begin
1444 continue;
1446 // check if we have argument for this format string
1448 begin
1451 break;
1453 // skip percent
1457 // parse format; check for sign
1461 // parse width
1464 begin
1465 if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1469 begin
1475 end
1476 else
1477 begin
1481 // parse precision
1484 begin
1487 if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1490 begin
1497 // get format char
1501 // done parsing format, check for valid format chars
1502 if not (fmtch in ['s','u','d','x','X','p','f','g','c']) then begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1503 // now write formatted string
1506 begin
1507 if not (fmtch in ['s','u','d','x','X']) then begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1516 begin
1518 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'true')
1523 begin
1525 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('t'))
1530 begin
1535 else
1536 begin
1539 break;
1545 begin
1552 begin
1557 else
1558 begin
1561 break;
1564 //vtWideChar: begin end; // args[curarg].VWideChar (WideChar)
1568 begin
1575 begin
1581 begin
1583 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(trunc(args[curarg].VExtended^)));
1587 begin
1589 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], LongWord(trunc(args[curarg].VExtended^)));
1592 else
1593 begin
1596 break;
1600 begin
1608 begin
1617 begin
1625 else
1626 begin
1629 break;
1634 begin
1638 end
1639 else
1640 begin
1648 begin
1654 begin
1659 //vtPWideChar: begin end; // args[curarg].VPWideChar (PWideChar)
1661 begin
1666 //vtCurrency: begin end; // args[curarg].VCurrency (PCurrency)
1667 //vtVariant: begin end; // args[curarg].VVariant^ (PVariant)
1668 //vtInterface: begin end; // args[curarg].VInterface (Pointer);
1669 //vtWideString: begin end; // args[curarg].VWideString (Pointer);
1671 begin
1676 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1681 begin
1683 begin
1685 begin
1690 end
1691 else
1692 begin
1695 end
1696 else
1697 begin
1705 begin
1710 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1714 if (sign <> '-') then begin if zeropad then indent0(width-pclen) else indent(width-pclen); end;
1718 else
1719 begin
1722 break;
1730 (*
1731 var
1732 ss: ShortString;
1733 ls: AnsiString;
1734 i64: Int64 = -$A000000000;
1735 ui64: UInt64 = $A000000000;
1736 begin
1737 writef(conwriter, 'test int:<%s> bool:<%s:%02d:%c> bool:<%s:%02d:%c>; char:<%2s;%c;%d>!'#10, [42, true, true, true, false, false, false, 'A', 'A', 'A']);
1738 writef(conwriter, 'test float:<%s;%u;%f;%g>'#10, [666.6942, 666.6942, 666.6942, 666.6942]);
1739 ss := 'fuckit';
1740 ls := 'FUCKIT';
1741 writef(conwriter, 'test ss:<%5s;%040s>'#10, [ss, ss]);
1742 writef(conwriter, 'test ls:<%5s;%040s>'#10, [ls, ls]);
1743 writef(conwriter, 'test pointer:<%s;%x;%p>'#10, [@ss, @ss, @ss]);
1744 writef(conwriter, 'test i64:<%s;%x;%015d;%u;%X>'#10, [i64, i64, i64, i64, i64]);
1745 writef(conwriter, 'test ui64:<%s;%x;%15d;%015u;%X>'#10, [ui64, ui64, ui64, ui64, ui64]);
1746 *)