1 (* Copyright (C) DooM 2D:Forever Developers
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.
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.
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/>.
25 // does filename have one of ".wad", ".pk3", ".zip" extensions?
26 function hasWadExtension (fn
: AnsiString): Boolean;
28 // does filepath have ".XXX:\" in it?
29 function isWadPath (fn
: AnsiString): Boolean;
31 // adds ".wad" extension if filename doesn't have one of ".wad", ".pk3", ".zip"
32 function addWadExtension (fn
: AnsiString): AnsiString;
34 // convert number to strig with nice commas
35 function Int64ToStrComma (i
: Int64): AnsiString;
37 function UpCase1251 (ch
: Char): Char;
38 function LoCase1251 (ch
: Char): Char;
40 // `true` if strings are equal; ignoring case for cp1251
41 function StrEquCI1251 (const s0
, s1
: AnsiString): Boolean;
43 function utf8Valid (const s
: AnsiString): Boolean;
45 function utf8to1251 (s
: AnsiString): AnsiString;
47 // `pathname` will be modified if path is valid
48 // `lastIsDir` should be `true` if we are searching for directory
49 // nobody cares about shitdoze, so i'll use the same code path for it
50 function findFileCI (var pathname
: AnsiString; lastIsDir
: Boolean=false): Boolean;
52 // returns name (the same if no file found)
53 function findFileCIStr (pathname
: AnsiString; lastIsDir
: Boolean=false): AnsiString;
56 function openDiskFileRO (pathname
: AnsiString): TStream
;
57 function createDiskFile (pathname
: AnsiString): TStream
;
60 procedure writeInt (st
: TStream
; v
: Byte); overload
;
61 procedure writeInt (st
: TStream
; v
: ShortInt); overload
;
62 procedure writeInt (st
: TStream
; v
: Word); overload
;
63 procedure writeInt (st
: TStream
; v
: SmallInt); overload
;
64 procedure writeInt (st
: TStream
; v
: LongWord); overload
;
65 procedure writeInt (st
: TStream
; v
: LongInt); overload
;
66 procedure writeInt (st
: TStream
; v
: Int64); overload
;
67 procedure writeInt (st
: TStream
; v
: UInt64); overload
;
69 function readByte (st
: TStream
): Byte;
70 function readShortInt (st
: TStream
): ShortInt;
71 function readWord (st
: TStream
): Word;
72 function readSmallInt (st
: TStream
): SmallInt;
73 function readLongWord (st
: TStream
): LongWord;
74 function readLongInt (st
: TStream
): LongInt;
75 function readInt64 (st
: TStream
): Int64;
76 function readUInt64 (st
: TStream
): UInt64;
79 procedure writeIntBE (st
: TStream
; v
: Byte); overload
;
80 procedure writeIntBE (st
: TStream
; v
: ShortInt); overload
;
81 procedure writeIntBE (st
: TStream
; v
: Word); overload
;
82 procedure writeIntBE (st
: TStream
; v
: SmallInt); overload
;
83 procedure writeIntBE (st
: TStream
; v
: LongWord); overload
;
84 procedure writeIntBE (st
: TStream
; v
: LongInt); overload
;
85 procedure writeIntBE (st
: TStream
; v
: Int64); overload
;
86 procedure writeIntBE (st
: TStream
; v
: UInt64); overload
;
88 function readByteBE (st
: TStream
): Byte;
89 function readShortIntBE (st
: TStream
): ShortInt;
90 function readWordBE (st
: TStream
): Word;
91 function readSmallIntBE (st
: TStream
): SmallInt;
92 function readLongWordBE (st
: TStream
): LongWord;
93 function readLongIntBE (st
: TStream
): LongInt;
94 function readInt64BE (st
: TStream
): Int64;
95 function readUInt64BE (st
: TStream
): UInt64;
101 function hasWadExtension (fn
: AnsiString): Boolean;
103 fn
:= ExtractFileExt(fn
);
104 result
:= StrEquCI1251(fn
, '.wad') or StrEquCI1251(fn
, '.pk3') or StrEquCI1251(fn
, '.zip');
108 function addWadExtension (fn
: AnsiString): AnsiString;
111 if not hasWadExtension(result
) then result
:= result
+'.wad';
115 function isWadPath (fn
: AnsiString): Boolean;
124 if (p
= 0) or (length(fn
)-p
< 1) then break
;
125 if (p
-4 > 1) and (fn
[p
-4] = '.') and ((fn
[p
+1] = '\') or (fn
[p
+1] = '/')) then
127 s
:= Copy(fn
, p
-4, 4);
128 if StrEquCI1251(s
, '.wad') or StrEquCI1251(s
, '.pk3') or StrEquCI1251(s
, '.zip') then
139 function Int64ToStrComma (i
: Int64): AnsiString;
144 f
:= Length(result
)+1;
147 Dec(f
, 3); Insert(',', result
, f
);
152 function UpCase1251 (ch
: Char): Char;
156 if (ch
>= 'a') and (ch
<= 'z') then Dec(ch
, 32);
160 if (ch
>= #224) and (ch
<= #255) then
167 #184, #186, #191: Dec(ch
, 16);
176 function LoCase1251 (ch
: Char): Char;
180 if (ch
>= 'A') and (ch
<= 'Z') then Inc(ch
, 32);
184 if (ch
>= #192) and (ch
<= #223) then
191 #168, #170, #175: Inc(ch
, 16);
200 function StrEquCI1251 (const s0
, s1
: AnsiString): Boolean;
205 if length(s0
) <> length(s1
) then exit
;
206 for i
:= 1 to length(s0
) do if UpCase1251(s0
[i
]) <> UpCase1251(s1
[i
]) then exit
;
211 // ////////////////////////////////////////////////////////////////////////// //
215 function utf8CodeLen (ch
: Word): Integer;
217 if ch
< $80 then begin result
:= 1; exit
; end;
218 if (ch
and $FE) = $FC then begin result
:= 6; exit
; end;
219 if (ch
and $FC) = $F8 then begin result
:= 5; exit
; end;
220 if (ch
and $F8) = $F0 then begin result
:= 4; exit
; end;
221 if (ch
and $F0) = $E0 then begin result
:= 3; exit
; end;
222 if (ch
and $E0) = $C0 then begin result
:= 2; exit
; end;
223 result
:= -1; // invalid
227 function utf8Valid (const s
: AnsiString): Boolean;
233 while pos
<= length(s
) do
235 len
:= utf8CodeLen(Byte(s
[pos
]));
236 if len
< 1 then exit
; // invalid sequence start
237 if pos
+len
-1 > length(s
) then exit
; // out of chars in string
240 // check other sequence bytes
243 if (Byte(s
[pos
]) and $C0) <> $80 then exit
;
252 // ////////////////////////////////////////////////////////////////////////// //
254 uni2wint
: array [128..255] of Word = (
255 $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
256 $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
257 $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
258 $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
259 $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
260 $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
261 $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
262 $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
266 function decodeUtf8Char (s
: AnsiString; var pos
: Integer): char;
270 (* The following encodings are valid, except for the 5 and 6 byte
274 * 1110xxxx 10xxxxxx 10xxxxxx
275 * 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
276 * 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
277 * 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
280 if pos
> length(s
) then exit
;
284 if b
< $80 then begin result
:= char(b
); exit
; end;
286 // mask out unused bits
287 if (b
and $FE) = $FC then b
:= b
and $01
288 else if (b
and $FC) = $F8 then b
:= b
and $03
289 else if (b
and $F8) = $F0 then b
:= b
and $07
290 else if (b
and $F0) = $E0 then b
:= b
and $0F
291 else if (b
and $E0) = $C0 then b
:= b
and $1F
292 else exit
; // invalid utf8
295 while pos
<= length(s
) do
298 if (c
and $C0) <> $80 then break
; // no more
300 b
:= b
or (c
and $3F);
305 for c
:= 128 to 255 do if uni2wint
[c
] = b
then begin result
:= char(c
and $FF); exit
; end;
310 function utf8to1251 (s
: AnsiString): AnsiString;
314 if not utf8Valid(s
) then begin result
:= s
; exit
; end;
316 while pos
<= length(s
) do
318 if Byte(s
[pos
]) >= $80 then break
;
321 if pos
> length(s
) then begin result
:= s
; exit
; end; // nothing to do here
324 while pos
<= length(s
) do result
:= result
+decodeUtf8Char(s
, pos
);
328 // ////////////////////////////////////////////////////////////////////////// //
329 // `pathname` will be modified if path is valid
330 // `lastIsDir` should be `true` if we are searching for directory
331 // nobody cares about shitdoze, so i'll use the same code path for it
332 function findFileCI (var pathname
: AnsiString; lastIsDir
: Boolean=false): Boolean;
336 newname
: AnsiString = '';
343 result
:= (length(npt
) > 0);
344 if (length(npt
) > 0) and ((npt
[1] = '/') or (npt
[1] = '\')) then newname
:= '/';
345 while length(npt
) > 0 do
347 // remove trailing slashes
348 while (length(npt
) > 0) and ((npt
[1] = '/') or (npt
[1] = '\')) do Delete(npt
, 1, 1);
349 if length(npt
) = 0 then break
;
352 while (length(npt
) > 0) and (npt
[1] <> '/') and (npt
[1] <> '\') do
354 curname
:= curname
+npt
[1];
357 // remove trailing slashes again
358 while (length(npt
) > 0) and ((npt
[1] = '/') or (npt
[1] = '\')) do Delete(npt
, 1, 1);
359 wantdir
:= lastIsDir
or (length(npt
) > 0); // do we want directory here?
360 writeln(Format('0: npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt
, newname
, curname
, Integer(wantdir
)]));
361 // try the easiest case first
362 attr
:= FileGetAttr(newname
+curname
);
365 if wantdir
= ((attr
and faDirectory
) <> 0) then
368 writeln(Format('3: npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d; found=tan', [npt
, newname
, curname
, Integer(wantdir
)]));
369 newname
:= newname
+curname
;
370 if wantdir
then newname
:= newname
+'/';
374 writeln(Format('1: npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d', [npt
, newname
, curname
, Integer(wantdir
)]));
375 // alas, either not found, or invalid attributes
378 if FindFirst(newname
+'*', faAnyFile
, sr
) = 0 then
380 if (wantdir
= ((sr
.attr
and faDirectory
) <> 0)) and StrEquCI1251(sr
.name
, curname
) then
383 newname
:= newname
+sr
.name
;
384 if wantdir
then newname
:= newname
+'/';
388 until FindNext(sr
) <> 0;
394 writeln(Format('2: npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d; found=tan', [npt
, newname
, curname
, Integer(wantdir
)]));
398 writeln(Format('2: npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d; found=ona', [npt
, newname
, curname
, Integer(wantdir
)]));
400 if not foundher
then begin newname
:= ''; result
:= false; break
; end;
402 writeln(Format('4: npt=[%s]; newname=[%s]; curname=[%s]; wantdir=%d; found=ona', [npt
, newname
, curname
, Integer(wantdir
)]));
403 if result
then pathname
:= newname
;
406 function findFileCIStr (pathname
: AnsiString; lastIsDir
: Boolean=false): AnsiString;
411 if not findFileCI(s
, lastIsDir
) then s
:= pathname
;
412 writeln(Format('***: pathname=[%s]; s=[%s]', [pathname
, s
]));
416 function openDiskFileRO (pathname
: AnsiString): TStream
;
418 if not findFileCI(pathname
) then raise Exception
.Create('can''t open file "'+pathname
+'"');
419 result
:= TFileStream
.Create(pathname
, fmOpenRead
or {fmShareDenyWrite}fmShareDenyNone
);
422 function createDiskFile (pathname
: AnsiString): TStream
;
426 path
:= ExtractFilePath(pathname
);
427 if length(path
) > 0 then
429 if not findFileCI(path
, true) then raise Exception
.Create('can''t create file "'+pathname
+'"');
431 result
:= TFileStream
.Create(path
+ExtractFileName(pathname
), fmCreate
);
435 procedure writeIntegerLE (st
: TStream
; vp
: Pointer; size
: Integer);
436 {$IFDEF ENDIAN_LITTLE}
438 st
.writeBuffer(vp
^, size
);
444 p
:= PByte(vp
)+size
-1;
447 st
.writeBuffer(p
^, 1);
454 procedure writeIntegerBE (st
: TStream
; vp
: Pointer; size
: Integer);
455 {$IFDEF ENDIAN_LITTLE}
459 p
:= PByte(vp
)+size
-1;
462 st
.writeBuffer(p
^, 1);
469 st
.writeBuffer(vp
^, size
);
473 procedure writeInt (st
: TStream
; v
: Byte); overload
; begin writeIntegerLE(st
, @v
, 1); end;
474 procedure writeInt (st
: TStream
; v
: ShortInt); overload
; begin writeIntegerLE(st
, @v
, 1); end;
475 procedure writeInt (st
: TStream
; v
: Word); overload
; begin writeIntegerLE(st
, @v
, 2); end;
476 procedure writeInt (st
: TStream
; v
: SmallInt); overload
; begin writeIntegerLE(st
, @v
, 2); end;
477 procedure writeInt (st
: TStream
; v
: LongWord); overload
; begin writeIntegerLE(st
, @v
, 4); end;
478 procedure writeInt (st
: TStream
; v
: LongInt); overload
; begin writeIntegerLE(st
, @v
, 4); end;
479 procedure writeInt (st
: TStream
; v
: Int64); overload
; begin writeIntegerLE(st
, @v
, 8); end;
480 procedure writeInt (st
: TStream
; v
: UInt64); overload
; begin writeIntegerLE(st
, @v
, 8); end;
482 procedure writeIntBE (st
: TStream
; v
: Byte); overload
; begin writeIntegerBE(st
, @v
, 1); end;
483 procedure writeIntBE (st
: TStream
; v
: ShortInt); overload
; begin writeIntegerBE(st
, @v
, 1); end;
484 procedure writeIntBE (st
: TStream
; v
: Word); overload
; begin writeIntegerBE(st
, @v
, 2); end;
485 procedure writeIntBE (st
: TStream
; v
: SmallInt); overload
; begin writeIntegerBE(st
, @v
, 2); end;
486 procedure writeIntBE (st
: TStream
; v
: LongWord); overload
; begin writeIntegerBE(st
, @v
, 4); end;
487 procedure writeIntBE (st
: TStream
; v
: LongInt); overload
; begin writeIntegerBE(st
, @v
, 4); end;
488 procedure writeIntBE (st
: TStream
; v
: Int64); overload
; begin writeIntegerBE(st
, @v
, 8); end;
489 procedure writeIntBE (st
: TStream
; v
: UInt64); overload
; begin writeIntegerBE(st
, @v
, 8); end;
492 procedure readIntegerLE (st
: TStream
; vp
: Pointer; size
: Integer);
493 {$IFDEF ENDIAN_LITTLE}
495 st
.readBuffer(vp
^, size
);
501 p
:= PByte(vp
)+size
-1;
504 st
.readBuffer(p
^, 1);
511 procedure readIntegerBE (st
: TStream
; vp
: Pointer; size
: Integer);
512 {$IFDEF ENDIAN_LITTLE}
516 p
:= PByte(vp
)+size
-1;
519 st
.readBuffer(p
^, 1);
526 st
.readBuffer(vp
^, size
);
530 function readByte (st
: TStream
): Byte; begin readIntegerLE(st
, @result
, 1); end;
531 function readShortInt (st
: TStream
): ShortInt; begin readIntegerLE(st
, @result
, 1); end;
532 function readWord (st
: TStream
): Word; begin readIntegerLE(st
, @result
, 2); end;
533 function readSmallInt (st
: TStream
): SmallInt; begin readIntegerLE(st
, @result
, 2); end;
534 function readLongWord (st
: TStream
): LongWord; begin readIntegerLE(st
, @result
, 4); end;
535 function readLongInt (st
: TStream
): LongInt; begin readIntegerLE(st
, @result
, 4); end;
536 function readInt64 (st
: TStream
): Int64; begin readIntegerLE(st
, @result
, 8); end;
537 function readUInt64 (st
: TStream
): UInt64; begin readIntegerLE(st
, @result
, 8); end;
539 function readByteBE (st
: TStream
): Byte; begin readIntegerBE(st
, @result
, 1); end;
540 function readShortIntBE (st
: TStream
): ShortInt; begin readIntegerBE(st
, @result
, 1); end;
541 function readWordBE (st
: TStream
): Word; begin readIntegerBE(st
, @result
, 2); end;
542 function readSmallIntBE (st
: TStream
): SmallInt; begin readIntegerBE(st
, @result
, 2); end;
543 function readLongWordBE (st
: TStream
): LongWord; begin readIntegerBE(st
, @result
, 4); end;
544 function readLongIntBE (st
: TStream
): LongInt; begin readIntegerBE(st
, @result
, 4); end;
545 function readInt64BE (st
: TStream
): Int64; begin readIntegerBE(st
, @result
, 8); end;
546 function readUInt64BE (st
: TStream
): UInt64; begin readIntegerBE(st
, @result
, 8); end;