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 // ////////////////////////////////////////////////////////////////////////// //
55 // does filename have one of ".wad", ".pk3", ".zip" extensions?
58 // does filepath have ".XXX:\" in it?
61 // adds ".wad" extension if filename doesn't have one of ".wad", ".pk3", ".zip"
64 // convert number to strig with nice commas
70 // `true` if strings are equal; ignoring case for cp1251
77 // `pathname` will be modified if path is valid
78 // `lastIsDir` should be `true` if we are searching for directory
79 // nobody cares about shitdoze, so i'll use the same code path for it
82 // they throws
86 // little endian
105 // big endian
162 type
165 // returns formatted string if `writerCB` is `nil`, empty string otherwise
166 function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
173 // returns string in single or double quotes
174 // single quotes supports only pascal-style '' for single quote char
175 // double quotes supports c-style escapes
176 // function will select quote mode automatically
180 type
182 private
183 //type PItemT = ^ItemT;
186 public
187 type
189 private
193 public
200 private
204 private
211 public
215 //WARNING! don't change list contents in `for ... in`!
223 public
230 implementation
233 // ////////////////////////////////////////////////////////////////////////// //
235 begin
242 begin
248 begin
253 // ////////////////////////////////////////////////////////////////////////// //
255 begin
263 begin
270 begin
276 begin
283 begin
290 begin
296 begin
303 begin
309 begin
315 begin
317 begin
325 // ////////////////////////////////////////////////////////////////////////// //
326 var
331 // ////////////////////////////////////////////////////////////////////////// //
332 const
334 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
335 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
336 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
337 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
338 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
339 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
340 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
342 );
346 var
348 begin
356 // ////////////////////////////////////////////////////////////////////////// //
357 // fast state-machine based UTF-8 decoder; using 8 bytes of memory
358 // code points from invalid range will never be valid, this is the property of the state machine
359 const
360 // see http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
362 // maps bytes to character classes
379 // maps a combination of a state of the automaton and a character class to a state
389 // ////////////////////////////////////////////////////////////////////////// //
390 constructor TUtf8DecoderFast.Create (v: Boolean{fuck you, fpc}); begin state := Accept; codepoint := 0; end;
396 function TUtf8DecoderFast.completeOrInvalid (): Boolean; inline; begin result := (state = Accept) or (state = Reject); end;
398 function TUtf8DecoderFast.decode (c: AnsiChar): Boolean; inline; overload; begin result := decode(Byte(c)); end;
401 var
403 begin
406 if (state <> Accept) then codepoint := (b and $3f) or (codepoint shl 6) else codepoint := ($ff shr tp) and b;
413 // ////////////////////////////////////////////////////////////////////////// //
415 begin
421 // ////////////////////////////////////////////////////////////////////////// //
423 var
426 begin
428 begin
430 begin
434 begin
437 exit;
445 var
449 begin
452 begin
454 end
456 begin
459 end
461 begin
465 end
467 begin
472 end
473 else
474 begin
479 begin
481 begin
483 begin
486 begin
488 begin
490 end
491 else
492 begin
496 exit;
503 // ////////////////////////////////////////////////////////////////////////// //
505 begin
510 begin
513 end
514 else
515 begin
524 // ////////////////////////////////////////////////////////////////////////// //
528 var
530 begin
533 begin
541 var
544 begin
547 begin
555 begin
558 end
560 begin
563 end
564 else
565 begin
572 var
575 begin
577 begin
585 // ////////////////////////////////////////////////////////////////////////// //
587 begin
594 begin
601 var
604 begin
607 begin
611 begin
614 begin
616 exit;
625 var
627 begin
631 begin
638 begin
640 begin
642 end
643 else
644 begin
646 begin
648 end
649 else
650 begin
662 begin
664 begin
666 end
667 else
668 begin
670 begin
672 end
673 else
674 begin
686 var
688 begin
696 // ////////////////////////////////////////////////////////////////////////// //
697 // utils
698 // `ch`: utf8 start
699 // -1: invalid utf8
701 begin
713 var
715 begin
719 begin
725 // check other sequence bytes
727 begin
737 // ////////////////////////////////////////////////////////////////////////// //
738 const
740 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
741 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
742 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
743 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
744 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
745 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
746 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
748 );
752 var
754 begin
755 (* The following encodings are valid, except for the 5 and 6 byte
756 * combinations:
757 * 0xxxxxxx
758 * 110xxxxx 10xxxxxx
759 * 1110xxxx 10xxxxxx 10xxxxxx
760 * 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
761 * 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
762 * 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
763 *)
771 // mask out unused bits
779 // now continue
781 begin
789 // done, try 1251
791 // alas
796 var
798 begin
802 begin
813 // ////////////////////////////////////////////////////////////////////////// //
814 // `pathname` will be modified if path is valid
815 // `lastIsDir` should be `true` if we are searching for directory
816 // nobody cares about shitdoze, so i'll use the same code path for it
818 var
826 begin
831 begin
832 // remove trailing slashes
835 // extract name
838 begin
842 // remove trailing slashes again
845 //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
846 // try the easiest case first
849 begin
851 begin
852 // i found her!
855 continue;
858 //writeln(Format('npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt, newname, curname, Integer(wantdir)]));
859 // alas, either not found, or invalid attributes
861 try
863 repeat
865 begin
866 // i found her!
870 break;
873 finally
883 begin
889 var
891 begin
894 begin
902 {$IFDEF ENDIAN_LITTLE}
903 begin
906 {$ELSE}
907 var
909 begin
912 begin
918 {$ENDIF}
921 {$IFDEF ENDIAN_LITTLE}
922 var
924 begin
927 begin
933 {$ELSE}
934 begin
937 {$ENDIF}
949 procedure writeIntBE (st: TStream; v: ShortInt); overload; begin writeIntegerBE(st, @v, 1); end;
951 procedure writeIntBE (st: TStream; v: SmallInt); overload; begin writeIntegerBE(st, @v, 2); end;
952 procedure writeIntBE (st: TStream; v: LongWord); overload; begin writeIntegerBE(st, @v, 4); end;
959 {$IFDEF ENDIAN_LITTLE}
960 begin
963 {$ELSE}
964 var
966 begin
969 begin
975 {$ENDIF}
978 {$IFDEF ENDIAN_LITTLE}
979 var
981 begin
984 begin
990 {$ELSE}
991 begin
994 {$ENDIF}
1015 // ////////////////////////////////////////////////////////////////////////// //
1016 function nmin (a, b: Byte): Byte; inline; overload; begin if (a < b) then result := a else result := b; end;
1017 function nmin (a, b: ShortInt): ShortInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1018 function nmin (a, b: Word): Word; inline; overload; begin if (a < b) then result := a else result := b; end;
1019 function nmin (a, b: SmallInt): SmallInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1020 function nmin (a, b: LongWord): LongWord; inline; overload; begin if (a < b) then result := a else result := b; end;
1021 function nmin (a, b: LongInt): LongInt; inline; overload; begin if (a < b) then result := a else result := b; end;
1022 function nmin (a, b: Int64): Int64; inline; overload; begin if (a < b) then result := a else result := b; end;
1023 function nmin (a, b: UInt64): UInt64; inline; overload; begin if (a < b) then result := a else result := b; end;
1024 function nmin (a, b: Single): Single; inline; overload; begin if (a < b) then result := a else result := b; end;
1025 function nmin (a, b: Double): Double; inline; overload; begin if (a < b) then result := a else result := b; end;
1026 function nmin (a, b: Extended): Extended; inline; overload; begin if (a < b) then result := a else result := b; end;
1028 function nmax (a, b: Byte): Byte; inline; overload; begin if (a > b) then result := a else result := b; end;
1029 function nmax (a, b: ShortInt): ShortInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1030 function nmax (a, b: Word): Word; inline; overload; begin if (a > b) then result := a else result := b; end;
1031 function nmax (a, b: SmallInt): SmallInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1032 function nmax (a, b: LongWord): LongWord; inline; overload; begin if (a > b) then result := a else result := b; end;
1033 function nmax (a, b: LongInt): LongInt; inline; overload; begin if (a > b) then result := a else result := b; end;
1034 function nmax (a, b: Int64): Int64; inline; overload; begin if (a > b) then result := a else result := b; end;
1035 function nmax (a, b: UInt64): UInt64; inline; overload; begin if (a > b) then result := a else result := b; end;
1036 function nmax (a, b: Single): Single; inline; overload; begin if (a > b) then result := a else result := b; end;
1037 function nmax (a, b: Double): Double; inline; overload; begin if (a > b) then result := a else result := b; end;
1038 function nmax (a, b: Extended): Extended; inline; overload; begin if (a > b) then result := a else result := b; end;
1040 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;
1041 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;
1042 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;
1043 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;
1044 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;
1045 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;
1046 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;
1047 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;
1048 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;
1049 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;
1050 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;
1053 // ////////////////////////////////////////////////////////////////////////// //
1054 {$IFDEF WINDOWS}
1055 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'msvcrt.dll' name '_snprintf';
1056 {$ELSE}
1057 function snprintf (buf: PAnsiChar; bufsize: SizeUInt; const fmt: PAnsiChar): SizeUInt; cdecl; varargs; external 'libc' name 'snprintf';
1058 {$ENDIF}
1061 (*
1062 procedure conwriter (constref buf; len: SizeUInt);
1063 var
1064 ss: ShortString;
1065 slen: Integer;
1066 b: PByte;
1067 begin
1068 if (len < 1) then exit;
1069 b := PByte(@buf);
1070 while (len > 0) do
1071 begin
1072 if (len > 255) then slen := 255 else slen := Integer(len);
1073 Move(b^, ss[1], len);
1074 ss[0] := AnsiChar(slen);
1075 write(ss);
1076 b += slen;
1077 len -= slen;
1078 end;
1079 end;
1080 *)
1083 function formatstrf (const fmt: AnsiString; args: array of const; writerCB: TFormatStrFCallback=nil): AnsiString;
1084 const
1086 PadZeroes: AnsiString = '00000000000000000000000000000000000000000000000000000000000000000000000';
1087 var
1102 var
1106 begin
1110 begin
1112 end
1113 else
1114 begin
1116 begin
1128 begin
1133 begin
1139 var
1141 begin
1147 var
1149 begin
1155 begin
1159 begin
1169 begin
1174 var
1177 begin
1179 begin
1183 end
1184 else
1185 begin
1190 repeat
1192 begin
1196 end
1197 else
1198 begin
1200 begin
1203 end
1215 var
1217 begin
1220 repeat
1222 begin
1226 end
1227 else
1228 begin
1230 begin
1233 end
1243 var
1245 begin
1247 begin
1255 var
1257 begin
1259 begin
1266 begin
1270 begin
1271 // print literal part
1274 // output literal part
1276 begin
1278 begin
1280 break;
1284 begin
1288 end
1289 else
1290 begin
1294 continue;
1296 // check if we have argument for this format string
1298 begin
1301 break;
1303 // skip percent
1307 // parse format; check for sign
1311 // parse width
1314 begin
1315 if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1319 begin
1325 end
1326 else
1327 begin
1331 // parse precision
1334 begin
1337 if (fmt[spos] < '0') or (fmt[spos] > '9') then begin xwrite('<INVALID FORMAT>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1340 begin
1347 // get format char
1351 // done parsing format, check for valid format chars
1352 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;
1353 // now write formatted string
1356 begin
1357 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;
1366 begin
1368 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], 'true')
1373 begin
1375 if args[curarg].VBoolean then strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], AnsiChar('t'))
1380 begin
1385 else
1386 begin
1389 break;
1395 begin
1402 begin
1407 else
1408 begin
1411 break;
1414 //vtWideChar: begin end; // args[curarg].VWideChar (WideChar)
1418 begin
1425 begin
1431 begin
1433 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], Integer(trunc(args[curarg].VExtended^)));
1437 begin
1439 strblen := snprintf(@strbuf[0], Length(strbuf), @fmtbuf[0], LongWord(trunc(args[curarg].VExtended^)));
1442 else
1443 begin
1446 break;
1450 begin
1458 begin
1467 begin
1475 else
1476 begin
1479 break;
1484 begin
1488 end
1489 else
1490 begin
1498 begin
1504 begin
1509 //vtPWideChar: begin end; // args[curarg].VPWideChar (PWideChar)
1511 begin
1516 //vtCurrency: begin end; // args[curarg].VCurrency (PCurrency)
1517 //vtVariant: begin end; // args[curarg].VVariant^ (PVariant)
1518 //vtInterface: begin end; // args[curarg].VInterface (Pointer);
1519 //vtWideString: begin end; // args[curarg].VWideString (Pointer);
1521 begin
1526 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1531 begin
1533 begin
1535 begin
1540 end
1541 else
1542 begin
1545 end
1546 else
1547 begin
1555 begin
1560 else begin xwrite('<INVALID FORMAT CHAR>'); writer((PAnsiChar(fmt)+spos-1)^, Length(fmt)-spos+1); break; end;
1564 if (sign <> '-') then begin if zeropad then indent0(width-pclen) else indent(width-pclen); end;
1568 else
1569 begin
1572 break;
1580 (*
1581 var
1582 ss: ShortString;
1583 ls: AnsiString;
1584 i64: Int64 = -$A000000000;
1585 ui64: UInt64 = $A000000000;
1586 begin
1587 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']);
1588 writef(conwriter, 'test float:<%s;%u;%f;%g>'#10, [666.6942, 666.6942, 666.6942, 666.6942]);
1589 ss := 'fuckit';
1590 ls := 'FUCKIT';
1591 writef(conwriter, 'test ss:<%5s;%040s>'#10, [ss, ss]);
1592 writef(conwriter, 'test ls:<%5s;%040s>'#10, [ls, ls]);
1593 writef(conwriter, 'test pointer:<%s;%x;%p>'#10, [@ss, @ss, @ss]);
1594 writef(conwriter, 'test i64:<%s;%x;%015d;%u;%X>'#10, [i64, i64, i64, i64, i64]);
1595 writef(conwriter, 'test ui64:<%s;%x;%15d;%015u;%X>'#10, [ui64, ui64, ui64, ui64, ui64]);
1596 *)