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
86 // `true` if strings are equal; ignoring case for cp1251
93 // `pathname` will be modified if path is valid
94 // `lastIsDir` should be `true` if we are searching for directory
95 // nobody cares about shitdoze, so i'll use the same code path for it
98 // they throws
102 // little endian
121 // big endian
178 type
181 // returns formatted string if `writerCB` is `nil`, empty string otherwise
182 function formatstrf (const fmt: AnsiString; const args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
189 // returns string in single or double quotes
190 // single quotes supports only pascal-style '' for single quote char
191 // double quotes supports c-style escapes
192 // function will select quote mode automatically
196 type
198 private
199 //type PItemT = ^ItemT;
202 public
203 type
205 private
209 public
216 private
220 private
227 public
231 //WARNING! don't change list contents in `for ... in`!
241 public
248 implementation
251 // ////////////////////////////////////////////////////////////////////////// //
253 begin
260 begin
266 begin
271 // ////////////////////////////////////////////////////////////////////////// //
273 begin
281 begin
288 begin
294 begin
301 begin
308 begin
314 begin
321 begin
327 begin
333 var
335 begin
337 begin
347 var
349 begin
351 begin
358 var
360 begin
362 begin
365 end
366 else
367 begin
373 // ////////////////////////////////////////////////////////////////////////// //
374 var
379 // ////////////////////////////////////////////////////////////////////////// //
380 const
382 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
383 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
384 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
385 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
386 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
387 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
388 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
390 );
394 var
396 begin
404 // ////////////////////////////////////////////////////////////////////////// //
405 // fast state-machine based UTF-8 decoder; using 8 bytes of memory
406 // code points from invalid range will never be valid, this is the property of the state machine
407 const
408 // see http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
410 // maps bytes to character classes
427 // maps a combination of a state of the automaton and a character class to a state
437 // ////////////////////////////////////////////////////////////////////////// //
438 constructor TUtf8DecoderFast.Create (v: Boolean{fuck you, fpc}); begin state := Accept; codepoint := 0; end;
444 function TUtf8DecoderFast.completeOrInvalid (): Boolean; inline; begin result := (state = Accept) or (state = Reject); end;
446 function TUtf8DecoderFast.decode (c: AnsiChar): Boolean; inline; overload; begin result := decode(Byte(c)); end;
449 var
451 begin
454 if (state <> Accept) then codepoint := (b and $3f) or (codepoint shl 6) else codepoint := ($ff shr tp) and b;
461 // ////////////////////////////////////////////////////////////////////////// //
463 begin
469 // ////////////////////////////////////////////////////////////////////////// //
471 var
474 begin
476 begin
478 begin
482 begin
485 exit;
493 var
497 begin
500 begin
502 end
504 begin
507 end
509 begin
513 end
515 begin
520 end
521 else
522 begin
527 begin
529 begin
531 begin
534 begin
536 begin
538 end
539 else
540 begin
544 exit;
551 // ////////////////////////////////////////////////////////////////////////// //
553 begin
558 begin
561 end
562 else
563 begin
572 // ////////////////////////////////////////////////////////////////////////// //
576 var
578 begin
581 begin
589 var
592 begin
595 begin
603 begin
606 end
608 begin
611 end
612 else
613 begin
620 var
623 begin
625 begin
633 // ////////////////////////////////////////////////////////////////////////// //
635 var
638 begin
641 begin
644 begin
646 exit;
656 var
659 begin
664 begin
676 var
679 begin
683 begin
686 begin
688 begin
690 end
691 else
692 begin
695 exit;
702 begin
709 // strips out name from `fn`, leaving trailing slash
711 var
714 begin
719 begin
728 // ends with '/' or '\'?
730 begin
732 begin
734 end
735 else
736 begin
742 // strips extra trailing slashes in `path, and extra leading slashes in `fn`
743 // will add slash to `path`, even if `fn` is empty!
745 var
747 begin
751 if (Length(result) > 0) and ((result[Length(result)] <> '/') and (result[Length(result)] <> '\')) then result += '/';
753 begin
755 //FIXME: make this faster!
756 while (Length(result) > 0) and ((result[Length(result)] = '/') or (result[Length(result)] = '\')) do
757 begin
766 var
768 begin
775 begin
782 var
785 begin
789 begin
791 begin
794 begin
797 begin
799 exit;
809 var
811 begin
815 begin
822 begin
824 begin
826 end
827 else
828 begin
830 begin
832 end
833 else
834 begin
846 begin
848 begin
850 end
851 else
852 begin
854 begin
856 end
857 else
858 begin
870 var
872 begin
881 var
884 begin
886 begin
888 begin
892 exit;
895 // nothing to do
900 // ////////////////////////////////////////////////////////////////////////// //
901 // utils
902 // `ch`: utf8 start
903 // -1: invalid utf8
905 begin
917 var
919 begin
923 begin
929 // check other sequence bytes
931 begin
941 // ////////////////////////////////////////////////////////////////////////// //
942 const
944 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
945 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
946 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
947 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
948 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
949 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
950 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
952 );
956 var
958 begin
959 (* The following encodings are valid, except for the 5 and 6 byte
960 * combinations:
961 * 0xxxxxxx
962 * 110xxxxx 10xxxxxx
963 * 1110xxxx 10xxxxxx 10xxxxxx
964 * 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
965 * 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
966 * 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
967 *)
975 // mask out unused bits
983 // now continue
985 begin
993 // done, try 1251
995 // alas
1000 var
1002 begin
1006 begin
1017 // ////////////////////////////////////////////////////////////////////////// //
1018 // `pathname` will be modified if path is valid
1019 // `lastIsDir` should be `true` if we are searching for directory
1020 // nobody cares about shitdoze, so i'll use the same code path for it
1022 var
1030 begin
1035 begin
1036 // remove trailing slashes
1039 // extract name
1042 begin
1046 // remove trailing slashes again
1049 //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
1050 // try the easiest case first
1053 begin
1055 begin
1056 // i found her!
1059 continue;
1062 //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
1063 // alas, either not found, or invalid attributes
1065 try
1067 repeat
1069 begin
1070 // i found her!
1074 break;
1077 finally
1087 begin
1093 var
1095 begin
1098 begin
1099 if not findFileCI(path, true) then raise Exception.Create('can''t create file "'+pathname+'"');
1106 {$IFDEF ENDIAN_LITTLE}
1107 begin
1110 {$ELSE}
1111 var
1113 begin
1116 begin
1122 {$ENDIF}
1125 {$IFDEF ENDIAN_LITTLE}
1126 var
1128 begin
1131 begin
1137 {$ELSE}
1138 begin
1141 {$ENDIF}
1153 procedure writeIntBE (st: TStream; v: ShortInt); overload; begin writeIntegerBE(st, @v, 1); end;
1155 procedure writeIntBE (st: TStream; v: SmallInt); overload; begin writeIntegerBE(st, @v, 2); end;
1156 procedure writeIntBE (st: TStream; v: LongWord); overload; begin writeIntegerBE(st, @v, 4); end;
1157 procedure writeIntBE (st: TStream; v: LongInt); overload; begin writeIntegerBE(st, @v, 4); end;
1163 {$IFDEF ENDIAN_LITTLE}
1164 begin
1167 {$ELSE}
1168 var
1170 begin
1173 begin
1179 {$ENDIF}
1182 {$IFDEF ENDIAN_LITTLE}
1183 var
1185 begin
1188 begin
1194 {$ELSE}
1195 begin
1198 {$ENDIF}
1219 // ////////////////////////////////////////////////////////////////////////// //
1220 function nmin (a, b: Byte): Byte; inline; overload; begin if (a < b) then result := a else result := b; end;
1221 function nmin (a, b: ShortInt): ShortInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1222 function nmin (a, b: Word): Word; inline; overload; begin if (a < b) then result := a else result := b; end;
1223 function nmin (a, b: SmallInt): SmallInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1224 function nmin (a, b: LongWord): LongWord; inline; overload; begin if (a < b) then result := a else result := b; end;
1225 function nmin (a, b: LongInt): LongInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1226 function nmin (a, b: Int64): Int64; inline; overload; begin if (a < b) then result := a else result := b; end;
1227 function nmin (a, b: UInt64): UInt64; inline; overload; begin if (a < b) then result := a else result := b; end;
1228 function nmin (a, b: Single): Single; inline; overload; begin if (a < b) then result := a else result := b; end;
1229 function nmin (a, b: Double): Double; inline; overload; begin if (a < b) then result := a else result := b; end;
1230 function nmin (a, b: Extended): Extended; inline; overload; begin if (a < b) then result := a else result := b; end;
1232 function nmax (a, b: Byte): Byte; inline; overload; begin if (a > b) then result := a else result := b; end;
1233 function nmax (a, b: ShortInt): ShortInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1234 function nmax (a, b: Word): Word; inline; overload; begin if (a > b) then result := a else result := b; end;
1235 function nmax (a, b: SmallInt): SmallInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1236 function nmax (a, b: LongWord): LongWord; inline; overload; begin if (a > b) then result := a else result := b; end;
1237 function nmax (a, b: LongInt): LongInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1238 function nmax (a, b: Int64): Int64; inline; overload; begin if (a > b) then result := a else result := b; end;
1239 function nmax (a, b: UInt64): UInt64; inline; overload; begin if (a > b) then result := a else result := b; end;
1240 function nmax (a, b: Single): Single; inline; overload; begin if (a > b) then result := a else result := b; end;
1241 function nmax (a, b: Double): Double; inline; overload; begin if (a > b) then result := a else result := b; end;
1242 function nmax (a, b: Extended): Extended; inline; overload; begin if (a > b) then result := a else result := b; end;
1244 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;
1245 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;
1246 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;
1247 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;
1248 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;
1249 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;
1250 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;
1251 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;
1252 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;
1253 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;
1254 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;
1257 // ////////////////////////////////////////////////////////////////////////// //
1258 {$IFDEF WINDOWS}
1259 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'msvcrt.dll' name '_snprintf';
1260 {$ELSE}
1261 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'libc' name 'snprintf';
1262 {$ENDIF}
1265 (*
1266 procedure conwriter (constref buf; len: SizeUInt);
1267 var
1268 ss: ShortString;
1269 slen: Integer;
1270 b: PByte;
1271 begin
1272 if (len < 1) then exit;
1273 b := PByte(@buf);
1274 while (len > 0) do
1275 begin
1276 if (len > 255) then slen := 255 else slen := Integer(len);
1277 Move(b^, ss[1], len);
1278 ss[0] := AnsiChar(slen);
1279 write(ss);
1280 b += slen;
1281 len -= slen;
1282 end;
1283 end;
1284 *)
1287 function formatstrf (const fmt: AnsiString; const args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
1288 const
1290 PadZeroes: AnsiString = '00000000000000000000000000000000000000000000000000000000000000000000000';
1291 var
1307 var
1311 begin
1315 begin
1317 end
1318 else
1319 begin
1321 begin
1333 begin
1338 begin
1344 var
1346 begin
1352 var
1354 begin
1360 begin
1364 begin
1374 begin
1379 var
1382 begin
1384 begin
1388 end
1389 else
1390 begin
1395 repeat
1397 begin
1401 end
1402 else
1403 begin
1405 begin
1408 end
1420 var
1422 begin
1425 repeat
1427 begin
1431 end
1432 else
1433 begin
1435 begin
1438 end
1448 var
1450 begin
1452 begin
1460 var
1462 begin
1464 begin
1471 begin
1475 begin
1476 // print literal part
1479 // output literal part
1481 begin
1483 begin
1485 break;
1489 begin
1493 end
1494 else
1495 begin
1499 continue;
1501 // check if we have argument for this format string
1503 begin
1506 break;
1508 // skip percent
1512 // parse format; check for sign
1516 // parse width
1519 begin
1520 if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1524 begin
1530 end
1531 else
1532 begin
1536 // parse precision
1539 begin
1542 if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1545 begin
1552 // get format char
1556 // done parsing format, check for valid format chars
1557 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;
1558 // now write formatted string
1561 begin
1562 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;
1571 begin
1573 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'true')
1578 begin
1580 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('t'))
1585 begin
1590 else
1591 begin
1594 break;
1600 begin
1607 begin
1612 else
1613 begin
1616 break;
1619 //vtWideChar: begin end; // args[curarg].VWideChar (WideChar)
1623 begin
1630 begin
1636 begin
1638 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(trunc(args[curarg].VExtended^)));
1642 begin
1644 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], LongWord(trunc(args[curarg].VExtended^)));
1647 else
1648 begin
1651 break;
1655 begin
1663 begin
1672 begin
1680 else
1681 begin
1684 break;
1689 begin
1693 end
1694 else
1695 begin
1703 begin
1704 if (args[curarg].VObject <> nil) then ccname := args[curarg].VObject.Classname else ccname := '<nil>';
1710 begin
1711 if (args[curarg].VClass <> nil) then ccname := args[curarg].VClass.Classname else ccname := '<nil>';
1716 //vtPWideChar: begin end; // args[curarg].VPWideChar (PWideChar)
1718 begin
1723 //vtCurrency: begin end; // args[curarg].VCurrency (PCurrency)
1724 //vtVariant: begin end; // args[curarg].VVariant^ (PVariant)
1725 //vtInterface: begin end; // args[curarg].VInterface (Pointer);
1726 //vtWideString: begin end; // args[curarg].VWideString (Pointer);
1728 begin
1733 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1738 begin
1740 begin
1742 begin
1747 end
1748 else
1749 begin
1752 end
1753 else
1754 begin
1762 begin
1767 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1771 if (sign <> '-') then begin if zeropad then indent0(width-pclen) else indent(width-pclen); end;
1775 else
1776 begin
1779 break;
1787 (*
1788 var
1789 ss: ShortString;
1790 ls: AnsiString;
1791 i64: Int64 = -$A000000000;
1792 ui64: UInt64 = $A000000000;
1793 begin
1794 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']);
1795 writef(conwriter, 'test float:<%s;%u;%f;%g>'#10, [666.6942, 666.6942, 666.6942, 666.6942]);
1796 ss := 'fuckit';
1797 ls := 'FUCKIT';
1798 writef(conwriter, 'test ss:<%5s;%040s>'#10, [ss, ss]);
1799 writef(conwriter, 'test ls:<%5s;%040s>'#10, [ls, ls]);
1800 writef(conwriter, 'test pointer:<%s;%x;%p>'#10, [@ss, @ss, @ss]);
1801 writef(conwriter, 'test i64:<%s;%x;%015d;%u;%X>'#10, [i64, i64, i64, i64, i64]);
1802 writef(conwriter, 'test ui64:<%s;%x;%15d;%015u;%X>'#10, [ui64, ui64, ui64, ui64, ui64]);
1803 *)