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; 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`!
239 public
246 implementation
249 // ////////////////////////////////////////////////////////////////////////// //
251 begin
258 begin
264 begin
269 // ////////////////////////////////////////////////////////////////////////// //
271 begin
279 begin
286 begin
292 begin
299 begin
306 begin
312 begin
319 begin
325 begin
331 begin
333 begin
341 // ////////////////////////////////////////////////////////////////////////// //
342 var
347 // ////////////////////////////////////////////////////////////////////////// //
348 const
350 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
351 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
352 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
353 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
354 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
355 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
356 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
358 );
362 var
364 begin
372 // ////////////////////////////////////////////////////////////////////////// //
373 // fast state-machine based UTF-8 decoder; using 8 bytes of memory
374 // code points from invalid range will never be valid, this is the property of the state machine
375 const
376 // see http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
378 // maps bytes to character classes
395 // maps a combination of a state of the automaton and a character class to a state
405 // ////////////////////////////////////////////////////////////////////////// //
406 constructor TUtf8DecoderFast.Create (v: Boolean{fuck you, fpc}); begin state := Accept; codepoint := 0; end;
412 function TUtf8DecoderFast.completeOrInvalid (): Boolean; inline; begin result := (state = Accept) or (state = Reject); end;
414 function TUtf8DecoderFast.decode (c: AnsiChar): Boolean; inline; overload; begin result := decode(Byte(c)); end;
417 var
419 begin
422 if (state <> Accept) then codepoint := (b and $3f) or (codepoint shl 6) else codepoint := ($ff shr tp) and b;
429 // ////////////////////////////////////////////////////////////////////////// //
431 begin
437 // ////////////////////////////////////////////////////////////////////////// //
439 var
442 begin
444 begin
446 begin
450 begin
453 exit;
461 var
465 begin
468 begin
470 end
472 begin
475 end
477 begin
481 end
483 begin
488 end
489 else
490 begin
495 begin
497 begin
499 begin
502 begin
504 begin
506 end
507 else
508 begin
512 exit;
519 // ////////////////////////////////////////////////////////////////////////// //
521 begin
526 begin
529 end
530 else
531 begin
540 // ////////////////////////////////////////////////////////////////////////// //
544 var
546 begin
549 begin
557 var
560 begin
563 begin
571 begin
574 end
576 begin
579 end
580 else
581 begin
588 var
591 begin
593 begin
601 // ////////////////////////////////////////////////////////////////////////// //
603 var
606 begin
609 begin
612 begin
614 exit;
624 var
627 begin
632 begin
644 var
647 begin
651 begin
654 begin
656 begin
658 end
659 else
660 begin
663 exit;
670 begin
677 // strips out name from `fn`, leaving trailing slash
679 var
682 begin
687 begin
696 // ends with '/' or '\'?
698 begin
700 begin
702 end
703 else
704 begin
710 // strips extra trailing slashes in `path, and extra leading slashes in `fn`
711 // will add slash to `path`, even if `fn` is empty!
713 var
715 begin
719 if (Length(result) > 0) and ((result[Length(result)] <> '/') and (result[Length(result)] <> '\')) then result += '/';
721 begin
723 //FIXME: make this faster!
724 while (Length(result) > 0) and ((result[Length(result)] = '/') or (result[Length(result)] = '\')) do
725 begin
734 var
736 begin
743 begin
750 var
753 begin
757 begin
759 begin
762 begin
765 begin
767 exit;
777 var
779 begin
783 begin
790 begin
792 begin
794 end
795 else
796 begin
798 begin
800 end
801 else
802 begin
814 begin
816 begin
818 end
819 else
820 begin
822 begin
824 end
825 else
826 begin
838 var
840 begin
849 var
852 begin
854 begin
856 begin
860 exit;
863 // nothing to do
868 // ////////////////////////////////////////////////////////////////////////// //
869 // utils
870 // `ch`: utf8 start
871 // -1: invalid utf8
873 begin
885 var
887 begin
891 begin
897 // check other sequence bytes
899 begin
909 // ////////////////////////////////////////////////////////////////////////// //
910 const
912 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
913 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
914 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
915 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
916 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
917 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
918 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
920 );
924 var
926 begin
927 (* The following encodings are valid, except for the 5 and 6 byte
928 * combinations:
929 * 0xxxxxxx
930 * 110xxxxx 10xxxxxx
931 * 1110xxxx 10xxxxxx 10xxxxxx
932 * 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
933 * 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
934 * 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
935 *)
943 // mask out unused bits
951 // now continue
953 begin
961 // done, try 1251
963 // alas
968 var
970 begin
974 begin
985 // ////////////////////////////////////////////////////////////////////////// //
986 // `pathname` will be modified if path is valid
987 // `lastIsDir` should be `true` if we are searching for directory
988 // nobody cares about shitdoze, so i'll use the same code path for it
990 var
998 begin
1003 begin
1004 // remove trailing slashes
1007 // extract name
1010 begin
1014 // remove trailing slashes again
1017 //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
1018 // try the easiest case first
1021 begin
1023 begin
1024 // i found her!
1027 continue;
1030 //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
1031 // alas, either not found, or invalid attributes
1033 try
1035 repeat
1037 begin
1038 // i found her!
1042 break;
1045 finally
1055 begin
1061 var
1063 begin
1066 begin
1067 if not findFileCI(path, true) then raise Exception.Create('can''t create file "'+pathname+'"');
1074 {$IFDEF ENDIAN_LITTLE}
1075 begin
1078 {$ELSE}
1079 var
1081 begin
1084 begin
1090 {$ENDIF}
1093 {$IFDEF ENDIAN_LITTLE}
1094 var
1096 begin
1099 begin
1105 {$ELSE}
1106 begin
1109 {$ENDIF}
1121 procedure writeIntBE (st: TStream; v: ShortInt); overload; begin writeIntegerBE(st, @v, 1); end;
1123 procedure writeIntBE (st: TStream; v: SmallInt); overload; begin writeIntegerBE(st, @v, 2); end;
1124 procedure writeIntBE (st: TStream; v: LongWord); overload; begin writeIntegerBE(st, @v, 4); end;
1125 procedure writeIntBE (st: TStream; v: LongInt); overload; begin writeIntegerBE(st, @v, 4); end;
1131 {$IFDEF ENDIAN_LITTLE}
1132 begin
1135 {$ELSE}
1136 var
1138 begin
1141 begin
1147 {$ENDIF}
1150 {$IFDEF ENDIAN_LITTLE}
1151 var
1153 begin
1156 begin
1162 {$ELSE}
1163 begin
1166 {$ENDIF}
1187 // ////////////////////////////////////////////////////////////////////////// //
1188 function nmin (a, b: Byte): Byte; inline; overload; begin if (a < b) then result := a else result := b; end;
1189 function nmin (a, b: ShortInt): ShortInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1190 function nmin (a, b: Word): Word; inline; overload; begin if (a < b) then result := a else result := b; end;
1191 function nmin (a, b: SmallInt): SmallInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1192 function nmin (a, b: LongWord): LongWord; inline; overload; begin if (a < b) then result := a else result := b; end;
1193 function nmin (a, b: LongInt): LongInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1194 function nmin (a, b: Int64): Int64; inline; overload; begin if (a < b) then result := a else result := b; end;
1195 function nmin (a, b: UInt64): UInt64; inline; overload; begin if (a < b) then result := a else result := b; end;
1196 function nmin (a, b: Single): Single; inline; overload; begin if (a < b) then result := a else result := b; end;
1197 function nmin (a, b: Double): Double; inline; overload; begin if (a < b) then result := a else result := b; end;
1198 function nmin (a, b: Extended): Extended; inline; overload; begin if (a < b) then result := a else result := b; end;
1200 function nmax (a, b: Byte): Byte; inline; overload; begin if (a > b) then result := a else result := b; end;
1201 function nmax (a, b: ShortInt): ShortInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1202 function nmax (a, b: Word): Word; inline; overload; begin if (a > b) then result := a else result := b; end;
1203 function nmax (a, b: SmallInt): SmallInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1204 function nmax (a, b: LongWord): LongWord; inline; overload; begin if (a > b) then result := a else result := b; end;
1205 function nmax (a, b: LongInt): LongInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1206 function nmax (a, b: Int64): Int64; inline; overload; begin if (a > b) then result := a else result := b; end;
1207 function nmax (a, b: UInt64): UInt64; inline; overload; begin if (a > b) then result := a else result := b; end;
1208 function nmax (a, b: Single): Single; inline; overload; begin if (a > b) then result := a else result := b; end;
1209 function nmax (a, b: Double): Double; inline; overload; begin if (a > b) then result := a else result := b; end;
1210 function nmax (a, b: Extended): Extended; inline; overload; begin if (a > b) then result := a else result := b; end;
1212 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;
1213 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;
1214 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;
1215 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;
1216 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;
1217 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;
1218 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;
1219 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;
1220 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;
1221 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;
1222 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;
1225 // ////////////////////////////////////////////////////////////////////////// //
1226 {$IFDEF WINDOWS}
1227 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'msvcrt.dll' name '_snprintf';
1228 {$ELSE}
1229 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'libc' name 'snprintf';
1230 {$ENDIF}
1233 (*
1234 procedure conwriter (constref buf; len: SizeUInt);
1235 var
1236 ss: ShortString;
1237 slen: Integer;
1238 b: PByte;
1239 begin
1240 if (len < 1) then exit;
1241 b := PByte(@buf);
1242 while (len > 0) do
1243 begin
1244 if (len > 255) then slen := 255 else slen := Integer(len);
1245 Move(b^, ss[1], len);
1246 ss[0] := AnsiChar(slen);
1247 write(ss);
1248 b += slen;
1249 len -= slen;
1250 end;
1251 end;
1252 *)
1255 function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
1256 const
1258 PadZeroes: AnsiString = '00000000000000000000000000000000000000000000000000000000000000000000000';
1259 var
1275 var
1279 begin
1283 begin
1285 end
1286 else
1287 begin
1289 begin
1301 begin
1306 begin
1312 var
1314 begin
1320 var
1322 begin
1328 begin
1332 begin
1342 begin
1347 var
1350 begin
1352 begin
1356 end
1357 else
1358 begin
1363 repeat
1365 begin
1369 end
1370 else
1371 begin
1373 begin
1376 end
1388 var
1390 begin
1393 repeat
1395 begin
1399 end
1400 else
1401 begin
1403 begin
1406 end
1416 var
1418 begin
1420 begin
1428 var
1430 begin
1432 begin
1439 begin
1443 begin
1444 // print literal part
1447 // output literal part
1449 begin
1451 begin
1453 break;
1457 begin
1461 end
1462 else
1463 begin
1467 continue;
1469 // check if we have argument for this format string
1471 begin
1474 break;
1476 // skip percent
1480 // parse format; check for sign
1484 // parse width
1487 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;
1492 begin
1498 end
1499 else
1500 begin
1504 // parse precision
1507 begin
1510 if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1513 begin
1520 // get format char
1524 // done parsing format, check for valid format chars
1525 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;
1526 // now write formatted string
1529 begin
1530 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;
1539 begin
1541 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'true')
1546 begin
1548 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('t'))
1553 begin
1558 else
1559 begin
1562 break;
1568 begin
1575 begin
1580 else
1581 begin
1584 break;
1587 //vtWideChar: begin end; // args[curarg].VWideChar (WideChar)
1591 begin
1598 begin
1604 begin
1606 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(trunc(args[curarg].VExtended^)));
1610 begin
1612 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], LongWord(trunc(args[curarg].VExtended^)));
1615 else
1616 begin
1619 break;
1623 begin
1631 begin
1640 begin
1648 else
1649 begin
1652 break;
1657 begin
1661 end
1662 else
1663 begin
1671 begin
1672 if (args[curarg].VObject <> nil) then ccname := args[curarg].VObject.Classname else ccname := '<nil>';
1678 begin
1679 if (args[curarg].VClass <> nil) then ccname := args[curarg].VClass.Classname else ccname := '<nil>';
1684 //vtPWideChar: begin end; // args[curarg].VPWideChar (PWideChar)
1686 begin
1691 //vtCurrency: begin end; // args[curarg].VCurrency (PCurrency)
1692 //vtVariant: begin end; // args[curarg].VVariant^ (PVariant)
1693 //vtInterface: begin end; // args[curarg].VInterface (Pointer);
1694 //vtWideString: begin end; // args[curarg].VWideString (Pointer);
1696 begin
1701 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1706 begin
1708 begin
1710 begin
1715 end
1716 else
1717 begin
1720 end
1721 else
1722 begin
1730 begin
1735 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1739 if (sign <> '-') then begin if zeropad then indent0(width-pclen) else indent(width-pclen); end;
1743 else
1744 begin
1747 break;
1755 (*
1756 var
1757 ss: ShortString;
1758 ls: AnsiString;
1759 i64: Int64 = -$A000000000;
1760 ui64: UInt64 = $A000000000;
1761 begin
1762 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']);
1763 writef(conwriter, 'test float:<%s;%u;%f;%g>'#10, [666.6942, 666.6942, 666.6942, 666.6942]);
1764 ss := 'fuckit';
1765 ls := 'FUCKIT';
1766 writef(conwriter, 'test ss:<%5s;%040s>'#10, [ss, ss]);
1767 writef(conwriter, 'test ls:<%5s;%040s>'#10, [ls, ls]);
1768 writef(conwriter, 'test pointer:<%s;%x;%p>'#10, [@ss, @ss, @ss]);
1769 writef(conwriter, 'test i64:<%s;%x;%015d;%u;%X>'#10, [i64, i64, i64, i64, i64]);
1770 writef(conwriter, 'test ui64:<%s;%x;%15d;%015u;%X>'#10, [ui64, ui64, ui64, ui64, ui64]);
1771 *)