├── ANSI.PAS ├── AR.PAS ├── ARGS.PAS ├── CSTRING.PAS ├── DBB.PAS ├── DBM.PAS ├── DETECT.PAS ├── EXCACHE.PAS ├── EXMS.PAS ├── KMINPUT.PAS ├── LICENSE ├── MAKEFILE ├── PSON.PAS ├── QSORT.PAS ├── RC4.PAS ├── READARC.PAS ├── README.MD ├── STR.PAS ├── STRBIN.PAS ├── SYSTEM2.PAS ├── UJSON.PAS ├── UPPP.PAS ├── UTAR.PAS ├── WINCB.PAS ├── dynarr.pas ├── dynstr.pas ├── hashmap.pas ├── lzpmem.pas ├── memframe.pas ├── npbm.pas ├── pcxrle.pas └── rebuild.pas /ANSI.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT Ansi; 24 | 25 | INTERFACE 26 | 27 | CONST 28 | ANSI_ESC = CHR($1b); 29 | 30 | BLACK = 0; 31 | RED = 1; 32 | GREEN = 2; 33 | YELLOW = 3; 34 | BLUE = 4; 35 | MAGENTA = 5; 36 | CYAN = 6; 37 | WHITE = 7; 38 | 39 | CLS = ANSI_ESC + '[2J'; 40 | CLREOL = ANSI_ESC + '[K'; 41 | 42 | CONST 43 | ansi_enabled : BOOLEAN = TRUE; 44 | 45 | FUNCTION fg(clr : BYTE) : STRING; 46 | FUNCTION bg(clr : BYTE) : STRING; 47 | 48 | IMPLEMENTATION 49 | 50 | USES Detect; 51 | 52 | FUNCTION fg(clr : BYTE) : STRING; 53 | BEGIN 54 | IF ansi_enabled THEN 55 | fg := ANSI_ESC + '[3' + CHR($30 + (clr mod 8)) + 'm' 56 | ELSE fg := ''; 57 | END; 58 | 59 | FUNCTION bg(clr : BYTE) : STRING; 60 | BEGIN 61 | IF ansi_enabled THEN 62 | bg := ANSI_ESC + '[4' + CHR($30 + (clr mod 8)) + 'm' 63 | ELSE bg := ''; 64 | END; 65 | 66 | BEGIN 67 | ansi_enabled := IsAnsiSys AND (NOT IsOutputRedirected); 68 | END. 69 | -------------------------------------------------------------------------------- /AR.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2025 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT ar; 24 | 25 | INTERFACE 26 | 27 | USES system2, dynarr; 28 | 29 | TYPE 30 | ARFILE = BFILE; 31 | 32 | PArFileEntry = ^TArFileEntry; 33 | TArFileEntry = RECORD 34 | name : STRING[16]; 35 | ofs : LONGINT; 36 | size : LONGINT; 37 | END; 38 | 39 | FUNCTION IsArFile(VAR f : ARFILE; ofs : LONGINT) : BOOLEAN; 40 | PROCEDURE ReadDir(VAR FileArray : TArray; VAR f : ARFILE; ofs : LONGINT); 41 | FUNCTION Find(VAR FileArray : TArray; name : STRING) : PArFileEntry; 42 | PROCEDURE Create(VAR f : ARFILE); 43 | PROCEDURE AddHeader(VAR f : ARFILE; name : STRING; len : LONGINT); 44 | 45 | IMPLEMENTATION 46 | 47 | USES Memframe; 48 | 49 | TYPE 50 | ArFileEntry = RECORD 51 | name : ARRAY[1..16] OF CHAR; 52 | mod_time : ARRAY[1..12] OF CHAR; 53 | owner : ARRAY[1..6] OF CHAR; 54 | group : ARRAY[1..6] OF CHAR; 55 | attr : ARRAY[1..8] OF CHAR; 56 | size : ARRAY[1..10] OF CHAR; 57 | ending : WORD; 58 | END; 59 | 60 | FUNCTION IsArFile(VAR f : ARFILE; ofs : LONGINT) : BOOLEAN; 61 | VAR 62 | s : STRING; 63 | BEGIN 64 | Seek(f, ofs); 65 | BlockRead(f, s[1], 8); 66 | s[0] := #8; 67 | IsArFile := s = ('!' + #$0A); 68 | END; 69 | 70 | PROCEDURE ReadDir(VAR FileArray : TArray; VAR f : ARFILE; ofs : LONGINT); 71 | VAR 72 | c : TArFileEntry; 73 | w : WORD; 74 | frec : ArFileEntry; 75 | BEGIN 76 | dynarr.Init(FileArray, SizeOf(c), NIL); 77 | Seek(f, ofs + 8); 78 | WHILE NOT EOF(f) DO BEGIN 79 | FillChar(c, SizeOf(c), #0); 80 | w := BlockRead(f, frec, SizeOf(frec)); 81 | IF w <> SizeOf(frec) THEN BREAK; 82 | IF frec.ending <> $0A60 THEN BREAK; 83 | c.name[0] := #16; 84 | Move(frec.name, c.name[1], 16); 85 | FOR w := 1 TO 16 DO BEGIN 86 | c.name[w] := upcase(c.name[w]); 87 | IF c.name[w] = '/' THEN c.name[w] := '\' 88 | ELSE IF c.name[w] < ' ' THEN c.name[w] := ' '; 89 | END; 90 | WHILE (c.name[0] <> #0) AND (c.name[ORD(c.name[0])] IN [' ', '\']) DO DEC(c.name[0]); 91 | c.ofs := FilePos(f); 92 | c.size := 0; 93 | FOR w := 1 TO 10 DO BEGIN 94 | IF frec.size[w] IN ['0'..'9'] THEN BEGIN 95 | c.size := c.size * 10 + (ORD(frec.size[w]) - ORD('0')); 96 | END; 97 | END; 98 | Seek(f, FilePos(f) + c.size); 99 | IF (FilePos(f) AND 1) <> 0 THEN Seek(f, FilePos(f) + 1); 100 | dynarr.Add(FileArray, c); 101 | END; 102 | END; 103 | 104 | FUNCTION Find(VAR FileArray : TArray; name : STRING) : PArFileEntry; 105 | VAR 106 | n : STRING[16]; 107 | i : INTEGER; 108 | r : POINTER; 109 | rec : PArFileEntry; 110 | BEGIN 111 | r := NIL; 112 | n := name; 113 | FOR i := 1 TO ORD(n[0]) DO n[i] := upcase(n[i]); 114 | i := 0; 115 | WHILE i < dynarr.GetLength(FileArray) DO BEGIN 116 | rec := dynarr.GetPtr(FileArray, i); 117 | IF rec^.name = n THEN BEGIN r := rec; BREAK; END; 118 | INC(i); 119 | END; 120 | Find := r; 121 | END; 122 | 123 | PROCEDURE Create(VAR f : ARFILE); 124 | VAR 125 | s : STRING; 126 | BEGIN 127 | s := '!' + #$0A; 128 | BlockWrite(f, s[1], 8); 129 | Truncate(f); 130 | END; 131 | 132 | PROCEDURE AddHeader(VAR f : ARFILE; name : STRING; len : LONGINT); 133 | VAR 134 | frec : ArFileEntry; 135 | s : STRING; 136 | i : INTEGER; 137 | BEGIN 138 | IF (FilePos(f) AND 1) <> 0 THEN BEGIN 139 | i := 0; 140 | BlockWrite(f, i, 1); 141 | END; 142 | name := name + '/'; 143 | FillChar(frec, SizeOf(frec), #0); 144 | frec.ending := $0A60; 145 | i := Length(name); 146 | IF i > 16 THEN i := 16; 147 | Move(name[1], frec.name, i); 148 | Str(len, s); 149 | Move(s[1], frec.size, Length(s)); 150 | BlockWrite(f, frec, SizeOf(frec)); 151 | END; 152 | 153 | END. 154 | -------------------------------------------------------------------------------- /ARGS.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DosWorld/libsystem2/027eab3e2992a3ecfbf54a144f31e7ab74a89d98/ARGS.PAS -------------------------------------------------------------------------------- /CSTRING.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT CString; 24 | 25 | INTERFACE 26 | 27 | { memory area } 28 | 29 | FUNCTION memcpy(VAR dst, src; num : WORD) : POINTER; 30 | FUNCTION memmove(VAR dst, src; num : WORD) : POINTER; 31 | FUNCTION memcmp(VAR p1, p2; num : WORD) : INTEGER; 32 | FUNCTION memchr(VAR p; c: CHAR; num : WORD) : PCHAR; 33 | 34 | { strings area } 35 | 36 | FUNCTION strlen(str : PCHAR) : WORD; 37 | 38 | FUNCTION strcpy(dst, src : PCHAR) : PCHAR; 39 | FUNCTION strncpy(dst, src : PCHAR; num : WORD ) : PCHAR; 40 | 41 | FUNCTION strcat(dst, src : PCHAR) : PCHAR; 42 | FUNCTION strncat(dst, src : PCHAR; num : WORD) : PCHAR; 43 | 44 | FUNCTION strcmp(str1, str2 : PCHAR) : INTEGER; 45 | FUNCTION strncmp(str1, str2 : PCHAR; num : WORD) : INTEGER; 46 | 47 | FUNCTION strchr(p : PCHAR; c : CHAR) : PCHAR; 48 | FUNCTION strrchr(p : PCHAR; c : CHAR) : PCHAR; 49 | 50 | FUNCTION strstr(str1, str2 : PCHAR) : PCHAR; 51 | 52 | { non-standard functions } 53 | 54 | PROCEDURE strupr(p : PCHAR); 55 | PROCEDURE strlwr(p : PCHAR); 56 | 57 | FUNCTION strhash(p : PCHAR):WORD; 58 | 59 | FUNCTION strpas(p : PCHAR) : STRING; 60 | FUNCTION strpcopy(dest : PCHAR; source : STRING) : PCHAR; 61 | 62 | IMPLEMENTATION 63 | 64 | { memory area } 65 | 66 | FUNCTION memcpy(VAR dst, src; num : WORD) : POINTER;ASSEMBLER; 67 | ASM 68 | push ds 69 | mov cx, num 70 | les di, dst 71 | lds si, src 72 | push es 73 | push di 74 | cld 75 | rep movsb 76 | pop ax 77 | pop dx 78 | pop ds 79 | END; 80 | 81 | FUNCTION memmove(VAR dst, src; num : WORD) : POINTER;ASSEMBLER; 82 | ASM 83 | push ds 84 | mov cx, num 85 | les di, dst 86 | lds si, src 87 | push es 88 | push di 89 | mov ax, ds 90 | mov bx, es 91 | cmp ax, bx 92 | jnz @nooverlap 93 | cmp di, si 94 | jl @nooverlap 95 | std 96 | add di, cx 97 | add si, cx 98 | rep movsb 99 | jmp @end 100 | @nooverlap: 101 | cld 102 | rep movsb 103 | @end: pop ax 104 | pop dx 105 | pop ds 106 | END; 107 | 108 | FUNCTION memcmp(VAR p1, p2; num : WORD) : INTEGER;ASSEMBLER; 109 | ASM 110 | push ds 111 | mov cx, num 112 | les di, p1 113 | lds si, p2 114 | cld 115 | @cont: 116 | xor ax, ax 117 | or cx, cx 118 | jz @diff 119 | mov ah, es:[di] 120 | inc di 121 | lodsb 122 | dec cx 123 | cmp ah, al 124 | jnz @diff 125 | jmp @cont 126 | @diff: sub ah, al 127 | mov al, ah 128 | cbw 129 | pop ds 130 | END; 131 | 132 | FUNCTION memchr(VAR p; c: CHAR; num : WORD) : PCHAR;ASSEMBLER; 133 | ASM 134 | push es 135 | cld 136 | mov cx, num 137 | les di, p 138 | repne scasb 139 | or cx, cx 140 | jz @notfound 141 | mov dx, es 142 | mov ax, di 143 | dec ax 144 | jmp @end 145 | @notfound: 146 | xor ax, ax 147 | mov dx, ax 148 | @end: 149 | pop es 150 | END; 151 | 152 | { strings area } 153 | 154 | FUNCTION strlen(str : PCHAR) : WORD;ASSEMBLER; 155 | ASM 156 | push es 157 | cld 158 | les di, str 159 | xor ax, ax 160 | mov cx, ax 161 | dec cx 162 | repnz scasb 163 | pop es 164 | mov ax, cx 165 | neg ax 166 | dec ax 167 | dec ax 168 | END; 169 | 170 | FUNCTION strcpy(dst, src : PCHAR) : PCHAR;ASSEMBLER; 171 | ASM 172 | push ds 173 | push es 174 | lds si, src 175 | les di, dst 176 | push es 177 | push di 178 | cld 179 | @cont: lodsb 180 | stosb 181 | or al, al 182 | jnz @cont 183 | pop ax 184 | pop dx 185 | pop es 186 | pop ds 187 | END; 188 | 189 | FUNCTION strncpy(dst, src : PCHAR; num : WORD ) : PCHAR;ASSEMBLER; 190 | ASM 191 | push ds 192 | push es 193 | mov cx, num 194 | lds si, src 195 | les di, dst 196 | push es 197 | push di 198 | cld 199 | @cont: or cx, cx 200 | jz @pad 201 | lodsb 202 | or al, al 203 | jz @pad 204 | stosb 205 | dec cx 206 | jmp @cont 207 | @pad: xor al, al 208 | or cx, cx 209 | jz @end 210 | stosb 211 | dec cx 212 | jmp @pad 213 | @end: pop ax 214 | pop dx 215 | pop es 216 | pop ds 217 | END; 218 | 219 | FUNCTION strcat(dst, src : PCHAR) : PCHAR;ASSEMBLER; 220 | ASM 221 | push es 222 | cld 223 | les di, dst 224 | push es 225 | push di 226 | xor ax, ax 227 | mov cx, ax 228 | dec cx 229 | repnz scasb 230 | dec di 231 | push ds 232 | lds si, src 233 | @cont: lodsb 234 | stosb 235 | or al, al 236 | jz @end 237 | jmp @cont 238 | @end: 239 | pop ds 240 | pop ax 241 | pop dx 242 | pop es 243 | END; 244 | 245 | FUNCTION strncat(dst, src : PCHAR; num : WORD) : PCHAR;ASSEMBLER; 246 | ASM 247 | push es 248 | cld 249 | les di, dst 250 | push es 251 | push di 252 | xor ax, ax 253 | mov cx, ax 254 | dec cx 255 | repnz scasb 256 | dec di 257 | mov cx, num 258 | push ds 259 | lds si, src 260 | @cont: or cx, cx 261 | jz @end 262 | lodsb 263 | or al, al 264 | jz @end 265 | stosb 266 | dec cx 267 | jmp @cont 268 | @end: xor al, al 269 | stosb 270 | pop ds 271 | pop ax 272 | pop dx 273 | pop es 274 | END; 275 | 276 | FUNCTION strcmp(str1, str2 : PCHAR) : INTEGER;ASSEMBLER; 277 | ASM 278 | push ds 279 | les di, str1 280 | lds si, str2 281 | cld 282 | @cont: 283 | mov ah, es:[di] 284 | inc di 285 | lodsb 286 | cmp ah, al 287 | jnz @diff 288 | or al, al 289 | jz @diff 290 | jmp @cont 291 | @diff: sub ah, al 292 | mov al, ah 293 | cbw 294 | pop ds 295 | END; 296 | 297 | FUNCTION strncmp(str1, str2 : PCHAR; num : WORD) : INTEGER;ASSEMBLER; 298 | ASM 299 | push ds 300 | mov cx, num 301 | les di, str1 302 | lds si, str2 303 | cld 304 | @cont: xor ax, ax 305 | or cx, cx 306 | jz @diff 307 | mov ah, es:[di] 308 | inc di 309 | lodsb 310 | dec cx 311 | cmp ah, al 312 | jnz @diff 313 | or al, al 314 | jz @diff 315 | jmp @cont 316 | @diff: sub ah, al 317 | mov al, ah 318 | cbw 319 | pop ds 320 | END; 321 | 322 | FUNCTION strchr(p : PCHAR; c : CHAR) : PCHAR;ASSEMBLER; 323 | ASM 324 | push es 325 | cld 326 | mov al, 0 327 | les di, p 328 | push di 329 | mov cx, $FFFF 330 | push cx 331 | repne scasb 332 | neg cx 333 | mov bx, cx 334 | mov al, c 335 | pop cx 336 | pop di 337 | repne scasb 338 | neg cx 339 | cmp cx, bx 340 | jnc @notfound 341 | mov dx, es 342 | mov ax, di 343 | dec ax 344 | jmp @end 345 | @notfound: 346 | xor ax, ax 347 | mov dx, ax 348 | @end: 349 | pop es 350 | END; 351 | 352 | FUNCTION strrchr(p : PCHAR; c : CHAR) : PCHAR;ASSEMBLER; 353 | ASM 354 | push es 355 | cld 356 | mov al, 0 357 | les di, p 358 | mov cx, $FFFF 359 | cld 360 | repne scasb 361 | neg cx 362 | inc cx 363 | mov al, c 364 | std 365 | repne scasb 366 | or cx, cx 367 | jz @notfound 368 | mov dx, es 369 | mov ax, di 370 | inc ax 371 | jmp @end 372 | @notfound: 373 | xor ax, ax 374 | mov dx, ax 375 | @end: 376 | pop es 377 | END; 378 | 379 | FUNCTION strstr(str1, str2 : PCHAR) : PCHAR; 380 | VAR r : PCHAR; 381 | len : WORD; 382 | BEGIN 383 | r := NIL; 384 | len := strlen(str2); 385 | CASE len OF 386 | 0: r := str1; 387 | 1: r := strchr(str1, str2^); 388 | ELSE BEGIN 389 | r := strchr(str1, str2^); 390 | WHILE r <> NIL DO BEGIN 391 | IF memcmp(r, str2, len) = 0 THEN BREAK; 392 | str1 := r + 1; 393 | END; 394 | END; 395 | END; 396 | strstr := r; 397 | END; 398 | 399 | 400 | 401 | 402 | 403 | 404 | { non-standard functions } 405 | 406 | PROCEDURE strupr(p : PCHAR);ASSEMBLER; 407 | ASM 408 | push ds 409 | 410 | lds si, p 411 | push ds 412 | pop es 413 | cld 414 | mov di, si 415 | @cont: 416 | lodsb 417 | cmp al, 'a' 418 | jl @noconv 419 | cmp al, 'z' 420 | jg @noconv 421 | sub al, $20 422 | @noconv: 423 | stosb 424 | or al, al 425 | jnz @cont 426 | @end: 427 | pop ds 428 | END; 429 | 430 | PROCEDURE strlwr(p : PCHAR);ASSEMBLER; 431 | ASM 432 | push ds 433 | 434 | lds si, p 435 | push ds 436 | pop es 437 | cld 438 | mov di, si 439 | @cont: 440 | lodsb 441 | cmp al, 'A' 442 | jl @noconv 443 | cmp al, 'Z' 444 | jg @noconv 445 | add al, $20 446 | @noconv: 447 | stosb 448 | or al, al 449 | jnz @cont 450 | @end: 451 | pop ds 452 | END; 453 | 454 | FUNCTION strhash(p : PCHAR):WORD; 455 | VAR h : WORD; 456 | BEGIN 457 | h := 0; 458 | WHILE p[0] <> #0 DO BEGIN h := h * 33 + ORD(p[0]); Inc(p); END; 459 | strhash := h; 460 | END; 461 | 462 | FUNCTION strpas(p : PCHAR) : STRING; 463 | VAR r : STRING; 464 | len : WORD; 465 | BEGIN 466 | len := strlen(p) AND $FF; 467 | Move(p^, r[1], len); 468 | r[0] := chr(len); 469 | strpas := r; 470 | END; 471 | 472 | FUNCTION strpcopy(dest : PCHAR; source : STRING) : PCHAR; 473 | VAR l : BYTE; 474 | BEGIN 475 | l := ORD(source[0]); 476 | IF l <> 0 THEN BEGIN 477 | Move(source[1], dest[0], l); 478 | Inc(dest, l); 479 | END; 480 | dest^ := #0; 481 | strpcopy := dest; 482 | END; 483 | 484 | END. 485 | -------------------------------------------------------------------------------- /DBB.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT DBB; 24 | { ========================================================================= 25 | This is unit implements dbb files (like a .dbt) - but fixed size blocks, 26 | has "garbage collection" (free blocks will be reused). 27 | ========================================================================= } 28 | INTERFACE 29 | 30 | USES System2; 31 | 32 | TYPE 33 | DBB_HDR = RECORD 34 | sign : WORD; 35 | next : LONGINT; 36 | records : LONGINT; 37 | root : LONGINT; 38 | size : WORD; 39 | END; 40 | 41 | DBBFile = RECORD 42 | f : BFILE; 43 | header : DBB_HDR; 44 | END; 45 | 46 | PROCEDURE dbb_Reset(VAR f : DBBFile; fname : STRING; blk_size : WORD); 47 | PROCEDURE dbb_ReWrite(VAR f : DBBFile; fname : STRING; blk_size : WORD); 48 | PROCEDURE dbb_ReWriteTemp(VAR f : DBBFile; blk_size : WORD); 49 | 50 | FUNCTION dbb_IsOpen(VAR f : DBBFile) : BOOLEAN; 51 | 52 | FUNCTION dbb_Add(VAR f : DBBFile; VAR b) : LONGINT; 53 | PROCEDURE dbb_Put(VAR f : DBBFile; rec : LONGINT; VAR b); 54 | PROCEDURE dbb_Get(VAR f : DBBFile; rec : LONGINT; VAR b); 55 | 56 | PROCEDURE dbb_Free(VAR f : DBBFile; rec : LONGINT); 57 | PROCEDURE dbb_Close(VAR f : DBBFile); 58 | 59 | FUNCTION dbb_GetRoot(VAR f : DBBFile):LONGINT; 60 | PROCEDURE dbb_SetRoot(VAR f : DBBFile; new_root : LONGINT); 61 | 62 | IMPLEMENTATION 63 | 64 | TYPE 65 | PLONGINT = ^LONGINT; 66 | 67 | CONST 68 | DBB_SIGN = $4244; 69 | DBB_HDR_SIZE = SizeOf(DBB_HDR); 70 | 71 | FUNCTION _go(VAR f : DBBFile; recno : LONGINT) : LONGINT; 72 | VAR r : LONGINT; 73 | BEGIN 74 | r := DBB_HDR_SIZE + (recno - 1) * f.header.size; 75 | Seek(f.f, DBB_HDR_SIZE + (recno - 1) * f.header.size); 76 | _go := r; 77 | END; 78 | 79 | PROCEDURE dbb_Reset(VAR f : DBBFile; fname : STRING; blk_size : WORD); 80 | BEGIN 81 | IF blk_size < SizeOf(LONGINT) THEN blk_size := SizeOf(LONGINT); 82 | FillChar(f, SizeOf(DBBFile), #0); 83 | Assign(f.f, fname); 84 | Reset(f.f); 85 | IF NOT IsOpen(f.f) THEN BEGIN 86 | dbb_rewrite(f, fname, blk_size); 87 | EXIT; 88 | END; 89 | IF SizeOf(DBB_HDR) <> BlockRead(f.f, f.header, SizeOf(DBB_HDR)) THEN BEGIN 90 | Close(f.f); 91 | dbb_ReWrite(f, fname, blk_size); 92 | EXIT; 93 | END; 94 | IF (f.header.sign <> DBB_SIGN) OR (f.header.size <> blk_size) THEN BEGIN 95 | Close(f.f); 96 | dbb_ReWrite(f, fname, blk_size); 97 | END; 98 | END; 99 | 100 | PROCEDURE _rewrite(VAR f : DBBFile; blk_size : WORD); 101 | BEGIN 102 | IF blk_size < SizeOf(LONGINT) THEN blk_size := SizeOf(LONGINT); 103 | IF IsOpen(f.f) THEN BEGIN 104 | f.header.sign := DBB_SIGN; 105 | f.header.next := 0; 106 | f.header.records := 0; 107 | f.header.root := 0; 108 | f.header.size := blk_size; 109 | Seek(f.f, 0); 110 | BlockWrite(f.f, f.header, DBB_HDR_SIZE); 111 | END; 112 | END; 113 | 114 | PROCEDURE dbb_ReWrite(VAR f : DBBFile; fname : STRING; blk_size : WORD); 115 | BEGIN 116 | FillChar(f, SizeOf(DBBFile), #0); 117 | Assign(f.f, fname); 118 | ReWrite(f.f); 119 | _rewrite(f, blk_size); 120 | END; 121 | 122 | PROCEDURE dbb_ReWriteTemp(VAR f : DBBFile; blk_size : WORD); 123 | BEGIN 124 | FillChar(f, SizeOf(DBBFile), #0); 125 | ReWriteTemp(f.f); 126 | _rewrite(f, blk_size); 127 | END; 128 | 129 | FUNCTION dbb_IsOpen(VAR f : DBBFile) : BOOLEAN; 130 | BEGIN 131 | dbb_IsOpen := IsOpen(f.f); 132 | END; 133 | 134 | PROCEDURE dbb_Close(VAR f : DBBFile); 135 | BEGIN 136 | IF NOT IsOpen(f.f) THEN EXIT; 137 | Seek(f.f, 0); 138 | BlockWrite(f.f, f.header, DBB_HDR_SIZE); 139 | Close(f.f); 140 | FillChar(f, SizeOf(DBBFile), #0); 141 | END; 142 | 143 | PROCEDURE dbb_Free(VAR f : DBBFile; rec : LONGINT); 144 | BEGIN 145 | IF (NOT IsOpen(f.f)) OR (rec = 0) THEN EXIT; 146 | _go(f, rec); 147 | WriteDWord(f.f, f.header.next); 148 | f.header.next := rec; 149 | END; 150 | 151 | FUNCTION _alloc(VAR f : DBBFile) : LONGINT; 152 | VAR r : LONGINT; 153 | BEGIN 154 | IF f.header.next <> 0 THEN BEGIN 155 | r := f.header.next; 156 | _go(f, r); 157 | f.header.next := ReadDWord(f.f); 158 | END ELSE BEGIN 159 | Inc(f.header.records); 160 | r := f.header.records; 161 | END; 162 | _alloc := r; 163 | END; 164 | 165 | PROCEDURE dbb_Get(VAR f : DBBFile; rec : LONGINT; VAR b); 166 | BEGIN 167 | IF (NOT IsOpen(f.f)) OR (rec = 0) THEN EXIT; 168 | _go(f, rec); 169 | BlockRead(f.f, b, f.header.size); 170 | END; 171 | 172 | FUNCTION dbb_Add(VAR f : DBBFile; VAR b) : LONGINT; 173 | VAR res : LONGINT; 174 | BEGIN 175 | res := 0; 176 | IF IsOpen(f.f) THEN BEGIN 177 | res := _alloc(f); 178 | _go(f, res); 179 | BlockWrite(f.f, b, f.header.size); 180 | END; 181 | dbb_Add := res; 182 | END; 183 | 184 | PROCEDURE dbb_Put(VAR f : DBBFile; rec : LONGINT; VAR b); 185 | BEGIN 186 | IF (NOT IsOpen(f.f)) OR (rec = 0) THEN EXIT; 187 | _go(f, rec); 188 | BlockWrite(f.f, b, f.header.size); 189 | END; 190 | 191 | FUNCTION dbb_GetRoot(VAR f : DBBFile):LONGINT; 192 | BEGIN 193 | dbb_GetRoot := f.header.root; 194 | END; 195 | 196 | PROCEDURE dbb_SetRoot(VAR f : DBBFile; new_root : LONGINT); 197 | BEGIN 198 | f.header.root := new_root; 199 | END; 200 | 201 | END. 202 | -------------------------------------------------------------------------------- /DBM.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT DBM; 24 | { ========================================================================= 25 | This is unit implements dbu files (like a .dbt) - container for memo fields 26 | with variable length. Free blocks will be reused. 27 | ========================================================================= } 28 | INTERFACE 29 | 30 | USES System2; 31 | 32 | TYPE 33 | DBM_HDR = RECORD 34 | sign : WORD; 35 | next : LONGINT; 36 | records : LONGINT; 37 | root : LONGINT; 38 | size : WORD; 39 | END; 40 | 41 | DBMFile = RECORD 42 | f : BFILE; 43 | header : DBM_HDR; 44 | rblk_size : WORD; 45 | END; 46 | 47 | PROCEDURE dbm_Reset(VAR f : DBMFile; fname : STRING; blk_size : WORD); 48 | PROCEDURE dbm_ReWrite(VAR f : DBMFile; fname : STRING; blk_size : WORD); 49 | PROCEDURE dbm_ReWriteTemp(VAR f : DBMFile; blk_size : WORD); 50 | 51 | FUNCTION dbm_IsOpen(VAR f : DBMFile) : BOOLEAN; 52 | 53 | FUNCTION dbm_GetRoot(VAR f : DBMFile):LONGINT; 54 | PROCEDURE dbm_SetRoot(VAR f : DBMFile; new_root : LONGINT); 55 | 56 | FUNCTION dbm_Add(VAR f : DBMFile; VAR b; size : WORD) : LONGINT; 57 | PROCEDURE dbm_Get(VAR f : DBMFile; rec : LONGINT; VAR b; size : WORD); 58 | PROCEDURE dbm_Put(VAR f : DBMFile; rec : LONGINT; VAR b; size : WORD); 59 | FUNCTION dbm_Size(VAR f : DBMFile; rec : LONGINT) : LONGINT; 60 | 61 | PROCEDURE dbm_Free(VAR f : DBMFile; rec : LONGINT); 62 | 63 | PROCEDURE dbm_Close(VAR f : DBMFile); 64 | 65 | IMPLEMENTATION 66 | 67 | CONST 68 | DBM_SIGN = $4D44; 69 | ADDED_DATA = SizeOf(LONGINT) + SizeOf(WORD); 70 | 71 | FUNCTION _norm_blk_size(blk_size : WORD) : WORD; 72 | BEGIN 73 | blk_size := blk_size + ADDED_DATA; 74 | IF blk_size < SizeOf(DBM_HDR) THEN blk_size := SizeOf(DBM_HDR); 75 | IF (blk_size AND 3) <> 0 THEN blk_size := ((blk_size SHR 2) + 1) SHL 2; 76 | _norm_blk_size := blk_size; 77 | END; 78 | 79 | FUNCTION _go(VAR f : DBMFile; recno : LONGINT) : LONGINT; 80 | VAR r : LONGINT; 81 | BEGIN 82 | r := recno * f.header.size; 83 | Seek(f.f, r); 84 | _go := r; 85 | END; 86 | 87 | PROCEDURE dbm_Reset(VAR f : DBMFile; fname : STRING; blk_size : WORD); 88 | VAR rblk_size : WORD; 89 | BEGIN 90 | FillChar(f, SizeOf(DBMFile), #0); 91 | Assign(f.f, fname); 92 | Reset(f.f); 93 | rblk_size := _norm_blk_size(blk_size); 94 | IF NOT IsOpen(f.f) THEN dbm_rewrite(f, fname, blk_size) 95 | ELSE IF SizeOf(DBM_HDR) <> BlockRead(f.f, f.header, SizeOf(DBM_HDR)) THEN BEGIN 96 | Close(f.f); 97 | dbm_ReWrite(f, fname, blk_size); 98 | END ELSE IF (f.header.sign = DBM_SIGN) AND (f.header.size = rblk_size) THEN BEGIN 99 | f.rblk_size := f.header.size - ADDED_DATA; 100 | END ELSE BEGIN 101 | Close(f.f); 102 | dbm_ReWrite(f, fname, blk_size); 103 | END; 104 | END; 105 | 106 | PROCEDURE _rewrite(VAR f : DBMFile); 107 | VAR i : INTEGER; 108 | BEGIN 109 | IF IsOpen(f.f) THEN BEGIN 110 | f.header.sign := DBM_SIGN; 111 | f.header.next := 0; 112 | f.header.records := 0; 113 | f.header.root := 0; 114 | Seek(f.f, 0); 115 | BlockWrite(f.f, f.header, SizeOf(DBM_HDR)); 116 | FOR i := 1 TO f.header.size - SizeOf(DBM_HDR) DO WriteByte(f.f, 0); 117 | END; 118 | END; 119 | 120 | PROCEDURE dbm_ReWrite(VAR f : DBMFile; fname : STRING; blk_size : WORD); 121 | BEGIN 122 | FillChar(f, SizeOf(DBMFile), #0); 123 | Assign(f.f, fname); 124 | ReWrite(f.f); 125 | f.header.size := _norm_blk_size(blk_size); 126 | f.rblk_size := f.header.size - ADDED_DATA; 127 | _rewrite(f); 128 | END; 129 | 130 | PROCEDURE dbm_ReWriteTemp(VAR f : DBMFile; blk_size : WORD); 131 | BEGIN 132 | FillChar(f, SizeOf(DBMFile), #0); 133 | ReWriteTemp(f.f); 134 | f.header.size := _norm_blk_size(blk_size); 135 | f.rblk_size := f.header.size - ADDED_DATA; 136 | _rewrite(f); 137 | END; 138 | 139 | FUNCTION dbm_IsOpen(VAR f : DBMFile) : BOOLEAN; 140 | BEGIN 141 | dbm_IsOpen := IsOpen(f.f); 142 | END; 143 | 144 | PROCEDURE dbm_Close(VAR f : DBMFile); 145 | BEGIN 146 | IF NOT IsOpen(f.f) THEN EXIT; 147 | Seek(f.f, 0); 148 | BlockWrite(f.f, f.header, SizeOf(DBM_HDR)); 149 | Close(f.f); 150 | FillChar(f, SizeOf(DBMFile), #0); 151 | END; 152 | 153 | PROCEDURE dbm_Free(VAR f : DBMFile; rec : LONGINT); 154 | VAR n : LONGINT; 155 | BEGIN 156 | IF NOT IsOpen(f.f) THEN EXIT; 157 | WHILE rec <> 0 DO BEGIN 158 | _go(f, rec); 159 | n := ReadDWord(f.f); 160 | _go(f, rec); 161 | WriteDWord(f.f, f.header.next); 162 | WriteWord(f.f, 0); 163 | f.header.next := rec; 164 | rec := n; 165 | END; 166 | END; 167 | 168 | FUNCTION _alloc(VAR f : DBMFile) : LONGINT; 169 | VAR r : LONGINT; 170 | BEGIN 171 | IF f.header.next <> 0 THEN BEGIN 172 | r := f.header.next; 173 | _go(f, r); 174 | f.header.next := ReadDWord(f.f); 175 | END ELSE BEGIN 176 | Inc(f.header.records); 177 | r := f.header.records; 178 | END; 179 | _go(f, r); 180 | _alloc := r; 181 | END; 182 | 183 | FUNCTION dbm_Size(VAR f : DBMFile; rec : LONGINT) : LONGINT; 184 | VAR r : LONGINT; 185 | BEGIN 186 | r := 0; 187 | IF IsOpen(f.f) THEN BEGIN 188 | WHILE rec <> 0 DO BEGIN 189 | _go(f, rec); 190 | rec := ReadDWord(f.f); 191 | Inc(r, ReadWord(f.f)); 192 | END; 193 | END; 194 | dbm_Size := r; 195 | END; 196 | 197 | PROCEDURE dbm_Get(VAR f : DBMFile; rec : LONGINT; VAR b; size : WORD); 198 | VAR p : PCHAR; 199 | g : WORD; 200 | BEGIN 201 | IF NOT IsOpen(f.f) THEN EXIT; 202 | p := @b; 203 | WHILE (size <> 0) AND (rec <> 0) DO BEGIN 204 | _go(f, rec); 205 | rec := ReadDWord(f.f); 206 | g := ReadWord(f.f); 207 | IF g > size THEN g := size; 208 | BlockRead(f.f, p^, g); 209 | Dec(size, g); 210 | Inc(p, g); 211 | END; 212 | END; 213 | 214 | FUNCTION dbm_Add(VAR f : DBMFile; VAR b; size : WORD) : LONGINT; 215 | VAR root, prec, crec : LONGINT; 216 | p : PCHAR; 217 | csize : WORD; 218 | i : WORD; 219 | BEGIN 220 | root := 0; 221 | IF IsOpen(f.f) THEN BEGIN 222 | p := @b; 223 | prec := 0; 224 | WHILE size <> 0 DO BEGIN 225 | crec := _alloc(f); 226 | IF root = 0 THEN root := crec; 227 | IF prec <> 0 THEN BEGIN 228 | _go(f, prec); 229 | WriteDWord(f.f, crec); 230 | END; 231 | csize := f.rblk_size; 232 | IF csize > size THEN csize := size; 233 | _go(f, crec); 234 | WriteDWord(f.f, 0); 235 | WriteWord(f.f, csize); 236 | BlockWrite(f.f, p^, csize); 237 | IF f.rblk_size > csize THEN BEGIN 238 | i := f.rblk_size - csize; 239 | WHILE i >= SizeOf(LONGINT) DO BEGIN 240 | WriteDWord(f.f, 0); 241 | Dec(i, SizeOf(LONGINT)); 242 | END; 243 | WHILE i >= 1 DO BEGIN 244 | WriteByte(f.f, 0); 245 | Dec(i, 1); 246 | END; 247 | END; 248 | Dec(size, csize); 249 | Inc(p, csize); 250 | prec := crec; 251 | END; 252 | END; 253 | dbm_Add := root; 254 | END; 255 | 256 | PROCEDURE dbm_Put(VAR f : DBMFile; rec : LONGINT; VAR b; size : WORD); 257 | VAR crec : LONGINT; 258 | BEGIN 259 | IF NOT IsOpen(f.f) THEN EXIT; 260 | _go(f, rec); 261 | crec := ReadDWord(f.f); 262 | _go(f, rec); 263 | WriteDWord(f.f, 0); 264 | WriteWord(f.f, 0); 265 | dbm_Free(f, crec); 266 | dbm_Free(f, rec); 267 | dbm_Add(f, b, size); 268 | END; 269 | 270 | FUNCTION dbm_GetRoot(VAR f : DBMFile):LONGINT; 271 | BEGIN 272 | dbm_GetRoot := f.header.root; 273 | END; 274 | 275 | PROCEDURE dbm_SetRoot(VAR f : DBMFile; new_root : LONGINT); 276 | BEGIN 277 | f.header.root := new_root; 278 | END; 279 | 280 | END. 281 | -------------------------------------------------------------------------------- /DETECT.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT Detect; 24 | 25 | INTERFACE 26 | 27 | CONST 28 | CPU_86 = 0; 29 | CPU_286 = 1; 30 | CPU_386 = 2; 31 | 32 | FUNCTION IsEga : BOOLEAN; 33 | FUNCTION IsVga : BOOLEAN; 34 | FUNCTION IsMonochrome : BOOLEAN; 35 | 36 | FUNCTION IsInputRedirected : BOOLEAN; 37 | FUNCTION IsOutputRedirected : BOOLEAN; 38 | FUNCTION IsAnsiSys : BOOLEAN; 39 | 40 | FUNCTION IsFreeDos : BOOLEAN; 41 | FUNCTION GetFreeDosVer : PCHAR; 42 | 43 | FUNCTION IsAT : BOOLEAN; 44 | FUNCTION GetCpu : WORD; 45 | 46 | IMPLEMENTATION 47 | 48 | FUNCTION IsEga : BOOLEAN;ASSEMBLER; 49 | ASM 50 | MOV AX, $1200 51 | MOV BX, $10 52 | MOV CX, $FFFF 53 | INT $10 54 | INC CX 55 | MOV AL, CL 56 | OR AL, CH 57 | END; 58 | 59 | FUNCTION IsVga : BOOLEAN;ASSEMBLER; 60 | ASM 61 | MOV AX, $1A00 62 | INT $10 {check for VGA/MCGA} 63 | CMP AL, $1A 64 | JNE @err {no VGA Bios} 65 | CMP BL, 7 66 | JB @err {is VGA or better?} 67 | CMP BL, $FF 68 | JNE @ok 69 | @err: 70 | XOR AL, AL 71 | JMP @end 72 | @ok: 73 | MOV AL, 1 74 | @end: 75 | END; 76 | 77 | FUNCTION IsFreeDos : BOOLEAN;ASSEMBLER; 78 | ASM 79 | MOV AX, $3000 80 | XOR BX, BX 81 | INT $21 82 | CMP BH, $FD 83 | JE @end 84 | XOR BH, BH 85 | @end: 86 | MOV AL, BH 87 | END; 88 | 89 | FUNCTION GetFreeDosVer : PCHAR; ASSEMBLER; 90 | ASM 91 | MOV AX, $33FF 92 | XOR DX, DX 93 | INT $21 94 | TEST DX, DX 95 | JNZ @end 96 | XOR AX, AX 97 | MOV DX, AX 98 | @end: 99 | END; 100 | 101 | FUNCTION IsMonochrome : BOOLEAN;ASSEMBLER; 102 | ASM 103 | PUSH DS 104 | MOV AX, WORD PTR [seg0040] 105 | MOV DS, AX 106 | MOV AL, BYTE PTR [$0065] 107 | POP DS 108 | AND AL, 4 109 | END; 110 | 111 | FUNCTION IsInputRedirected : BOOLEAN; ASSEMBLER; 112 | ASM 113 | MOV AX, $4400 114 | XOR BX, BX 115 | INT $21 116 | XOR AL, AL 117 | AND DL, $81 118 | OR DL, DL 119 | JNZ @end 120 | INC AL 121 | @end: 122 | END; 123 | 124 | FUNCTION IsOutputRedirected : BOOLEAN; ASSEMBLER; 125 | ASM 126 | MOV AX, $4400 127 | MOV BX, 1 128 | INT $21 129 | XOR AL, AL 130 | AND DL, $82 131 | OR DL, DL 132 | JNZ @end 133 | INC AL 134 | @end: 135 | END; 136 | 137 | FUNCTION IsAnsiSys : BOOLEAN; ASSEMBLER; 138 | ASM 139 | MOV AX,$1A00 140 | INT $2F 141 | XOR AH, AH 142 | END; 143 | 144 | FUNCTION GetCpu : WORD; ASSEMBLER; 145 | ASM 146 | XOR DX, DX 147 | PUSH DX 148 | POPF 149 | PUSHF 150 | POP AX 151 | AND AX, $F000 152 | CMP AX, $F000 153 | JE @end 154 | INC DX 155 | MOV AX, $F000 156 | PUSH AX 157 | POPF 158 | PUSHF 159 | POP AX 160 | AND AX, $F000 161 | JZ @end 162 | INC DX 163 | @end: 164 | MOV AX, DX 165 | END; 166 | 167 | FUNCTION IsAT : BOOLEAN; 168 | BEGIN 169 | IsAT := MEM[$F000 : $FFFE] = $FC; 170 | END; 171 | 172 | END. 173 | 174 | -------------------------------------------------------------------------------- /EXCACHE.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT ExCache; 24 | 25 | { Simple cache implementation } 26 | 27 | INTERFACE 28 | 29 | CONST 30 | EXCACHE_ITEM_COUNT = 8; 31 | 32 | TYPE 33 | TEXCACHE_ITEM = RECORD 34 | recno : LONGINT; 35 | page : INTEGER; 36 | count : WORD; 37 | is_busy : BOOLEAN; 38 | END; 39 | 40 | PEXCACHE = ^TEXCACHE; 41 | TEXCACHE = RECORD 42 | h : WORD; 43 | size : INTEGER; 44 | allocated : INTEGER; 45 | items : ARRAY[1..EXCACHE_ITEM_COUNT] OF TEXCACHE_ITEM; 46 | END; 47 | 48 | FUNCTION excache_Create(size : INTEGER) : PEXCACHE; 49 | PROCEDURE excache_Free(c : PEXCACHE); 50 | FUNCTION excache_IsFull(c : PEXCACHE) : BOOLEAN; 51 | 52 | FUNCTION excache_Get(c : PEXCACHE; recno : LONGINT; VAR b; VAR count : WORD) : BOOLEAN; 53 | FUNCTION excache_Put(c : PEXCACHE; recno : LONGINT; VAR b; count : WORD) : BOOLEAN; 54 | PROCEDURE excache_Truncate(c : PEXCACHE; recno : LONGINT; count : WORD); 55 | FUNCTION excache_Size(c : PEXCACHE) : WORD; 56 | 57 | IMPLEMENTATION 58 | 59 | USES EXms; 60 | 61 | FUNCTION excache_Create(size : INTEGER) : PEXCACHE; 62 | VAR r : PEXCACHE; 63 | h : WORD; 64 | BEGIN 65 | r := NIL; 66 | IF exms_check_driver THEN BEGIN 67 | IF size < 1 THEN size := EXCACHE_ITEM_COUNT; 68 | IF size > EXCACHE_ITEM_COUNT THEN size := EXCACHE_ITEM_COUNT; 69 | h := exms_malloc(size); 70 | IF h <> 0 THEN BEGIN 71 | GetMem(r, SizeOf(TEXCACHE)); 72 | FillChar(r^, SizeOf(TEXCACHE), #0); 73 | r^.h := h; 74 | r^.size := size; 75 | FOR h := 1 TO r^.size DO r^.items[h].page := h - 1; 76 | END; 77 | END; 78 | excache_Create := r; 79 | END; 80 | 81 | PROCEDURE excache_Free(c : PEXCACHE); 82 | BEGIN 83 | IF c = NIL THEN EXIT; 84 | IF c^.h <> 0 THEN exms_free(c^.h); 85 | FillChar(c^, SizeOf(TEXCACHE), #0); 86 | FreeMem(c, SizeOf(TEXCACHE)); 87 | END; 88 | 89 | PROCEDURE make_top(c : PEXCACHE; page : INTEGER); 90 | VAR item : TEXCACHE_ITEM; 91 | i : INTEGER; 92 | BEGIN 93 | IF page = 1 THEN EXIT; 94 | item := c^.items[page]; 95 | i := page; 96 | WHILE i > 1 DO BEGIN 97 | c^.items[i] := c^.items[i - 1]; 98 | Dec(i); 99 | END; 100 | c^.items[1] := item; 101 | END; 102 | 103 | FUNCTION lookup_recno(c : PEXCACHE; recno : LONGINT) : BOOLEAN; 104 | VAR i : INTEGER; 105 | r : BOOLEAN; 106 | BEGIN 107 | r := FALSE; 108 | i := 1; 109 | WHILE i <= c^.size DO BEGIN 110 | IF c^.items[i].is_busy 111 | AND (c^.items[i].recno = recno) THEN BEGIN 112 | make_top(c, i); 113 | r := TRUE; 114 | BREAK; 115 | END; 116 | Inc(i); 117 | END; 118 | lookup_recno := r; 119 | END; 120 | 121 | PROCEDURE lookup_free(c : PEXCACHE); 122 | VAR i, r : INTEGER; 123 | BEGIN 124 | r := c^.size; 125 | i := 1; 126 | WHILE i <= r DO BEGIN 127 | IF NOT c^.items[i].is_busy THEN BEGIN 128 | r := i; 129 | BREAK; 130 | END; 131 | Inc(i); 132 | END; 133 | make_top(c, r); 134 | END; 135 | 136 | FUNCTION excache_Get(c : PEXCACHE; recno : LONGINT; VAR b; VAR count : WORD) : BOOLEAN; 137 | VAR r : BOOLEAN; 138 | BEGIN 139 | r := FALSE; 140 | IF c <> NIL THEN BEGIN 141 | IF c^.h <> 0 THEN r := lookup_recno(c, recno); 142 | END; 143 | IF r THEN BEGIN 144 | exms_copy(c^.h, c^.items[1].page, b, EXT2DOS); 145 | count := c^.items[1].count; 146 | c^.items[1].is_busy := FALSE; 147 | Dec(c^.allocated); 148 | END; 149 | excache_Get := r; 150 | END; 151 | 152 | FUNCTION excache_Put(c : PEXCACHE; recno : LONGINT; VAR b; count : WORD) : BOOLEAN; 153 | BEGIN 154 | IF c = NIL THEN excache_Put := FALSE 155 | ELSE IF c^.h = 0 THEN excache_Put := FALSE 156 | ELSE BEGIN 157 | lookup_free(c); 158 | IF NOT c^.items[1].is_busy THEN Inc(c^.allocated); 159 | c^.items[1].recno := recno; 160 | c^.items[1].count := count; 161 | c^.items[1].is_busy := TRUE; 162 | exms_copy(c^.h, c^.items[1].page, b, DOS2EXT); 163 | excache_Put := TRUE; 164 | END; 165 | END; 166 | 167 | PROCEDURE excache_Truncate(c : PEXCACHE; recno : LONGINT; count : WORD); 168 | VAR i : INTEGER; 169 | BEGIN 170 | IF c = NIL THEN EXIT; 171 | IF c^.h = 0 THEN EXIT; 172 | 173 | i := 1; 174 | WHILE i <= c^.size DO BEGIN 175 | IF c^.items[i].is_busy THEN BEGIN 176 | IF c^.items[i].recno = recno THEN c^.items[i].count := count 177 | ELSE IF c^.items[i].recno > recno THEN BEGIN 178 | c^.items[i].is_busy := FALSE; 179 | Dec(c^.allocated); 180 | END; 181 | END; 182 | Inc(i); 183 | END; 184 | END; 185 | 186 | FUNCTION excache_IsFull(c : PEXCACHE) : BOOLEAN; 187 | BEGIN 188 | IF c <> NIL THEN excache_IsFull := c^.allocated = c^.size 189 | ELSE excache_IsFull := TRUE; 190 | END; 191 | 192 | FUNCTION excache_Size(c : PEXCACHE) : WORD; 193 | BEGIN 194 | IF c = NIL THEN excache_Size := 0 ELSE excache_Size := c^.size; 195 | END; 196 | 197 | END. 198 | -------------------------------------------------------------------------------- /EXMS.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT EXms; 24 | 25 | INTERFACE 26 | 27 | CONST 28 | EXT_PAGE_SIZE = $4000; { 16 kb } 29 | EMS_STATUS_OK = 0; 30 | 31 | TYPE 32 | MEM_COPY_DIRECTION = (DOS2EXT, EXT2DOS); 33 | DWORD = LONGINT; 34 | 35 | { --- EMS -------------------------------------------------------- } 36 | 37 | FUNCTION ems_check_driver : BOOLEAN; 38 | FUNCTION ems_get_status : BYTE; 39 | FUNCTION ems_maxavail : WORD; 40 | FUNCTION ems_malloc(pages : WORD) : WORD; 41 | FUNCTION ems_realloc(handle : WORD; old_page_count, new_page_count : WORD) : WORD; 42 | PROCEDURE ems_copy(handle : WORD; page : WORD; VAR buf; dir : MEM_COPY_DIRECTION); 43 | PROCEDURE ems_free(handle : WORD); 44 | 45 | { --- XMS -------------------------------------------------------- } 46 | 47 | FUNCTION xms_check_driver : BOOLEAN; 48 | FUNCTION xms_version : WORD; 49 | FUNCTION xms_maxavail : DWORD; 50 | FUNCTION xms_malloc(pages : WORD) : WORD; 51 | FUNCTION xms_realloc(handle : WORD; old_page_count, new_page_count : WORD) : WORD; 52 | PROCEDURE xms_copy(handle : WORD; page : WORD; VAR buf; dir : MEM_COPY_DIRECTION); 53 | PROCEDURE xms_free(handle : WORD); 54 | 55 | { --- EMS/XMS ---------------------------------------------------- } 56 | 57 | FUNCTION exms_check_driver : BOOLEAN; 58 | FUNCTION exms_maxavail : DWORD; 59 | FUNCTION exms_malloc(pages : WORD) : WORD; 60 | FUNCTION exms_realloc(handle : WORD; old_page_count, new_page_count : WORD) : WORD; 61 | PROCEDURE exms_copy(handle : WORD; page : WORD; VAR buf; dir : MEM_COPY_DIRECTION); 62 | PROCEDURE exms_free(handle : WORD); 63 | 64 | IMPLEMENTATION 65 | 66 | {$IFDEF DPMI} 67 | This unit could be used only with real-mode DOS ! 68 | {$ENDIF} 69 | {$IFDEF WINDOWS} 70 | This unit could be used only with real-mode DOS ! 71 | {$ENDIF} 72 | {$IFDEF LINUX} 73 | This unit could be used only with real-mode DOS ! 74 | {$ENDIF} 75 | {$IFDEF OS2} 76 | This unit could be used only with real-mode DOS ! 77 | {$ENDIF} 78 | 79 | CONST 80 | EMMDEVNAME : STRING[8] = 'EMMXXXX0'; 81 | 82 | TYPE 83 | 84 | TEMSCOPYREC = RECORD 85 | len : DWORD; 86 | src_type : BYTE; 87 | src_hnd : WORD; 88 | src_ofs : WORD; 89 | src_seg : WORD; 90 | dst_type : BYTE; 91 | dst_hnd : WORD; 92 | dst_ofs : WORD; 93 | dst_seg : WORD; 94 | END; 95 | 96 | TXMSCOPYREC = RECORD 97 | len : DWORD; 98 | src_hnd : WORD; 99 | src_ofs : DWORD; 100 | dst_hnd : WORD; 101 | dst_ofs : DWORD; 102 | { XMS v3.51 fields } 103 | src_hi : BYTE; 104 | dst_hi : BYTE; 105 | END; 106 | 107 | CONST 108 | EMS = 1; 109 | XMS = 2; 110 | 111 | VAR emsrec : TEMSCOPYREC; 112 | xmshandler : POINTER; 113 | xmsrec : TXMSCOPYREC; 114 | mtype : BYTE; 115 | IsSXMS : BOOLEAN; 116 | 117 | xmsMaxAvailFn : BYTE; 118 | xmsAllocFn : BYTE; 119 | xmsCopyFn : BYTE; 120 | { --- EMS -------------------------------------------------------- } 121 | 122 | FUNCTION ems_get_status : BYTE;ASSEMBLER; 123 | ASM 124 | MOV AH, $40 125 | INT $67 126 | MOV AL, AH 127 | END; 128 | 129 | FUNCTION ems_malloc(pages : WORD) : WORD;ASSEMBLER; 130 | ASM 131 | MOV BX, pages 132 | MOV AH, $43 133 | INT $67 134 | OR AH, AH 135 | JZ @ok 136 | XOR DX, DX 137 | @ok: 138 | MOV AX, DX 139 | END; 140 | 141 | PROCEDURE ems_free(handle : WORD);ASSEMBLER; 142 | ASM 143 | MOV AH, $45 144 | MOV DX, handle 145 | INT $67 146 | END; 147 | 148 | FUNCTION ems_maxavail : WORD;ASSEMBLER; 149 | ASM 150 | MOV AH, $42 151 | INT $67 152 | OR AH, AH 153 | JZ @ok 154 | XOR BX, BX 155 | @ok: 156 | MOV AX, BX 157 | END; 158 | 159 | FUNCTION ems_check_driver : BOOLEAN; 160 | VAR dev_name : STRING[8]; 161 | int67seg : WORD; 162 | BEGIN 163 | ASM 164 | MOV AX, $3567 165 | INT $21 166 | MOV AX, ES 167 | MOV int67seg, AX 168 | END; 169 | Move(MEM[int67seg : $0A], dev_name[1], 8); 170 | dev_name[0] := #8; 171 | ems_check_driver := dev_name = EMMDEVNAME; 172 | END; 173 | 174 | PROCEDURE ems_copy(handle : WORD; page : WORD; VAR buf; dir : MEM_COPY_DIRECTION); 175 | BEGIN 176 | FillChar(emsrec, SizeOf(TEMSCOPYREC), #0); 177 | emsrec.len := EXT_PAGE_SIZE; 178 | IF dir = DOS2EXT THEN BEGIN 179 | emsrec.src_ofs := Ofs(buf); 180 | emsrec.src_seg := Seg(buf); 181 | emsrec.dst_type := 1; 182 | emsrec.dst_hnd := handle; 183 | emsrec.dst_seg := page; 184 | END ELSE IF dir = EXT2DOS THEN BEGIN 185 | emsrec.src_type := 1; 186 | emsrec.src_hnd := handle; 187 | emsrec.src_seg := page; 188 | emsrec.dst_ofs := Ofs(buf); 189 | emsrec.dst_seg := Seg(buf); 190 | END; 191 | ASM 192 | MOV SI, offset emsrec 193 | MOV AX, $5701 194 | INT $67 195 | END; 196 | END; 197 | 198 | FUNCTION _ems_realloc(handle : WORD; new_page_count : WORD) : BOOLEAN;ASSEMBLER; 199 | ASM 200 | MOV BX, new_page_count 201 | MOV DX, handle 202 | MOV AH, $51 203 | INT $67 204 | OR AH, AH 205 | JZ @ok 206 | MOV AH, 1 207 | @ok: 208 | MOV AL, AH 209 | DEC AL 210 | END; 211 | 212 | FUNCTION ems_realloc(handle : WORD; old_page_count, new_page_count : WORD) : WORD; 213 | VAR h : WORD; 214 | BEGIN 215 | IF _ems_realloc(handle, new_page_count) THEN h := handle 216 | ELSE BEGIN 217 | h := ems_malloc(new_page_count); 218 | IF h <> 0 THEN BEGIN 219 | FillChar(emsrec, SizeOf(TEMSCOPYREC), #0); 220 | emsrec.len := old_page_count * EXT_PAGE_SIZE; 221 | emsrec.src_type := 1; 222 | emsrec.src_hnd := handle; 223 | emsrec.dst_type := 1; 224 | emsrec.dst_hnd := h; 225 | ASM 226 | MOV SI, offset emsrec 227 | MOV AX, $5701 228 | INT $67 229 | END; 230 | ems_free(handle); 231 | END; 232 | END; 233 | ems_realloc := h; 234 | END; 235 | 236 | { --- XMS -------------------------------------------------------- } 237 | 238 | FUNCTION xms_check_driver : BOOLEAN;ASSEMBLER; 239 | ASM 240 | MOV AX, $4300 241 | INT $2F 242 | CMP AL, $80 243 | JE @ok 244 | XOR AL, AL 245 | @ok: 246 | END; 247 | 248 | FUNCTION xms_version : WORD;ASSEMBLER; 249 | ASM 250 | MOV AH, 0 251 | CALL [xmshandler] 252 | END; 253 | 254 | FUNCTION xms_get_handler : POINTER;ASSEMBLER; 255 | ASM 256 | PUSH ES 257 | MOV AX, $4310 258 | INT $2F 259 | MOV AX, BX 260 | MOV DX, ES 261 | POP ES 262 | END; 263 | 264 | FUNCTION xms_malloc(pages : WORD) : WORD;ASSEMBLER; 265 | ASM 266 | MOV BL, IsSXMS 267 | MOV AX, pages 268 | OR BL, BL 269 | JZ @oldXms 270 | DB $66, $25, $FF, $FF, $00, $00 { AND EAX, $FFFF } 271 | DB $66, $D3, $E0 { SHL EAX, CL } 272 | DB $66, $89, $C2 { MOV EDX, EAX } 273 | JMP @cont 274 | @oldXms: 275 | MOV CL, 4 276 | SHL AX, CL 277 | MOV DX, AX 278 | @cont: MOV AH, xmsAllocFn 279 | CALL [xmshandler] 280 | OR AX, AX 281 | JNZ @ok 282 | XOR DX, DX 283 | @ok: 284 | MOV AX, DX 285 | END; 286 | 287 | PROCEDURE xms_free(handle : WORD);ASSEMBLER; 288 | ASM 289 | MOV DX, handle 290 | MOV AH, $0A 291 | CALL [xmshandler] 292 | END; 293 | 294 | PROCEDURE SetSrcOfs(page : WORD);ASSEMBLER; 295 | ASM 296 | MOV AX, page 297 | MOV BX, $40 298 | MUL BX 299 | MOV BYTE PTR [xmsrec.src_ofs], BH 300 | MOV WORD PTR [xmsrec.src_ofs + 1], AX 301 | MOV BYTE PTR [xmsrec.src_ofs + 3], DL 302 | MOV BYTE PTR [xmsrec.src_hi], DH 303 | END; 304 | 305 | PROCEDURE SetDstOfs(page : WORD);ASSEMBLER; 306 | ASM 307 | MOV AX, page 308 | MOV BX, $40 309 | MUL BX 310 | MOV BYTE PTR [xmsrec.dst_ofs], BH 311 | MOV WORD PTR [xmsrec.dst_ofs + 1], AX 312 | MOV BYTE PTR [xmsrec.dst_ofs + 3], DL 313 | MOV BYTE PTR [xmsrec.dst_hi], DH 314 | END; 315 | 316 | PROCEDURE xms_copy(handle : WORD; page : WORD; VAR buf; dir : MEM_COPY_DIRECTION); 317 | VAR buf_ptr : LONGINT; 318 | BEGIN 319 | FillChar(xmsrec, SizeOf(TXMSCOPYREC), #0); 320 | xmsrec.len := EXT_PAGE_SIZE; 321 | buf_ptr := LONGINT(@buf); 322 | IF dir = DOS2EXT THEN BEGIN 323 | xmsrec.src_hnd := 0; 324 | xmsrec.src_ofs := buf_ptr; 325 | xmsrec.dst_hnd := handle; 326 | SetDstOfs(page); 327 | END ELSE IF dir = EXT2DOS THEN BEGIN 328 | xmsrec.src_hnd := handle; 329 | SetSrcOfs(page); 330 | xmsrec.dst_hnd := 0; 331 | xmsrec.dst_ofs := buf_ptr; 332 | END; 333 | ASM 334 | MOV SI, offset xmsrec 335 | MOV AH, xmsCopyFn 336 | CALL [xmshandler] 337 | END; 338 | END; 339 | 340 | FUNCTION _xms_realloc(handle : WORD; pcount : WORD) : BOOLEAN; ASSEMBLER; 341 | ASM 342 | MOV AX, pcount 343 | MOV CL, 4 344 | SHL AX, CL 345 | MOV BX, AX 346 | MOV DX, handle 347 | MOV AH, $0F 348 | CALL [xmshandler] 349 | END; 350 | 351 | FUNCTION xms_realloc(handle : WORD; old_page_count, new_page_count : WORD) : WORD; 352 | VAR h : WORD; 353 | BEGIN 354 | IF _xms_realloc(handle, new_page_count) THEN h := handle 355 | ELSE BEGIN 356 | h := xms_malloc(new_page_count); 357 | IF h <> 0 THEN BEGIN 358 | FillChar(xmsrec, SizeOf(xmsrec), #0); 359 | xmsrec.src_hnd := handle; 360 | xmsrec.dst_hnd := h; 361 | xmsrec.len := LONGINT(old_page_count) * EXT_PAGE_SIZE; 362 | ASM 363 | MOV SI, offset xmsrec 364 | MOV AH, $0B 365 | CALL [xmshandler] 366 | END; 367 | xms_free(handle); 368 | END; 369 | END; 370 | xms_realloc := h; 371 | END; 372 | 373 | FUNCTION xms_maxavail : DWORD;ASSEMBLER; 374 | ASM 375 | MOV AH, xmsMaxAvailFn 376 | CALL [xmshandler] 377 | MOV BL, IsSXMS 378 | OR BL, BL 379 | JZ @oldXMS 380 | DB $66, $C1, $E8, $04 { SHR EAX, 4 } 381 | DB $66, $50 { PUSH EAX } 382 | DB $66, $5A { POP EDX } 383 | DB $66, $C1, $E8, $10 { SHR EAX, 16 } 384 | XCHG AX, DX 385 | JMP @end 386 | @oldXMS: 387 | MOV CL, 4 388 | SHR AX, CL 389 | XOR DX, DX 390 | @end: 391 | END; 392 | 393 | FUNCTION exms_check_driver : BOOLEAN; 394 | BEGIN 395 | exms_check_driver := mtype <> 0; 396 | END; 397 | 398 | FUNCTION exms_maxavail : DWORD; 399 | BEGIN 400 | IF mtype = EMS THEN exms_maxavail := ems_maxavail 401 | ELSE IF mtype = XMS THEN exms_maxavail := xms_maxavail 402 | ELSE exms_maxavail := 0; 403 | END; 404 | 405 | FUNCTION exms_malloc(pages : WORD) : WORD; 406 | BEGIN 407 | IF mtype = EMS THEN exms_malloc := ems_malloc(pages) 408 | ELSE IF mtype = XMS THEN exms_malloc := xms_malloc(pages) 409 | ELSE exms_malloc := 0; 410 | END; 411 | 412 | FUNCTION exms_realloc(handle : WORD; old_page_count, new_page_count : WORD) : WORD; 413 | BEGIN 414 | IF mtype = EMS THEN exms_realloc := ems_realloc(handle, old_page_count, new_page_count) 415 | ELSE IF mtype = XMS THEN exms_realloc := xms_realloc(handle, old_page_count, new_page_count) 416 | ELSE exms_realloc := 0; 417 | END; 418 | 419 | PROCEDURE exms_copy(handle : WORD; page : WORD; VAR buf; dir : MEM_COPY_DIRECTION); 420 | BEGIN 421 | IF mtype = EMS THEN ems_copy(handle, page, buf, dir) 422 | ELSE IF mtype = XMS THEN xms_copy(handle, page, buf, dir); 423 | END; 424 | 425 | PROCEDURE exms_free(handle : WORD); 426 | BEGIN 427 | IF mtype = EMS THEN ems_free(handle) 428 | ELSE IF mtype = XMS THEN xms_free(handle); 429 | END; 430 | 431 | PROCEDURE BAD_XMS_CALL; 432 | BEGIN 433 | System.Writeln('Error in XMS call.'); 434 | Halt(255); 435 | END; 436 | 437 | BEGIN 438 | mtype := 0; 439 | IsSXMS := FALSE; 440 | xmshandler := @BAD_XMS_CALL; 441 | IF xms_check_driver THEN BEGIN 442 | xmshandler := xms_get_handler; 443 | mtype := XMS; 444 | IsSXMS := xms_version > $0350; 445 | xmsAllocFn := $09; 446 | xmsCopyFn := $0B; 447 | xmsMaxAvailFn := $08; 448 | IF IsSXMS THEN BEGIN 449 | xmsAllocFn := $C9; 450 | xmsCopyFn := $CB; 451 | xmsMaxAvailFn := $C8; 452 | END; 453 | END ELSE IF ems_check_driver THEN mtype := EMS; 454 | END. 455 | -------------------------------------------------------------------------------- /KMINPUT.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2020 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT KMInput; 24 | 25 | INTERFACE 26 | 27 | { --- Keyboard ------------------------------------------------------ } 28 | 29 | CONST 30 | 31 | SCAN_ESC = $01; 32 | 33 | SCAN_UP = $48; 34 | SCAN_DOWN = $50; 35 | SCAN_LEFT = $4B; 36 | SCAN_RIGHT = $4D; 37 | 38 | SCAN_CTRL_LEFT = $73; 39 | SCAN_CTRL_RIGHT = $74; 40 | SCAN_CTRL_UP = $8D; 41 | SCAN_CTRL_DOWN = $91; 42 | 43 | SCAN_INS = $52; 44 | SCAN_HOME = $47; 45 | SCAN_PGUP = $49; 46 | SCAN_DEL = $53; 47 | SCAN_END = $4F; 48 | SCAN_PGDN = $51; 49 | 50 | SCAN_CTRL_HOME = $77; 51 | SCAN_CTRL_PGUP = $84; 52 | SCAN_CTRL_END = $75; 53 | SCAN_CTRL_PGDN = $76; 54 | 55 | SCAN_F1 = $3B; 56 | SCAN_F2 = $3C; 57 | SCAN_F3 = $3D; 58 | SCAN_F4 = $3E; 59 | SCAN_F5 = $3F; 60 | SCAN_F6 = $40; 61 | SCAN_F7 = $41; 62 | SCAN_F8 = $42; 63 | SCAN_F9 = $43; 64 | SCAN_F10 = $44; 65 | SCAN_F11 = $85; 66 | SCAN_F12 = $86; 67 | 68 | SCAN_ALT_F1 = $68; 69 | SCAN_ALT_F2 = $69; 70 | SCAN_ALT_F3 = $6A; 71 | SCAN_ALT_F4 = $6B; 72 | SCAN_ALT_F5 = $6C; 73 | SCAN_ALT_F6 = $6D; 74 | SCAN_ALT_F7 = $6E; 75 | SCAN_ALT_F8 = $6F; 76 | SCAN_ALT_F9 = $70; 77 | SCAN_ALT_F10 = $71; 78 | SCAN_ALT_F11 = $8B; 79 | SCAN_ALT_F12 = $8C; 80 | 81 | SCAN_SHIFT_F1 = $54; 82 | SCAN_SHIFT_F2 = $55; 83 | SCAN_SHIFT_F3 = $56; 84 | SCAN_SHIFT_F4 = $57; 85 | SCAN_SHIFT_F5 = $58; 86 | SCAN_SHIFT_F6 = $59; 87 | SCAN_SHIFT_F7 = $5A; 88 | SCAN_SHIFT_F8 = $5B; 89 | SCAN_SHIFT_F9 = $5C; 90 | SCAN_SHIFT_F10 = $5D; 91 | SCAN_SHIFT_F11 = $87; 92 | SCAN_SHIFT_F12 = $88; 93 | 94 | SCAN_CTRL_F1 = $5E; 95 | SCAN_CTRL_F2 = $5F; 96 | SCAN_CTRL_F3 = $60; 97 | SCAN_CTRL_F4 = $61; 98 | SCAN_CTRL_F5 = $62; 99 | SCAN_CTRL_F6 = $63; 100 | SCAN_CTRL_F7 = $64; 101 | SCAN_CTRL_F8 = $65; 102 | SCAN_CTRL_F9 = $66; 103 | SCAN_CTRL_F10 = $67; 104 | SCAN_CTRL_F11 = $89; 105 | SCAN_CTRL_F12 = $8A; 106 | 107 | { first row } 108 | SCAN_TILDA = $29; 109 | SCAN_1 = $02; 110 | SCAN_2 = $03; 111 | SCAN_3 = $04; 112 | SCAN_4 = $05; 113 | SCAN_5 = $06; 114 | SCAN_6 = $07; 115 | SCAN_7 = $08; 116 | SCAN_8 = $09; 117 | SCAN_9 = $0A; 118 | SCAN_0 = $0B; 119 | SCAN_MINUS = $0C; 120 | SCAN_EQ = $0D; 121 | SCAN_BS = $0E; 122 | 123 | { second row } 124 | SCAN_TAB = $0F; 125 | SCAN_Q = $10; 126 | SCAN_W = $11; 127 | SCAN_E = $12; 128 | SCAN_R = $13; 129 | SCAN_T = $14; 130 | SCAN_Y = $15; 131 | SCAN_U = $16; 132 | SCAN_I = $17; 133 | SCAN_O = $18; 134 | SCAN_P = $19; 135 | SCAN_LBRAKET = $1A; 136 | SCAN_RBRAKET = $1B; 137 | SCAN_BACK_SLASH = $2B; 138 | 139 | { third row } 140 | SCAN_A = $1E; 141 | SCAN_S = $1F; 142 | SCAN_D = $20; 143 | SCAN_F = $21; 144 | SCAN_G = $22; 145 | SCAN_H = $23; 146 | SCAN_J = $24; 147 | SCAN_K = $25; 148 | SCAN_L = $26; 149 | SCAN_DOTCOMA = $27; 150 | SCAN_QUOTE = $28; 151 | SCAN_ENTER = $1c; 152 | 153 | { fourth row } 154 | SCAN_Z = $2C; 155 | SCAN_X = $2D; 156 | SCAN_C = $2E; 157 | SCAN_V = $2F; 158 | SCAN_B = $30; 159 | SCAN_N = $31; 160 | SCAN_M = $32; 161 | SCAN_COMA = $33; 162 | SCAN_DOT = $34; 163 | SCAN_SLASH = $35; 164 | 165 | SCAN_SPACE = $39; 166 | 167 | SCAN_GREY_MINUS = $4A; 168 | SCAN_GREY_PLUS = $4E; 169 | 170 | FUNCTION kbd_getkey : WORD; 171 | FUNCTION kbd_haskey : BOOLEAN; 172 | FUNCTION kbd_getflags : BYTE; 173 | PROCEDURE kbd_reset; 174 | PROCEDURE kbd_fast; 175 | 176 | FUNCTION is_ctrl(flags : BYTE) : BOOLEAN; 177 | FUNCTION is_alt(flags : BYTE) : BOOLEAN; 178 | FUNCTION is_shift(flags : BYTE) : BOOLEAN; 179 | 180 | { --- Mouse ------------------------------------------------------ } 181 | 182 | CONST 183 | 184 | MOUSE_B1 = 1; 185 | MOUSE_B2 = 2; 186 | 187 | PROCEDURE mouse_show; 188 | PROCEDURE mouse_hide; 189 | FUNCTION mouse_visible : BOOLEAN; 190 | FUNCTION mouse_buttons : BYTE; 191 | FUNCTION mouse_getx : INTEGER; 192 | FUNCTION mouse_gety : INTEGER; 193 | FUNCTION mouse_avail : BOOLEAN; 194 | 195 | IMPLEMENTATION 196 | 197 | VAR have_ext_kb : BOOLEAN; 198 | have_122_kb : BOOLEAN; 199 | mouse_present, mouse_state : BOOLEAN; 200 | 201 | { --- Keyboard ------------------------------------------------------ } 202 | 203 | FUNCTION kbd_getkey : WORD;ASSEMBLER; 204 | ASM 205 | cmp BYTE ptr have_122_kb, 0 206 | jne @h122 207 | cmp BYTE ptr have_ext_kb, 0 208 | jne @hext 209 | xor ax, ax 210 | jmp @end 211 | @h122: 212 | mov ah, $20 213 | jmp @end 214 | @hext: 215 | mov ah, $10 216 | @end: 217 | int $16 218 | END; 219 | 220 | FUNCTION kbd_haskey : BOOLEAN;ASSEMBLER; 221 | ASM 222 | cmp BYTE ptr have_122_kb, 0 223 | jne @h122 224 | cmp BYTE ptr have_ext_kb, 0 225 | jne @hext 226 | 227 | mov ah, 1 228 | jmp @end 229 | @hext: 230 | mov ah, $11 231 | jmp @end 232 | @h122: 233 | mov ah, $21 234 | @end: 235 | int $16 236 | mov cx, 0 237 | jz @nokey 238 | dec cx 239 | @nokey: 240 | mov ax, cx 241 | END; 242 | 243 | FUNCTION kbd_getflags : BYTE;ASSEMBLER; 244 | ASM 245 | cmp BYTE ptr have_122_kb, 0 246 | jne @h122 247 | cmp BYTE ptr have_ext_kb, 0 248 | jne @hext 249 | 250 | mov ah, 2 251 | jmp @end 252 | @hext: 253 | mov ah, $12 254 | jmp @end 255 | @h122: 256 | mov ah, $22 257 | 258 | @end: 259 | int $16 260 | END; 261 | 262 | FUNCTION is_ctrl(flags : BYTE) : BOOLEAN;ASSEMBLER; 263 | ASM 264 | mov al, flags 265 | and al, $4 266 | END; 267 | 268 | FUNCTION is_alt(flags : BYTE) : BOOLEAN;ASSEMBLER; 269 | ASM 270 | mov al, flags 271 | and al, $8 272 | END; 273 | 274 | FUNCTION is_shift(flags : BYTE) : BOOLEAN;ASSEMBLER; 275 | ASM 276 | mov al, flags 277 | and al, $3 278 | END; 279 | 280 | PROCEDURE kbd_fast;ASSEMBLER; 281 | ASM 282 | mov ax, $0305 283 | xor bx, bx 284 | int $16 285 | END; 286 | 287 | PROCEDURE kbd_reset; 288 | BEGIN 289 | WHILE kbd_haskey DO kbd_getkey; 290 | END; 291 | 292 | { --- Mouse ------------------------------------------------------ } 293 | 294 | FUNCTION mouse_avail : BOOLEAN;ASSEMBLER; 295 | ASM 296 | mov al, mouse_present 297 | END; 298 | 299 | FUNCTION mouse_visible : BOOLEAN;ASSEMBLER; 300 | ASM 301 | mov al, mouse_present 302 | or al, al 303 | jz @nomouse 304 | mov al, mouse_state 305 | @nomouse: 306 | END; 307 | 308 | PROCEDURE mouse_show;ASSEMBLER; 309 | ASM 310 | mov al, mouse_present 311 | or al, al 312 | jz @nomouse 313 | mov ax, 1 314 | int $33 315 | mov al, 1 316 | mov mouse_state, al 317 | @nomouse: 318 | END; 319 | 320 | PROCEDURE mouse_hide;ASSEMBLER; 321 | ASM 322 | mov al, mouse_present 323 | or al, al 324 | jz @nomouse 325 | mov ax, 2 326 | xor al, al 327 | mov mouse_state, al 328 | @nomouse: 329 | END; 330 | 331 | FUNCTION mouse_buttons : BYTE;ASSEMBLER; 332 | ASM 333 | mov al, mouse_present 334 | or al, al 335 | jz @nomouse 336 | mov ax, 3 337 | int $33 338 | mov al, bl 339 | and al, 3 340 | @nomouse: 341 | END; 342 | 343 | FUNCTION mouse_getx : INTEGER;ASSEMBLER; 344 | ASM 345 | mov al, mouse_present 346 | or al, al 347 | jz @nomouse 348 | mov ax, 3 349 | int $33 350 | mov ax, cx 351 | mov cl ,3 352 | shr ax, cl 353 | @nomouse: 354 | END; 355 | 356 | FUNCTION mouse_gety : INTEGER;ASSEMBLER; 357 | ASM 358 | mov al, mouse_present 359 | or al, al 360 | jz @nomouse 361 | mov ax, 3 362 | int $33 363 | mov ax, dx 364 | mov cl ,3 365 | shr ax, cl 366 | @nomouse: 367 | END; 368 | 369 | BEGIN 370 | ASM 371 | { check keyboard } 372 | mov ax, $0900 373 | int $16 374 | push ax 375 | and al, $20 376 | mov have_ext_kb, al 377 | pop ax 378 | and al, $40 379 | mov have_122_kb, al 380 | { check mouse } 381 | xor ax, ax 382 | int $33 383 | mov mouse_present, al 384 | END; 385 | END. 386 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 DosWorld 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /MAKEFILE: -------------------------------------------------------------------------------- 1 | all : rebuild.exe 2 | rebuild 3 | 4 | rebuild.exe: rebuild.pas 5 | tpc rebuild.pas 6 | 7 | clean: 8 | del *.TPU 9 | del *.BAK 10 | del *.EXE 11 | 12 | install: all 13 | copy *.tpu ..\TPU\ 14 | 15 | -------------------------------------------------------------------------------- /PSON.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-,N+} 23 | UNIT pson; 24 | 25 | INTERFACE 26 | 27 | CONST 28 | 29 | PSON_EOF = #1; 30 | PSON_CHAR = #2; 31 | PSON_INT = #4; 32 | PSON_REAL = #5; 33 | PSON_STR = #6; 34 | PSON_OBJ = #7; 35 | 36 | TYPE 37 | 38 | PSON_KEY_TYPE = STRING; 39 | PSON_PTR_TYPE = PCHAR; 40 | 41 | PSON_CHAR_TYPE = CHAR; 42 | PSON_INT_TYPE = LONGINT; 43 | PSON_REAL_TYPE = SINGLE; 44 | PSON_STR_TYPE = STRING; 45 | 46 | {$IFDEF PSON16} 47 | {$DEFINE _PSON_TYPE} 48 | PSON_LEN_TYPE = WORD; 49 | {$ENDIF} 50 | {$IFDEF PSON32} 51 | {$DEFINE _PSON_TYPE} 52 | PSON_LEN_TYPE = LONGINT; 53 | {$ENDIF} 54 | {$IFNDEF _PSON_TYPE} 55 | {$UNDEF _PSON_SEL} 56 | {$IFNDEF _PSON_SEL} 57 | {$IFDEF CPU16} 58 | {$DEFINE PSON16} 59 | {$DEFINE _PSON_SEL} 60 | {$ENDIF} 61 | {$ENDIF} 62 | {$IFDEF CPU32} 63 | {$DEFINE PSON32} 64 | {$DEFINE _PSON_SEL} 65 | {$ENDIF} 66 | {$IFNDEF _PSON_SEL} 67 | {$DEFINE PSON16} 68 | {$DEFINE _PSON_SEL} 69 | {$ENDIF} 70 | {$ENDIF} 71 | {$IFNDEF _PSON_TYPE} 72 | {$IFDEF PSON16} 73 | {$DEFINE _PSON_TYPE} 74 | PSON_LEN_TYPE = WORD; 75 | {$ENDIF} 76 | 77 | {$IFDEF PSON32} 78 | {$DEFINE _PSON_TYPE} 79 | PSON_LEN_TYPE = LONGINT; 80 | {$ENDIF} 81 | {$ENDIF} 82 | 83 | FUNCTION openDoc(item : PSON_PTR_TYPE) : PSON_PTR_TYPE; 84 | FUNCTION docLength(item : PSON_PTR_TYPE) : PSON_LEN_TYPE; 85 | 86 | FUNCTION getType(item : PSON_PTR_TYPE) : CHAR; 87 | FUNCTION isType(item : PSON_PTR_TYPE; t : CHAR) : BOOLEAN; 88 | PROCEDURE getKey(item : PSON_PTR_TYPE; VAR key : PSON_KEY_TYPE); 89 | FUNCTION getValue(item : PSON_PTR_TYPE) : PSON_PTR_TYPE; 90 | 91 | FUNCTION lookup(doc : PSON_PTR_TYPE; path : STRING) : PSON_PTR_TYPE; 92 | FUNCTION next(p : PSON_PTR_TYPE) : PSON_PTR_TYPE; 93 | 94 | FUNCTION asChar(value : PSON_PTR_TYPE) : PSON_CHAR_TYPE; 95 | FUNCTION asInt(value : PSON_PTR_TYPE) : PSON_INT_TYPE; 96 | FUNCTION asReal(value : PSON_PTR_TYPE) : PSON_REAL_TYPE; 97 | FUNCTION asStr(value : PSON_PTR_TYPE) : PSON_STR_TYPE; 98 | 99 | FUNCTION endDoc(item : PSON_PTR_TYPE; lastobj : PSON_PTR_TYPE) : PSON_PTR_TYPE; 100 | 101 | FUNCTION addChar(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE; value : PSON_CHAR_TYPE) : PSON_PTR_TYPE; 102 | FUNCTION addInt(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE; value : PSON_INT_TYPE) : PSON_PTR_TYPE; 103 | FUNCTION addReal(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE; value : PSON_REAL_TYPE) : PSON_PTR_TYPE; 104 | FUNCTION addStr(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE; value : PSON_STR_TYPE) : PSON_PTR_TYPE; 105 | FUNCTION addObj(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE) : PSON_PTR_TYPE; 106 | 107 | IMPLEMENTATION 108 | 109 | CONST 110 | LEN_SIZE = SizeOf(PSON_LEN_TYPE); 111 | TYPE 112 | LEN_PTR = ^PSON_LEN_TYPE; 113 | 114 | FUNCTION next(p : PSON_PTR_TYPE) : PSON_PTR_TYPE; 115 | VAR t : CHAR; 116 | BEGIN 117 | t := PSON_EOF; 118 | IF p <> NIL THEN t := p^; 119 | IF t <> PSON_EOF THEN BEGIN 120 | Inc(p); 121 | Inc(p, ORD(p^) + 1); 122 | END ELSE p := NIL; 123 | CASE t OF 124 | PSON_CHAR: Inc(p, SizeOf(PSON_CHAR_TYPE)); 125 | PSON_INT: Inc(p, SizeOf(PSON_INT_TYPE)); 126 | PSON_REAL: Inc(p, SizeOf(PSON_REAL_TYPE)); 127 | PSON_STR: Inc(p, ORD(p^) + 1); 128 | PSON_OBJ: Inc(p, LEN_PTR(p)^ + LEN_SIZE); 129 | ELSE p := NIL; 130 | END; 131 | IF p <> NIL THEN IF p^ = PSON_EOF THEN p := NIL; 132 | next := p; 133 | END; 134 | 135 | FUNCTION openDoc(item : PSON_PTR_TYPE) : PSON_PTR_TYPE; 136 | BEGIN 137 | IF item <> NIL THEN openDoc := item + LEN_SIZE 138 | ELSE openDoc := NIL; 139 | END; 140 | 141 | FUNCTION getType(item : PSON_PTR_TYPE) : CHAR; 142 | BEGIN 143 | getType := item^; 144 | END; 145 | 146 | FUNCTION isType(item : PSON_PTR_TYPE; t : CHAR) : BOOLEAN; 147 | BEGIN 148 | isType := item^ = t; 149 | END; 150 | 151 | PROCEDURE getKey(item : PSON_PTR_TYPE; VAR key : PSON_KEY_TYPE); 152 | BEGIN 153 | key := ''; 154 | IF item <> NIL THEN BEGIN 155 | Inc(item); 156 | Move(item^, key, ORD(item^) + 1); 157 | END; 158 | END; 159 | 160 | FUNCTION getValue(item : PSON_PTR_TYPE) : PSON_PTR_TYPE; 161 | BEGIN 162 | IF item <> NIL THEN BEGIN 163 | Inc(item); 164 | Inc(item, ORD(item^) + 1); 165 | END; 166 | getValue := item; 167 | END; 168 | 169 | FUNCTION lookup(doc : PSON_PTR_TYPE; path : STRING) : PSON_PTR_TYPE; 170 | VAR dpos : INTEGER; 171 | key : STRING; 172 | ckey : STRING; 173 | r : PSON_PTR_TYPE; 174 | BEGIN 175 | r := NIL; 176 | dpos := Pos('\', path); 177 | IF dpos = 0 THEN BEGIN 178 | key := path; 179 | path := ''; 180 | END ELSE BEGIN 181 | key := Copy(path, 1, dpos - 1); 182 | path := Copy(path, dpos + 1, length(path) - dpos); 183 | END; 184 | WHILE doc <> NIL DO BEGIN 185 | getKey(doc, ckey); 186 | IF key[0] = ckey[0] THEN IF key = ckey THEN BREAK; 187 | doc := next(doc); 188 | END; 189 | IF doc <> NIL THEN BEGIN 190 | IF Length(path) <> 0 THEN BEGIN 191 | IF isType(doc, PSON_OBJ) THEN r := lookup(opendoc(getValue(doc)), path); 192 | END ELSE r := doc; 193 | END; 194 | lookup := r; 195 | END; 196 | 197 | FUNCTION asChar(value : PSON_PTR_TYPE) : PSON_CHAR_TYPE; 198 | BEGIN 199 | IF value <> NIL THEN asChar := value^ 200 | ELSE asChar := #0; 201 | END; 202 | 203 | FUNCTION asInt(value : PSON_PTR_TYPE) : PSON_INT_TYPE; 204 | TYPE 205 | PTR_TYPE = ^PSON_INT_TYPE; 206 | BEGIN 207 | IF value <> NIL THEN asInt := PTR_TYPE(value)^ 208 | ELSE asInt := 0; 209 | END; 210 | 211 | FUNCTION asReal(value : PSON_PTR_TYPE) : PSON_REAL_TYPE; 212 | TYPE 213 | PTR_TYPE = ^PSON_REAL_TYPE; 214 | BEGIN 215 | IF value <> NIL THEN asReal := PTR_TYPE(value)^ 216 | ELSE asReal := 0.0; 217 | END; 218 | 219 | FUNCTION asStr(value : PSON_PTR_TYPE) : PSON_STR_TYPE; 220 | TYPE 221 | PTR_TYPE = ^PSON_STR_TYPE; 222 | BEGIN 223 | IF value <> NIL THEN asStr := PTR_TYPE(value)^ 224 | ELSE asStr := ''; 225 | END; 226 | 227 | FUNCTION newRec(doc : PSON_PTR_TYPE; t : CHAR; key : PSON_KEY_TYPE) : PSON_PTR_TYPE; 228 | VAR len : INTEGER; 229 | BEGIN 230 | doc^ := t; 231 | Inc(doc); 232 | len := Length(key) + 1; 233 | Move(key, doc^, len); 234 | Inc(doc, len); 235 | newRec := doc; 236 | END; 237 | 238 | FUNCTION addChar(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE; value : PSON_CHAR_TYPE) : PSON_PTR_TYPE; 239 | BEGIN 240 | doc := newRec(doc, PSON_CHAR, key); 241 | doc^ := value; 242 | Inc(doc, SizeOf(value)); 243 | addChar := doc; 244 | END; 245 | 246 | FUNCTION addInt(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE; value : PSON_INT_TYPE) : PSON_PTR_TYPE; 247 | TYPE 248 | PTR_TYPE = ^PSON_INT_TYPE; 249 | BEGIN 250 | doc := newRec(doc, PSON_INT, key); 251 | PTR_TYPE(doc)^ := value; 252 | Inc(doc, SizeOf(value)); 253 | addInt := doc; 254 | END; 255 | 256 | FUNCTION addReal(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE; value : PSON_REAL_TYPE) : PSON_PTR_TYPE; 257 | TYPE 258 | PTR_TYPE = ^PSON_REAL_TYPE; 259 | BEGIN 260 | doc := newRec(doc, PSON_REAL, key); 261 | PTR_TYPE(doc)^ := value; 262 | Inc(doc, SizeOf(value)); 263 | addReal := doc; 264 | END; 265 | 266 | FUNCTION addStr(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE; value : PSON_STR_TYPE) : PSON_PTR_TYPE; 267 | VAR len : INTEGER; 268 | BEGIN 269 | len := ORD(value[0]) + 1; 270 | doc := newRec(doc, PSON_STR, key); 271 | Move(value, doc^, len); 272 | Inc(doc, len); 273 | addStr := doc; 274 | END; 275 | 276 | FUNCTION addObj(doc : PSON_PTR_TYPE; key : PSON_KEY_TYPE) : PSON_PTR_TYPE; 277 | BEGIN 278 | addObj := newRec(doc, PSON_OBJ, key); 279 | END; 280 | 281 | FUNCTION endDoc(item : PSON_PTR_TYPE; lastobj : PSON_PTR_TYPE) : PSON_PTR_TYPE; 282 | VAR len : PSON_LEN_TYPE; 283 | BEGIN 284 | lastobj^ := PSON_EOF; 285 | Inc(lastobj); 286 | len := lastobj - (item + LEN_SIZE); 287 | LEN_PTR(item)^ := len; 288 | endDoc := lastobj; 289 | END; 290 | 291 | FUNCTION docLength(item : PSON_PTR_TYPE) : PSON_LEN_TYPE; 292 | BEGIN 293 | docLength := LEN_PTR(item)^ + LEN_SIZE; 294 | END; 295 | 296 | END. 297 | 298 | -------------------------------------------------------------------------------- /QSORT.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT QSort; 24 | 25 | INTERFACE 26 | 27 | { ======================================================== 28 | Compare function must return integer: 29 | 30 | FUNCTION(info : POINTER; element1, element2 : WORD) : INTEGER; 31 | 32 | IF element1 < element2 THEN return -1 (or any negative) 33 | IF element1 = element2 THEN return 0 34 | IF element1 > element2 THEN return +1 (or any positive) 35 | ======================================================== } 36 | 37 | TYPE 38 | QS_SWAP = PROCEDURE(info : POINTER; element1, element2 : WORD); 39 | QS_CMP = FUNCTION(info : POINTER; element1, element2 : WORD) : INTEGER; 40 | 41 | QS_SWAP_LONG = PROCEDURE(info : POINTER; element1, element2 : LONGINT); 42 | QS_CMP_LONG = FUNCTION(info : POINTER; element1, element2 : LONGINT) : INTEGER; 43 | 44 | PROCEDURE Sort(info : POINTER; left, right : WORD; cmp : QS_CMP; swap : QS_SWAP); 45 | PROCEDURE SortLong(info : POINTER; left, right : LONGINT; cmp : QS_CMP_LONG; swap : QS_SWAP_LONG); 46 | 47 | IMPLEMENTATION 48 | 49 | PROCEDURE Sort(info : POINTER; left, right : WORD; cmp : QS_CMP; swap : QS_SWAP); 50 | VAR lower, upper, middle : WORD; 51 | BEGIN 52 | lower := left; 53 | upper := right; 54 | middle:= ((right - left) shr 1) + left; 55 | REPEAT 56 | WHILE cmp(info, lower, middle) < 0 DO Inc(lower); 57 | WHILE cmp(info, middle, upper) < 0 DO Dec(upper); 58 | IF lower <= upper THEN BEGIN 59 | Swap(info, lower, upper); 60 | Inc(lower); 61 | Dec(upper); 62 | END; 63 | UNTIL lower > upper; 64 | IF left < upper THEN Sort(info, left, upper, cmp, swap); 65 | IF lower < right THEN Sort(info, lower, right, cmp, swap); 66 | END; 67 | 68 | PROCEDURE SortLong(info : POINTER; left, right : LONGINT; cmp : QS_CMP_LONG; swap : QS_SWAP_LONG); 69 | VAR lower, upper, middle : LONGINT; 70 | BEGIN 71 | lower := left; 72 | upper := right; 73 | middle:= ((right - left) shr 1) + left; 74 | REPEAT 75 | WHILE cmp(info, lower, middle) < 0 DO Inc(lower); 76 | WHILE cmp(info, middle, upper) < 0 DO Dec(upper); 77 | IF lower <= upper THEN BEGIN 78 | Swap(info, lower, upper); 79 | Inc(lower); 80 | Dec(upper); 81 | END; 82 | UNTIL lower > upper; 83 | IF left < upper THEN SortLong(info, left, upper, cmp, swap); 84 | IF lower < right THEN SortLong(info, lower, right, cmp, swap); 85 | END; 86 | 87 | END. 88 | 89 | -------------------------------------------------------------------------------- /RC4.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT RC4; 24 | 25 | INTERFACE 26 | 27 | TYPE 28 | RC4_SEED = ARRAY[0..255] OF BYTE; 29 | 30 | PROCEDURE rc4_init(VAR seed : RC4_SEED; password : STRING); 31 | PROCEDURE rc4_crypt(VAR seed : RC4_SEED; VAR buf; size : WORD); 32 | 33 | IMPLEMENTATION 34 | 35 | PROCEDURE rc4_init(VAR seed : RC4_SEED; password : STRING); 36 | VAR i, j : INTEGER; 37 | len : INTEGER; 38 | x : BYTE; 39 | BEGIN 40 | FOR i := 0 TO 255 DO seed[i] := i; 41 | len := Length(password); 42 | j := 0; 43 | FOR i := 0 TO 255 DO BEGIN 44 | j := (j + seed[i] + ORD(password[(i MOD len) + 1])) AND $FF; 45 | x := seed[i]; 46 | seed[i] := seed[j]; 47 | seed[j] := x; 48 | END; 49 | END; 50 | 51 | PROCEDURE rc4_crypt(VAR seed : RC4_SEED; VAR buf; size : WORD); 52 | VAR i, j : INTEGER; 53 | x : BYTE; 54 | src : PCHAR; 55 | BEGIN 56 | i := 0; 57 | j := 0; 58 | src := @buf; 59 | WHILE size <> 0 DO BEGIN 60 | Inc(i); 61 | i := i AND $FF; 62 | Inc(j); 63 | j := j AND $FF; 64 | x := seed[i]; 65 | seed[i] := seed[j]; 66 | seed[j] := x; 67 | src^ := CHR(ORD(src^) XOR seed[(seed[i] + seed[j]) AND $FF]); 68 | Inc(src); 69 | Dec(size); 70 | END; 71 | END; 72 | 73 | END. 74 | -------------------------------------------------------------------------------- /READARC.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT ReadArc; 24 | 25 | INTERFACE 26 | 27 | USES System2; 28 | 29 | TYPE 30 | PFILE_ENTRY = ^FILE_ENTRY; 31 | FILE_ENTRY=RECORD 32 | name : STRING; 33 | hcode : WORD; 34 | ofs : LONGINT; 35 | csize : LONGINT; 36 | ucsize : LONGINT; 37 | ctype : WORD; 38 | next : PFILE_ENTRY; 39 | END; 40 | 41 | { funtion to operate with (loaded) files list } 42 | 43 | FUNCTION FE_CREATE(next : PFILE_ENTRY; VAR name : STRING) : PFILE_ENTRY; 44 | FUNCTION FE_FIND(root : PFILE_ENTRY; name : STRING; VAR dst : PFILE_ENTRY) : BOOLEAN; 45 | PROCEDURE FE_DESTROY_ALL(fe : PFILE_ENTRY); 46 | 47 | { funtion to load files list from archive } 48 | 49 | FUNCTION load_zip(VAR f : BFile) : PFILE_ENTRY; 50 | FUNCTION load_ha(VAR f : BFile) : PFILE_ENTRY; 51 | FUNCTION load_tar(VAR f : BFile) : PFILE_ENTRY; 52 | FUNCTION load_any(VAR f : BFile) : PFILE_ENTRY; 53 | 54 | { ================================================ 55 | Usage example: 56 | 57 | uses System2, ReadArc; 58 | 59 | var n, i : PFILE_ENTRY; 60 | f : BFile; 61 | begin 62 | assign(f, 'test.tar'); 63 | reset(f); 64 | n := load_tar(f); 65 | close(f); 66 | i := n; 67 | while i <> nil do begin 68 | system.writeln(i^.name, 69 | , #9, i^.ofs:8 70 | , #9, i^.csize:8); 71 | i := i^.next; 72 | end; 73 | FE_DESTROY_ALL(n); 74 | end. 75 | ================================================== } 76 | 77 | IMPLEMENTATION 78 | 79 | USES Str; 80 | 81 | CONST 82 | ZIP_LSIG = $04034B50; 83 | ZIP_CSIG = $02014b50; 84 | 85 | TYPE 86 | ZIP_LHEADER = RECORD 87 | sign : LONGINT; 88 | ver : WORD; 89 | gpflag : WORD; 90 | compress : WORD; 91 | time : WORD; 92 | date : WORD; 93 | crc32 : LONGINT; 94 | csize : LONGINT; 95 | usize : LONGINT; 96 | fnamelen : WORD; 97 | extrafield : WORD; 98 | END; 99 | 100 | ZIP_CHEADER = RECORD 101 | sign : LONGINT; 102 | vers : WORD; 103 | vneeded : WORD; 104 | gpflag : WORD; 105 | compress : WORD; 106 | time : WORD; 107 | date : WORD; 108 | crc32 : LONGINT; 109 | csize : LONGINT; 110 | ucsize : LONGINT; 111 | fnamelen : WORD; 112 | extrafield : WORD; 113 | fcl : WORD; 114 | dns : WORD; 115 | ifa : WORD; 116 | efa : LONGINT; 117 | roolh : LONGINT; 118 | END; 119 | 120 | CONST 121 | HA_SIG = $4148; 122 | 123 | TYPE 124 | HA_CHEADER = RECORD 125 | sign : WORD; 126 | count : WORD; 127 | END; 128 | 129 | CONST 130 | TAR_BLOCKSIZE = 512; 131 | AR_SIGN : STRING[8] = '!'+#10; 132 | 133 | PROCEDURE norm_name(VAR s : STRING); 134 | VAR i : INTEGER; 135 | BEGIN 136 | upstr(s); 137 | FOR i := 1 TO Length(s) DO IF s[i] = '/' THEN s[i] := '\'; 138 | END; 139 | 140 | FUNCTION FE_CREATE(next : PFILE_ENTRY; VAR name : STRING) : PFILE_ENTRY; 141 | VAR r : PFILE_ENTRY; 142 | BEGIN 143 | GetMem(r, SizeOf(FILE_ENTRY)); 144 | IF r <> NIL THEN BEGIN 145 | FillChar(r^, SizeOf(FILE_ENTRY), #0); 146 | r^.name := name; 147 | norm_name(r^.name); 148 | r^.hcode := hcode(r^.name); 149 | r^.next := next; 150 | END; 151 | FE_CREATE := r; 152 | END; 153 | 154 | PROCEDURE FE_DESTROY_ALL(fe : PFILE_ENTRY); 155 | VAR r : PFILE_ENTRY; 156 | BEGIN 157 | WHILE fe <> NIL DO BEGIN 158 | r := fe; 159 | fe := fe^.next; 160 | FreeMem(r, SizeOf(FILE_ENTRY)); 161 | END; 162 | END; 163 | 164 | FUNCTION FE_FIND(root : PFILE_ENTRY; name : STRING; VAR dst : PFILE_ENTRY) : BOOLEAN; 165 | VAR h : WORD; 166 | BEGIN 167 | norm_name(name); 168 | h := hcode(name); 169 | WHILE root <> NIL DO BEGIN 170 | IF h = root^.hcode THEN IF root^.name = name THEN BREAK; 171 | root := root^.next; 172 | END; 173 | dst := root; 174 | FE_FIND := root <> NIL; 175 | END; 176 | 177 | FUNCTION load_zip(VAR f : BFile) : PFILE_ENTRY; 178 | VAR chdr : ZIP_CHEADER; 179 | lhdr : ZIP_LHEADER; 180 | s : STRING; 181 | r, l, t : PFILE_ENTRY; 182 | BEGIN 183 | r := NIL; 184 | l := NIL; 185 | 186 | IF IsOpen(f) THEN BEGIN 187 | Seek(f, 0); 188 | WHILE NOT Eof(f) DO BEGIN 189 | BlockRead(f, lhdr, SizeOf(ZIP_LHEADER)); 190 | IF lhdr.sign <> ZIP_LSIG THEN BREAK; 191 | BlockRead(f, s[1], lhdr.fnamelen); 192 | s[0] := CHR(lhdr.fnamelen); 193 | l := FE_CREATE(l, s); 194 | l^.ofs := FilePos(f) + lhdr.extrafield; 195 | Seek(f, l^.ofs + lhdr.csize); 196 | END; 197 | IF (NOT Eof(f)) AND (lhdr.sign = ZIP_CSIG) THEN BEGIN 198 | Seek(f, FilePos(f) - SizeOf(ZIP_LHEADER)); 199 | WHILE NOT Eof(f) DO BEGIN 200 | BlockRead(f, chdr, SizeOf(ZIP_CHEADER)); 201 | IF chdr.sign <> ZIP_CSIG THEN BREAK; 202 | BlockRead(f, s[1], chdr.fnamelen); 203 | s[0] := CHR(chdr.fnamelen); 204 | IF FE_FIND(l, s, t) THEN BEGIN 205 | r := FE_CREATE(r, s); 206 | r^.ctype := chdr.compress; 207 | r^.ofs := t^.ofs; 208 | r^.csize := chdr.csize; 209 | r^.ucsize := chdr.ucsize; 210 | END; 211 | Seek(f, FilePos(f) + chdr.extrafield + chdr.fcl); 212 | END; 213 | END; 214 | END; 215 | FE_DESTROY_ALL(l); 216 | load_zip := r; 217 | END; 218 | 219 | FUNCTION load_ha(VAR f : BFile) : PFILE_ENTRY; 220 | VAR r : PFILE_ENTRY; 221 | chdr : HA_CHEADER; 222 | i : INTEGER; 223 | p : LONGINT; 224 | s1, s2 : STRING; 225 | csize : LONGINT; 226 | ucsize : LONGINT; 227 | b : BYTE; 228 | BEGIN 229 | r := NIL; 230 | 231 | IF IsOpen(f) THEN BEGIN 232 | Seek(f, 0); 233 | i := 0; 234 | BlockRead(f, chdr, SizeOf(HA_CHEADER)); 235 | IF chdr.sign = HA_SIG THEN BEGIN 236 | WHILE (NOT Eof(f)) AND (i < chdr.count) DO BEGIN 237 | b := ReadByte(f) AND $0F; 238 | csize := ReadDword(f); 239 | ucsize := ReadDword(f); 240 | ReadDword(f); 241 | ReadDword(f); 242 | ReadAsciiz(f, s1); 243 | ReadAsciiz(f, s2); 244 | ReadWord(f); 245 | ReadByte(f); 246 | s1 := s1 + s2; 247 | r := FE_CREATE(r, s1); 248 | r^.ctype := b; 249 | r^.ofs := FilePos(f); 250 | r^.csize := csize; 251 | r^.ucsize := ucsize; 252 | Seek(f, r^.ofs + r^.csize); 253 | Inc(i); 254 | END; 255 | END; 256 | END; 257 | load_ha := r; 258 | END; 259 | 260 | FUNCTION load_tar(VAR f : BFile) : PFILE_ENTRY; 261 | VAR r : PFILE_ENTRY; 262 | buf : ARRAY[1..TAR_BLOCKSIZE] OF CHAR; 263 | fname : STRING; 264 | fsize : LONGINT; 265 | i : INTEGER; 266 | BEGIN 267 | r := NIL; 268 | IF IsOpen(f) THEN BEGIN 269 | Seek(f, 0); 270 | WHILE NOT Eof(f) DO BEGIN 271 | BlockRead(f, buf, TAR_BLOCKSIZE); 272 | fname := ''; 273 | i := 0; 274 | WHILE i < 5 DO BEGIN 275 | IF buf[i+258] = #0 THEN BREAK; 276 | fname[i+1] := buf[i+258]; 277 | Inc(i); 278 | END; 279 | fname[0] := CHR(i); 280 | IF fname <> 'ustar' THEN BREAK; 281 | i := 1; 282 | WHILE i < 101 DO BEGIN 283 | IF buf[i] = #0 THEN BREAK; 284 | fname[i] := buf[i]; 285 | Inc(i); 286 | END; 287 | fname[0] := CHR(i - 1); 288 | fsize := 0; 289 | i := 0; 290 | WHILE i < 12 DO BEGIN 291 | IF buf[i+125] = #0 THEN BREAK; 292 | IF buf[i+125] IN ['0'..'7'] THEN BEGIN 293 | fsize := fsize * 8; 294 | Inc(fsize, ORD(buf[i+125]) - ORD('0')); 295 | END; 296 | Inc(i); 297 | END; 298 | r := FE_CREATE(r, fname); 299 | r^.ofs := FilePos(f); 300 | r^.csize := fsize; 301 | r^.ucsize := fsize; 302 | fsize := FilePos(f) + fsize; 303 | IF (fsize MOD TAR_BLOCKSIZE) <> 0 THEN BEGIN 304 | Inc(fsize, TAR_BLOCKSIZE - (fsize MOD TAR_BLOCKSIZE)); 305 | END; 306 | Seek(f, fsize); 307 | 308 | END; 309 | END; 310 | load_tar := r; 311 | END; 312 | 313 | FUNCTION load_any(VAR f : BFile) : PFILE_ENTRY; 314 | VAR r : PFILE_ENTRY; 315 | BEGIN 316 | r := NIL; 317 | IF r = NIL THEN r := load_tar(f); 318 | IF r = NIL THEN r := load_zip(f); 319 | IF r = NIL THEN r := load_ha(f); 320 | load_any := r; 321 | END; 322 | 323 | END. 324 | -------------------------------------------------------------------------------- /README.MD: -------------------------------------------------------------------------------- 1 | # System2 library for Turbo Pascal (MS-DOS) 2 | 3 | This units is designed to replace some functions from system unit. 4 | 5 | It has support for: 6 | 7 | 1. Long file names (LFN). 8 | 2. Buffered I/O (per file: DOS memory - 16K and EMS/XMS - 128K). 9 | 3. Temporary files. 10 | 4. Quoted command-line parameters. 11 | 12 | NOTE about 16K: This value became from EMS-page size, 13 | so please dont change it. 14 | 15 | # WinCB 16 | 17 | Unit for Windows Clipboard support for MS-DOS applications. 18 | 64KB limited. 19 | 20 | # StrBin 21 | 22 | Convert Byte/Integers/Longint to/from string in various format. 23 | 24 | # Args 25 | 26 | Command line parser in modern style. 27 | 28 | # READARC 29 | 30 | Reading non-compressed archives: zip, ha, tar 31 | 32 | # License 33 | 34 | MIT License, See LICENSE file. 35 | -------------------------------------------------------------------------------- /STR.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT Str; 24 | 25 | INTERFACE 26 | 27 | FUNCTION basename(s:STRING):STRING; 28 | FUNCTION getpathname(s:STRING):STRING; 29 | FUNCTION change_ext(s:STRING; new_ext:STRING):STRING; 30 | FUNCTION get_filename_ext(s:STRING):STRING; 31 | FUNCTION poschr(var s : string; c : CHAR) : INTEGER; 32 | 33 | PROCEDURE upstr(VAR s : STRING); 34 | 35 | FUNCTION hcode(VAR s : STRING):WORD; 36 | 37 | FUNCTION is_digit(c : CHAR):BOOLEAN; 38 | FUNCTION is_hdigit(c : CHAR):BOOLEAN; 39 | FUNCTION is_alpha(c : CHAR):BOOLEAN; 40 | FUNCTION is_id(c : CHAR):BOOLEAN; 41 | FUNCTION is_blank(c : CHAR):BOOLEAN; 42 | 43 | FUNCTION ltrim(s : STRING):STRING; 44 | FUNCTION rtrim(s : STRING):STRING; 45 | FUNCTION trim(s : STRING):STRING; 46 | 47 | FUNCTION starts_with(var s : STRING; start : STRING):BOOLEAN; 48 | 49 | FUNCTION rpad(s : STRING; len : INTEGER):STRING; 50 | FUNCTION lpad(s : STRING; len : INTEGER):STRING; 51 | 52 | FUNCTION itoa(i : INTEGER):STRING; 53 | FUNCTION wtoa(w : WORD):STRING; 54 | FUNCTION ltoa(l : LONGINT):STRING; 55 | FUNCTION atoi(s : STRING; default_val : INTEGER) : INTEGER; 56 | FUNCTION atow(s : STRING; default_val : WORD) : WORD; 57 | FUNCTION atol(s : STRING; default_val : LONGINT) : LONGINT; 58 | FUNCTION ahtob(str : STRING) : BYTE; 59 | 60 | IMPLEMENTATION 61 | 62 | FUNCTION get_filename_ext(s : STRING):STRING; 63 | VAR r : STRING; 64 | i : INTEGER; 65 | BEGIN 66 | r := ''; 67 | i := Length(s); 68 | WHILE i <> 0 DO BEGIN 69 | IF s[i] = '.' THEN BREAK; 70 | Dec(i); 71 | END; 72 | IF i = 0 THEN r := '' ELSE r := copy(s, i + 1, Length(s) - i); 73 | get_filename_ext := r; 74 | END; 75 | 76 | PROCEDURE upstr(var s : STRING);ASSEMBLER; 77 | ASM 78 | push ds 79 | push es 80 | 81 | lds si, s 82 | push ds 83 | pop es 84 | cld 85 | lodsb 86 | mov cl, al 87 | or cl, cl 88 | jz @end 89 | mov di, si 90 | @cont: 91 | lodsb 92 | cmp al, 'a' 93 | jl @noconv 94 | cmp al, 'z' 95 | jg @noconv 96 | sub al, $20 97 | @noconv: 98 | stosb 99 | dec cl 100 | jnz @cont 101 | @end: 102 | pop es 103 | pop ds 104 | END; 105 | 106 | FUNCTION basename(s : STRING):STRING; 107 | VAR i : INTEGER; 108 | BEGIN 109 | FOR i := Length(s) DOWNTO 0 DO BEGIN 110 | IF s[i] IN [':','\','/'] THEN BREAK; 111 | END; 112 | IF i <> 0 THEN s := Copy(s, i+1, Length(s) - i); 113 | basename := s; 114 | END; 115 | 116 | FUNCTION getpathname(s : STRING):STRING; 117 | VAR i : INTEGER; 118 | BEGIN 119 | FOR i := Length(s) DOWNTO 0 DO BEGIN 120 | IF s[i] IN [':','\','/'] THEN BREAK; 121 | END; 122 | IF i <> 0 THEN s := Copy(s, 1, i); 123 | getpathname := s; 124 | END; 125 | 126 | FUNCTION change_ext(s : STRING; new_ext : STRING):STRING; 127 | VAR i : INTEGER; 128 | BEGIN 129 | i := Length(s); 130 | WHILE i > 0 DO BEGIN 131 | CASE s[i] OF 132 | '.': BEGIN s[0] := CHR(i - 1); BREAK; END; 133 | '/', '\', ':': BREAK; 134 | END; 135 | dec(i); 136 | END; 137 | change_ext := s + new_ext; 138 | END; 139 | 140 | FUNCTION hcode(var s : STRING):WORD;ASSEMBLER; 141 | ASM 142 | push ds 143 | lds si, s 144 | cld 145 | xor bx, bx 146 | lodsb 147 | or al, al 148 | jz @end 149 | mov cl, al 150 | @cont: 151 | mov ax, 33 152 | mul bx 153 | xchg bx, ax 154 | lodsb 155 | add bx, ax 156 | dec cl 157 | jnz @cont 158 | @end: 159 | mov ax, bx 160 | pop ds 161 | END; 162 | 163 | FUNCTION hexb(b : BYTE):STRING; 164 | CONST a : STRING[16] = '0123456789ABCDEF'; 165 | BEGIN 166 | hexb := a[((b SHR 4) AND $0f) + 1] + a[(b AND $0f) + 1]; 167 | END; 168 | 169 | FUNCTION hexw(w : WORD):STRING; 170 | BEGIN 171 | hexw := hexb(hi(w)) + hexb(lo(w)); 172 | END; 173 | 174 | FUNCTION hexdw(dw : LONGINT):STRING; 175 | BEGIN 176 | hexdw := hexw((dw SHR 16) AND $ffff) + hexw(dw AND $ffff); 177 | END; 178 | 179 | FUNCTION hexp(p : PCHAR):STRING; 180 | BEGIN 181 | hexp := hexw(seg(p[0])) + ':' + hexw(ofs(p[0])); 182 | END; 183 | 184 | FUNCTION binb(b : BYTE):STRING; 185 | var s : STRING[8]; 186 | i : INTEGER; 187 | BEGIN 188 | s[0] := #8; 189 | FOR i := 7 DOWNTO 0 DO IF (b AND (1 SHL i)) <> 0 THEN s[8-i] := '1' ELSE s[8-i] := '0'; 190 | binb := s; 191 | END; 192 | 193 | FUNCTION bindw(l : LONGINT):STRING; 194 | BEGIN 195 | bindw := Concat(binb(l SHR 24), binb(l SHR 16), binb(l SHR 8), binb(l)); 196 | END; 197 | 198 | FUNCTION octb(b : BYTE):STRING; 199 | VAR s : STRING[4]; 200 | BEGIN 201 | s := ' '; 202 | s[3] := CHR($30 + (b AND 7)); 203 | b := b SHR 3; 204 | s[2] := CHR($30 + (b AND 7)); 205 | b := b SHR 3; 206 | s[1] := CHR($30 + (b AND 3)); 207 | octb := s; 208 | END; 209 | 210 | FUNCTION is_blank(c : CHAR) : BOOLEAN;ASSEMBLER; 211 | ASM 212 | xor al, al 213 | mov ah, c 214 | cmp ah, ' ' 215 | jg @end 216 | dec al 217 | @end: 218 | END; 219 | 220 | FUNCTION is_digit(c : CHAR):BOOLEAN;ASSEMBLER; 221 | ASM 222 | xor al, al 223 | mov ah, c 224 | cmp ah, '0' 225 | jl @cont1 226 | cmp ah, '9' 227 | jg @cont1 228 | dec al 229 | @cont1: 230 | END; 231 | 232 | FUNCTION is_alpha(c : CHAR):BOOLEAN;ASSEMBLER; 233 | ASM 234 | xor al, al 235 | mov ah, c 236 | cmp ah, 'a' 237 | jl @cont1 238 | cmp ah, 'z' 239 | jg @cont1 240 | dec al 241 | jmp @end 242 | @cont1: 243 | cmp ah, 'A' 244 | jl @cont2 245 | cmp ah, 'Z' 246 | jg @cont2 247 | dec al 248 | @cont2: 249 | @end: 250 | END; 251 | 252 | FUNCTION is_hdigit(c : CHAR):BOOLEAN;ASSEMBLER; 253 | ASM 254 | xor al, al 255 | mov ah, c 256 | cmp ah, 'a' 257 | jl @cont1 258 | cmp ah, 'f' 259 | jg @cont1 260 | dec al 261 | jmp @end 262 | @cont1: 263 | cmp ah, 'A' 264 | jl @cont2 265 | cmp ah, 'f' 266 | jg @cont2 267 | dec al 268 | jmp @end 269 | @cont2: 270 | cmp ah, '0' 271 | jl @end 272 | cmp ah, '9' 273 | jg @end 274 | dec al 275 | @end: 276 | END; 277 | 278 | FUNCTION is_id(c : CHAR):BOOLEAN;ASSEMBLER; 279 | ASM 280 | xor al, al 281 | mov ah, c 282 | cmp ah, 'a' 283 | jl @cont1 284 | cmp ah, 'z' 285 | jg @cont1 286 | dec al 287 | jmp @end 288 | @cont1: 289 | cmp ah, 'A' 290 | jl @cont2 291 | cmp ah, 'Z' 292 | jg @cont2 293 | dec al 294 | jmp @end 295 | @cont2: 296 | cmp ah, '0' 297 | jl @cont3 298 | cmp ah, '9' 299 | jg @cont3 300 | dec al 301 | jmp @end 302 | @cont3: cmp ah, '_' 303 | jnz @end 304 | dec al 305 | @end: 306 | END; 307 | 308 | FUNCTION ltrim(s : STRING):STRING; 309 | VAR k, l : INTEGER; 310 | BEGIN 311 | k := 1; l := Length(s); 312 | WHILE k < l DO BEGIN 313 | IF s[k] > ' ' THEN BREAK; 314 | Inc(k); 315 | END; 316 | IF k <> 1 THEN s := copy(s, k, l - k + 1); 317 | ltrim := s; 318 | END; 319 | 320 | FUNCTION rtrim(s : STRING):STRING; 321 | BEGIN 322 | WHILE s[0] > #0 DO BEGIN 323 | IF s[ORD(s[0])] > ' ' THEN BREAK; 324 | Dec(s[0]); 325 | END; 326 | rtrim := s; 327 | END; 328 | 329 | FUNCTION trim(s : STRING):STRING; 330 | BEGIN 331 | trim := ltrim(rtrim(s)); 332 | END; 333 | 334 | FUNCTION rpad(s : STRING; len : INTEGER):STRING; 335 | BEGIN 336 | IF Length(s) > len THEN s := copy(s, 1, len) 337 | ELSE WHILE Length(s) < len DO s := s + ' '; 338 | rpad := s; 339 | END; 340 | 341 | FUNCTION lpad(s : STRING; len : INTEGER):STRING; 342 | BEGIN 343 | IF Length(s) > len THEN s := Copy(s, 1, len) 344 | ELSE WHILE Length(s) < len DO s := ' ' + s; 345 | lpad := s; 346 | END; 347 | 348 | FUNCTION itoa(i : INTEGER):STRING; 349 | VAR s : STRING; 350 | BEGIN 351 | System.Str(i, s); 352 | itoa := s; 353 | END; 354 | 355 | FUNCTION wtoa(w : WORD):STRING; 356 | VAR s : STRING; 357 | BEGIN 358 | System.Str(w, s); 359 | wtoa := s; 360 | END; 361 | 362 | FUNCTION ltoa(l : LONGINT):STRING; 363 | VAR s : STRING; 364 | BEGIN 365 | System.Str(l, s); 366 | ltoa := s; 367 | END; 368 | 369 | FUNCTION atol(s : STRING; default_val : LONGINT) : LONGINT; 370 | VAR res : LONGINT; err_pos : INTEGER; 371 | BEGIN 372 | Val(s, res, err_pos); 373 | IF err_pos <> 0 THEN res := default_val; 374 | atol := res; 375 | END; 376 | 377 | FUNCTION atoi(s : STRING; default_val : INTEGER) : INTEGER; 378 | VAR res : INTEGER; err_pos : INTEGER; 379 | BEGIN 380 | Val(s, res, err_pos); 381 | IF err_pos <> 0 THEN res := default_val; 382 | atoi := res; 383 | END; 384 | 385 | FUNCTION atow(s : STRING; default_val : WORD) : WORD; 386 | VAR res : INTEGER; err_pos : INTEGER; 387 | BEGIN 388 | Val(s, res, err_pos); 389 | IF err_pos <> 0 THEN res := default_val; 390 | atow := res; 391 | END; 392 | 393 | FUNCTION ahtob(str : STRING) : BYTE; 394 | VAR r : BYTE; 395 | i : INTEGER; 396 | c : CHAR; 397 | k : BYTE; 398 | BEGIN 399 | r := 0; 400 | IF Length(str) = 1 THEN str := '0' + str; 401 | upstr(str); 402 | IF Length(str) > 2 THEN str := Copy(str, 1, 2); 403 | FOR i := 1 TO 2 DO BEGIN 404 | c := str[i]; 405 | k := 0; 406 | IF c IN ['0'..'9'] THEN k := ORD(c) - ORD('0') 407 | ELSE IF c IN ['A'..'F'] THEN k := ORD(c) - ORD('A') + 10; 408 | r := (r SHL 4) or (k AND $0F); 409 | END; 410 | ahtob := r; 411 | END; 412 | 413 | FUNCTION starts_with(var s : STRING; start : STRING):BOOLEAN; 414 | VAR n : STRING; 415 | BEGIN 416 | n := s; 417 | IF s[0] >= start[0] THEN BEGIN 418 | n := s; n[0] := start[0]; 419 | starts_with := n = start; 420 | END ELSE starts_with := FALSE; 421 | END; 422 | 423 | FUNCTION unquote(str : STRING) : STRING; 424 | BEGIN 425 | IF Length(str) > 0 THEN BEGIN 426 | IF (str[1] = '"') AND (str[Length(str)] = '"') THEN BEGIN 427 | str := copy(str, 2, Length(str) - 2); 428 | END; 429 | END; 430 | unquote := str; 431 | END; 432 | 433 | FUNCTION poschr(var s : string; c : CHAR) : INTEGER;ASSEMBLER; 434 | ASM 435 | push ds 436 | mov ah, c 437 | lds si, s 438 | mov bx, -1 439 | cld 440 | lodsb 441 | mov cl, al 442 | @cont: 443 | or cl, cl 444 | jz @end; 445 | lodsb 446 | dec cl 447 | cmp al, ah 448 | jne @cont 449 | mov bl, cl 450 | xor bh, bh 451 | @end: 452 | mov ax, bx 453 | pop ds 454 | END; 455 | 456 | END. 457 | -------------------------------------------------------------------------------- /STRBIN.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DosWorld/libsystem2/027eab3e2992a3ecfbf54a144f31e7ab74a89d98/STRBIN.PAS -------------------------------------------------------------------------------- /SYSTEM2.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT System2; 24 | { ========================================================================= 25 | Hi ! 26 | 27 | This units is designed to replace some functions from system unit. 28 | It has support for: 29 | 30 | 1. Long file names 31 | 2. Buffered I/O (DOS memory, 16K per file). 32 | 3. Temporary files. 33 | 4. Quoted command-line parameters. 34 | 35 | NOTE about 16K: This value became from EMS-page size, 36 | so please dont change it. 37 | 38 | ========================================================================= } 39 | INTERFACE 40 | 41 | {$DEFINE USE_CACHE} 42 | 43 | {$IFDEF DPMI} 44 | {$UNDEF USE_CACHE} 45 | {$ENDIF} 46 | {$IFDEF WINDOWS} 47 | {$UNDEF USE_CACHE} 48 | {$ENDIF} 49 | {$IFDEF LINUX} 50 | {$UNDEF USE_CACHE} 51 | {$ENDIF} 52 | {$IFDEF OS2} 53 | {$UNDEF USE_CACHE} 54 | {$ENDIF} 55 | 56 | CONST 57 | BFILE_BUF_SIZE = $4000; 58 | 59 | TYPE 60 | TFILETYPE = (FS_FILE); 61 | DWORD = LONGINT; 62 | BFILE_BUF = ARRAY[0..BFILE_BUF_SIZE - 1] OF CHAR; 63 | 64 | PBFILE = ^BFILE; 65 | BFILE = RECORD 66 | f : WORD; 67 | filename : STRING; 68 | filetype : TFILETYPE; 69 | ioresult : INTEGER; 70 | is_open : BOOLEAN; 71 | buf : ^BFILE_BUF; 72 | buf_page : DWORD; 73 | buf_update : BOOLEAN; 74 | buf_count : WORD; 75 | buf_pos : WORD; 76 | fsize : DWORD; 77 | {$IFDEF USE_CACHE} 78 | rcache : POINTER; 79 | wcache : POINTER; 80 | {$ENDIF} 81 | delonclose : BOOLEAN; 82 | END; 83 | 84 | PROCEDURE Assign (VAR f : BFILE; fname : STRING); 85 | PROCEDURE Reset (VAR f : BFILE); 86 | PROCEDURE ReWrite (VAR f : BFILE); 87 | PROCEDURE Append (VAR f : BFILE); 88 | 89 | { ReWriteTemp does not requre call to Assign } 90 | PROCEDURE ReWriteTemp (VAR f : BFILE); 91 | 92 | { Console EOF, for case when input is redirected } 93 | FUNCTION cEof : BOOLEAN; 94 | 95 | FUNCTION Eof (VAR f : BFILE) : BOOLEAN; 96 | PROCEDURE Flush (VAR f : BFILE); 97 | 98 | { Set flag - delete file, when close } 99 | PROCEDURE SetDeleteOnClose(VAR f : BFILE; flag : BOOLEAN); 100 | PROCEDURE Close (VAR f : BFILE); 101 | FUNCTION IsOpen(VAR f : BFILE):BOOLEAN; 102 | 103 | FUNCTION ReadByte(VAR f : BFILE) : BYTE; 104 | FUNCTION ReadInteger(VAR f : BFILE) : INTEGER; 105 | FUNCTION ReadWord(VAR f : BFILE) : WORD; 106 | FUNCTION ReadDWord(VAR f : BFILE) : DWORD; 107 | PROCEDURE ReadLn (VAR f : BFILE; VAR s : STRING); 108 | PROCEDURE ReadAsciiz(VAR f : BFile; VAR s : STRING); 109 | FUNCTION BlockRead (VAR f : BFILE; VAR d; count : WORD) : WORD; 110 | 111 | PROCEDURE WriteByte(VAR f : BFILE; b : BYTE); 112 | PROCEDURE WriteWord(VAR f : BFILE; w : WORD); 113 | PROCEDURE WriteDWord(VAR f : BFILE; dw : DWORD); 114 | PROCEDURE Write (VAR f : BFILE; s : STRING); 115 | PROCEDURE WriteLn (VAR f : BFILE; s : STRING); 116 | PROCEDURE BlockWrite (VAR f : BFILE; VAR d; count : WORD); 117 | FUNCTION BlockCopy (VAR src, dst : BFILE; count : DWORD) : DWORD; 118 | PROCEDURE Seek (VAR f : BFILE; pos : DWORD); 119 | FUNCTION FilePos (VAR f : BFILE) : DWORD; 120 | PROCEDURE FilePosAlign (VAR f : BFILE; align : WORD); 121 | FUNCTION FileSize (VAR f : BFILE) : DWORD; 122 | PROCEDURE Truncate (VAR f : BFILE); 123 | { random access } 124 | FUNCTION GetByte(VAR f : BFILE; ofs : DWORD) : BYTE; 125 | FUNCTION GetWord(VAR f : BFILE; ofs : DWORD) : WORD; 126 | FUNCTION GetDWord(VAR f : BFILE; ofs : DWORD) : DWORD; 127 | PROCEDURE SetByte(VAR f : BFILE; ofs : DWORD; b : BYTE); 128 | PROCEDURE SetWord(VAR f : BFILE; ofs : DWORD; w : WORD); 129 | PROCEDURE SetDWord(VAR f : BFILE; ofs : DWORD; dw : DWORD); 130 | PROCEDURE IncByte(VAR f : BFILE; ofs : DWORD; b : BYTE); 131 | PROCEDURE IncWord(VAR f : BFILE; ofs : DWORD; w : WORD); 132 | PROCEDURE IncDWord(VAR f : BFILE; ofs : DWORD; dw : DWORD); 133 | PROCEDURE DecByte(VAR f : BFILE; ofs : DWORD; b : BYTE); 134 | PROCEDURE DecWord(VAR f : BFILE; ofs : DWORD; w : WORD); 135 | PROCEDURE DecDWord(VAR f : BFILE; ofs : DWORD; dw : DWORD); 136 | { } 137 | PROCEDURE Erase (VAR f : BFILE); 138 | PROCEDURE Rename (VAR f : BFILE; newName : STRING); 139 | PROCEDURE GetDir(d : BYTE; VAR s : STRING); 140 | PROCEDURE ChDir(s : STRING); 141 | PROCEDURE MkDir(s : STRING); 142 | PROCEDURE RmDir(s : STRING); 143 | 144 | { writes string to STDERR } 145 | PROCEDURE WriteLnErr (s : STRING); 146 | 147 | FUNCTION ParamCount : INTEGER; 148 | FUNCTION ParamStr(i : INTEGER) : STRING; 149 | 150 | FUNCTION FileExists(s : STRING):BOOLEAN; 151 | PROCEDURE FileDelete(s : STRING); 152 | 153 | FUNCTION GetCurrentDisk : BYTE; 154 | PROCEDURE SetCurrentDisk(disk : BYTE); 155 | 156 | IMPLEMENTATION 157 | 158 | USES Dos {$IFDEF USE_CACHE}, ExCache{$ENDIF}; 159 | 160 | CONST 161 | STDIN = 0; 162 | STDOUT = 1; 163 | STDERR = 2; 164 | 165 | SEEK_BEG = 0; 166 | SEEK_CUR = 1; 167 | SEEK_END = 2; 168 | 169 | LN_STR : STRING[2] = #$0D + #$0A; 170 | SELFNAME : PCHAR = NIL; 171 | 172 | {$IFDEF USE_CACHE} 173 | READ_CACHE_SIZE = 8; 174 | WRITE_CACHE_SIZE = 8; 175 | {$ENDIF} 176 | 177 | TYPE 178 | PSTRING = ^STRING; 179 | PWORD = ^WORD; 180 | 181 | VAR fname : STRING; 182 | fname2 : STRING; 183 | res : WORD; 184 | prevExitProc : POINTER; 185 | 186 | FUNCTION IsOpen(VAR f : BFILE):BOOLEAN; 187 | BEGIN 188 | IsOpen := f.is_open; 189 | END; 190 | 191 | FUNCTION lReWrite : WORD;ASSEMBLER; 192 | ASM 193 | PUSH DS 194 | MOV SI, offset fname + 1 195 | MOV BX, $22 196 | XOR CX, CX 197 | MOV RES, CX 198 | MOV DX, $12 199 | MOV AX, seg fname 200 | MOV DS, AX 201 | XOR DI, DI 202 | STC 203 | MOV AX, $716C 204 | INT $21 205 | JNC @end 206 | 207 | MOV DX, offset fname + 1 208 | MOV AX, seg fname 209 | MOV DS, AX 210 | MOV AH, $3C 211 | XOR CX, CX 212 | INT $21 213 | JNC @end 214 | MOV RES, AX 215 | XOR AX, AX 216 | @end: 217 | POP DS 218 | END; 219 | 220 | FUNCTION lReset:WORD;ASSEMBLER; 221 | ASM 222 | PUSH DS 223 | XOR AX, AX 224 | MOV RES, AX 225 | MOV SI, offset fname + 1 226 | MOV BX, $22 { access attr} 227 | XOR CX, CX 228 | MOV DX, $1 229 | MOV AX, seg fname 230 | MOV DS, AX 231 | XOR DI, DI 232 | STC 233 | MOV AX, $716C 234 | INT $21 235 | JNC @end 236 | 237 | MOV DX, offset fname + 1 238 | MOV AX, seg fname 239 | MOV DS, AX 240 | MOV AX, $3D02 241 | INT $21 242 | JNC @end 243 | 244 | MOV RES, AX 245 | XOR AX, AX 246 | @end: 247 | POP DS 248 | END; 249 | 250 | FUNCTION lRead(h : WORD; VAR dest; count : WORD) : WORD;ASSEMBLER; 251 | ASM 252 | PUSH DS 253 | XOR AX, AX 254 | MOV RES, AX 255 | MOV BX, h 256 | MOV CX, count 257 | LDS DX, dest 258 | MOV AH, $3F 259 | INT $21 260 | POP DS 261 | JNC @ok 262 | MOV RES, AX 263 | XOR AX, AX 264 | @ok: 265 | END; 266 | 267 | FUNCTION lWrite(h : WORD; VAR dest; count : WORD) : WORD;ASSEMBLER; 268 | ASM 269 | PUSH DS 270 | XOR AX, AX 271 | MOV RES, AX 272 | MOV BX, h 273 | MOV CX, count 274 | LDS DX, dest 275 | MOV AH, $40 276 | INT $21 277 | POP DS 278 | JNC @ok 279 | MOV RES, AX 280 | XOR AX, AX 281 | @ok: 282 | END; 283 | 284 | PROCEDURE lTruncate(h : WORD);ASSEMBLER; 285 | ASM 286 | MOV BX, h 287 | XOR CX, CX 288 | MOV AH, $40 289 | INT $21 290 | END; 291 | 292 | PROCEDURE lSeek(h : WORD; seek_typ : BYTE; pos : DWORD);ASSEMBLER; 293 | ASM 294 | MOV BX, h 295 | MOV DX, word ptr [pos] 296 | MOV CX, word ptr [pos + 2] 297 | MOV AH, $42 298 | MOV AL, seek_typ 299 | INT $21 300 | END; 301 | 302 | FUNCTION lTell(h : word) : DWORD;ASSEMBLER; 303 | ASM 304 | MOV BX, h 305 | XOR DX, DX 306 | MOV CX, DX 307 | MOV AX, $4201 308 | INT $21 309 | END; 310 | 311 | PROCEDURE lClose(h : WORD);ASSEMBLER; 312 | ASM 313 | MOV BX, h 314 | MOV AH, $3E 315 | INT $21 316 | END; 317 | 318 | PROCEDURE lErase;ASSEMBLER; 319 | ASM 320 | XOR AX, AX 321 | MOV RES, AX 322 | PUSH DS 323 | MOV DI, offset fname + 1 324 | XOR CX, CX 325 | MOV AX, seg fname 326 | MOV DS, AX 327 | XOR SI, SI 328 | STC 329 | MOV AX, $7141 330 | INT $21 331 | MOV AL, 1 332 | JC @cont 333 | DEC AL 334 | @cont: 335 | OR AL, AL 336 | JZ @end 337 | XOR CX, CX 338 | MOV DX, offset fname + 1 339 | MOV AX, seg fname 340 | MOV DS, AX 341 | STC 342 | MOV AH, $41 343 | INT $21 344 | MOV AL, 1 345 | JC @end 346 | DEC AL 347 | @end: 348 | POP DS 349 | XOR AH, AH 350 | MOV RES, AX 351 | END; 352 | 353 | PROCEDURE ChDir(s : STRING); 354 | BEGIN 355 | fname := s + #0; 356 | ASM 357 | PUSH DS 358 | MOV AX, seg fname 359 | MOV DS, AX 360 | MOV DX, offset fname + 1 361 | MOV AX, $713B 362 | PUSH DS 363 | PUSH DX 364 | STC 365 | INT $21 366 | POP DX 367 | POP DS 368 | JNC @end 369 | MOV AH, $3b 370 | INT $21 371 | @end: 372 | POP DS 373 | END; 374 | END; 375 | 376 | PROCEDURE MkDir(s : STRING); 377 | BEGIN 378 | fname := s + #0; 379 | ASM 380 | PUSH DS 381 | MOV AX, seg fname 382 | MOV DS, AX 383 | MOV DX, offset fname + 1 384 | MOV AX, $7139 385 | PUSH DS 386 | PUSH DX 387 | STC 388 | INT $21 389 | POP DX 390 | POP DS 391 | JNC @end 392 | MOV AH, $39 393 | INT $21 394 | @end: 395 | POP DS 396 | END; 397 | END; 398 | 399 | PROCEDURE RmDir(s : STRING); 400 | BEGIN 401 | fname := s + #0; 402 | ASM 403 | PUSH DS 404 | MOV AX, seg fname 405 | MOV DS, AX 406 | MOV DX, offset fname + 1 407 | MOV AX, $713A 408 | PUSH DS 409 | PUSH DX 410 | STC 411 | INT $21 412 | POP DX 413 | POP DS 414 | JNC @end 415 | MOV AH, $3A 416 | INT $21 417 | @end: 418 | POP DS 419 | END; 420 | END; 421 | 422 | FUNCTION lRename:BOOLEAN;ASSEMBLER; 423 | ASM 424 | PUSH DS 425 | MOV AX, seg fname 426 | MOV DS, AX 427 | MOV ES, AX 428 | MOV DX, offset fname + 1 429 | MOV DI, offset fname2 + 1 430 | STC 431 | MOV AX, $7156 432 | INT $21 433 | MOV AX, 1 434 | JNC @ok 435 | 436 | MOV AX, seg fname 437 | MOV DS, AX 438 | MOV ES, AX 439 | MOV DX, offset fname + 1 440 | MOV DI, offset fname2 + 1 441 | MOV AH, $56 442 | STC 443 | INT $21 444 | MOV AX, 1 445 | JNC @ok 446 | XOR AX, AX 447 | @ok: 448 | POP DS 449 | END; 450 | 451 | PROCEDURE Rename(VAR f : BFILE; newName : STRING); 452 | BEGIN 453 | f.ioresult := 0; 454 | IF f.is_open THEN EXIT; 455 | fname := f.filename + #0; 456 | fname2 := newName + #0; 457 | IF lRename THEN f.filename := newName ELSE f.ioresult := 5; 458 | END; 459 | 460 | PROCEDURE GetDir(d : BYTE; VAR s : STRING); 461 | VAR 462 | res : INTEGER; 463 | BEGIN 464 | res := 0; 465 | s[0] := #0; 466 | ASM 467 | PUSH DS 468 | LDS SI, s 469 | INC SI 470 | MOV AX, $7147 471 | STC 472 | MOV DL, d 473 | PUSH DX 474 | PUSH DS 475 | PUSH SI 476 | INT $21 477 | POP SI 478 | POP DS 479 | POP DX 480 | MOV AX, 1 481 | JNC @end 482 | 483 | MOV AH, $47 484 | STC 485 | INT $21 486 | MOV AX, 1 487 | JNC @end 488 | XOR AX, AX 489 | @end: 490 | POP DS 491 | MOV res, AX 492 | END; 493 | IF res <> 0 THEN BEGIN 494 | WHILE s[0] <> #255 DO BEGIN 495 | IF s[ORD(s[0])+1] = #0 THEN BREAK; 496 | Inc(s[0]); 497 | END; 498 | END; 499 | IF NOT (s[ORD(s[0])] IN ['\', '/']) THEN s := s + '\'; 500 | END; 501 | 502 | FUNCTION cEof : BOOLEAN;ASSEMBLER; 503 | ASM 504 | MOV AX, $4406 505 | XOR BX, BX 506 | INT $21 507 | JC @err 508 | OR AL, AL 509 | JZ @err 510 | XOR AX, AX 511 | JMP @end 512 | @err: 513 | XOR AX, AX 514 | DEC AX 515 | @end: 516 | END; 517 | 518 | FUNCTION ParamCount : INTEGER; 519 | VAR r, len : INTEGER; 520 | str : PSTRING; 521 | pos : INTEGER; 522 | BEGIN 523 | r := 0; 524 | str := PString(ptr(PrefixSeg, $80)); 525 | pos := 1; 526 | len := ORD(str^[0]); 527 | WHILE pos <= ORD(str^[0]) DO BEGIN 528 | WHILE (str^[pos] <= ' ') AND (pos <= len) DO Inc(pos); 529 | IF pos > len THEN BREAK; 530 | IF str^[pos] = '"' THEN BEGIN 531 | Inc(pos); 532 | WHILE (str^[pos] <> '"') AND (pos <= len) DO BEGIN 533 | Inc(pos); 534 | END; 535 | Inc(pos); 536 | Inc(r); 537 | END ELSE BEGIN 538 | WHILE (str^[pos] > ' ') AND (pos <= len) DO BEGIN 539 | Inc(pos); 540 | END; 541 | Inc(r); 542 | END; 543 | END; 544 | ParamCount := r; 545 | END; 546 | 547 | FUNCTION GetSelfName(psp_seg : WORD; VAR sname : PCHAR) : STRING; 548 | VAR r : STRING; 549 | c : CHAR; 550 | p : PCHAR; 551 | BEGIN 552 | r[0] := #0; 553 | IF sname = NIL THEN BEGIN 554 | sname := ptr(PWORD(ptr(psp_seg, $2C))^, 0); 555 | c := #0; 556 | WHILE NOT ((sname[0] = #0) AND (c = #0)) DO BEGIN 557 | c := sname[0]; 558 | Inc(sname, 1); 559 | END; 560 | Inc(sname, 3); 561 | END; 562 | IF sname <> NIL THEN BEGIN 563 | p := sname; 564 | WHILE r[0] <> #255 DO BEGIN 565 | IF p[0] = #0 THEN BREAK; 566 | Inc(r[0]); 567 | r[ORD(r[0])] := p[0]; 568 | Inc(p); 569 | END; 570 | END; 571 | GetSelfName := r; 572 | END; 573 | 574 | FUNCTION ParamStr(i : INTEGER) : STRING; 575 | VAR r : STRING; 576 | str : PSTRING; 577 | pos : INTEGER; 578 | len : INTEGER; 579 | c : CHAR; 580 | p : PCHAR; 581 | BEGIN 582 | r[0] := #0; 583 | IF i <> 0 THEN BEGIN 584 | str := PString(ptr(PrefixSeg, $80)); 585 | len := ORD(str^[0]); 586 | pos := 1; 587 | Dec(i); 588 | WHILE pos <= len DO BEGIN 589 | WHILE (str^[pos] <= ' ') AND (pos <= len) DO Inc(pos); 590 | IF pos > len THEN BREAK; 591 | IF str^[pos] = '"' THEN BEGIN 592 | Inc(pos); 593 | WHILE (str^[pos] <> '"') AND (pos <= len) DO BEGIN 594 | IF i = 0 THEN BEGIN 595 | Inc(r[0]); 596 | r[ORD(r[0])] := str^[pos]; 597 | END; 598 | Inc(pos); 599 | END; 600 | Inc(pos); 601 | Dec(i); 602 | END ELSE BEGIN 603 | WHILE (str^[pos] > ' ') AND (pos <= len) DO BEGIN 604 | IF i = 0 THEN BEGIN 605 | Inc(r[0]); 606 | r[ORD(r[0])] := str^[pos]; 607 | END; 608 | Inc(pos); 609 | END; 610 | Dec(i); 611 | END; 612 | END; 613 | END ELSE BEGIN 614 | r := GetSelfName(PrefixSeg, SELFNAME); 615 | END; 616 | ParamStr := r; 617 | END; 618 | 619 | PROCEDURE Assign(VAR f : BFILE; fname : STRING); 620 | BEGIN 621 | FillChar(f, SizeOf(BFILE), #0); 622 | f.filename := fname; 623 | f.filetype := FS_FILE; 624 | END; 625 | 626 | PROCEDURE ReWrite(VAR f : BFILE); 627 | BEGIN 628 | IF f.is_open THEN EXIT; 629 | GetMem(f.buf, SizeOf(BFILE_BUF)); 630 | IF f.buf = NIL THEN EXIT; 631 | fname := f.filename + #0; 632 | f.ioresult := 0; 633 | f.f := lReWrite; 634 | IF f.f = 0 THEN f.ioresult := 5; 635 | f.is_open := f.ioresult = 0; 636 | f.buf_count := 0; 637 | f.buf_pos := 0; 638 | f.buf_page := 0; 639 | f.buf_update := FALSE; 640 | f.fsize := 0; 641 | f.delonclose := FALSE; 642 | f.filetype := FS_FILE; 643 | {$IFDEF USE_CACHE} 644 | IF f.is_open THEN BEGIN 645 | f.rcache := excache_create(READ_CACHE_SIZE); 646 | f.wcache := excache_create(WRITE_CACHE_SIZE); 647 | END; 648 | {$ENDIF} 649 | IF NOT f.is_open THEN BEGIN FreeMem(f.buf, SizeOf(BFILE_BUF)); f.buf := NIL; END; 650 | END; 651 | 652 | PROCEDURE Reset(VAR f : BFILE); 653 | BEGIN 654 | IF f.is_open THEN EXIT; 655 | GetMem(f.buf, SizeOf(BFILE_BUF)); 656 | IF f.buf = NIL THEN EXIT; 657 | f.ioresult := 0; 658 | fname := f.filename + #0; 659 | f.f := lReset; 660 | IF f.f = 0 THEN f.ioresult := 2; 661 | f.is_open := f.ioresult = 0; 662 | f.buf_count := 0; 663 | f.buf_pos := 0; 664 | f.buf_page := 0; 665 | f.buf_update := FALSE; 666 | f.delonclose := FALSE; 667 | f.filetype := FS_FILE; 668 | IF f.is_open THEN BEGIN 669 | lSeek(f.f, SEEK_END, 0); 670 | f.fsize := lTell(f.f); 671 | lSeek(f.f, SEEK_BEG, 0); 672 | f.buf_count := lRead(f.f, f.buf^, SizeOf(BFILE_BUF)); 673 | if res <> 0 THEN f.ioresult := 100; 674 | END; 675 | {$IFDEF USE_CACHE} 676 | IF f.is_open THEN BEGIN 677 | f.rcache := excache_create(READ_CACHE_SIZE); 678 | f.wcache := excache_create(WRITE_CACHE_SIZE); 679 | END; 680 | {$ENDIF} 681 | IF NOT f.is_open THEN BEGIN FreeMem(f.buf, SizeOf(BFILE_BUF)); f.buf := NIL; END; 682 | END; 683 | 684 | PROCEDURE Append (VAR f : BFILE); 685 | BEGIN 686 | Reset(f); 687 | IF f.is_open THEN Seek(f, FileSize(f)) ELSE ReWrite(f); 688 | END; 689 | 690 | PROCEDURE ReWriteTemp(VAR f : BFILE); 691 | CONST 692 | CHARS : string = '0123456789-_QWERTYUIOPASDFGHJKLZXCVBNM'; 693 | VAR tmp : STRING; 694 | name : STRING[12]; 695 | i : INTEGER; 696 | BEGIN 697 | FillChar(f, SizeOf(BFILE), #0); 698 | tmp := GetEnv('TMP'); 699 | IF Length(tmp) = 0 THEN tmp := GetEnv('TEMP'); 700 | IF Length(tmp) = 0 THEN tmp := GetEnv('HOME'); 701 | IF Length(tmp) = 0 THEN GetDir(0, tmp); 702 | IF Length(tmp) <> 0 THEN BEGIN 703 | IF NOT (tmp[ORD(tmp[0])] IN ['\', '/']) THEN tmp := tmp + '\'; 704 | END; 705 | FOR i := 1 TO 8 DO name[i] := CHARS[1 + Random(ORD(CHARS[0]))]; 706 | name[0] := #8; 707 | name := name + '.TMP'; 708 | Assign(f, tmp + name); 709 | ReWrite(f); 710 | Truncate(f); 711 | SetDeleteOnClose(f, TRUE); 712 | END; 713 | 714 | PROCEDURE UpdateFileSize(VAR f : BFILE); 715 | VAR ns : DWORD; 716 | BEGIN 717 | ns := DWORD(f.buf_page) * SizeOf(BFILE_BUF) + f.buf_count; 718 | IF f.fsize < ns THEN f.fsize := ns; 719 | END; 720 | 721 | FUNCTION Eof(VAR f : BFILE) : BOOLEAN; 722 | BEGIN 723 | IF NOT f.is_open THEN BEGIN 724 | f.ioresult := 103; 725 | EXIT; 726 | END; 727 | f.ioresult := 0; 728 | UpdateFileSize(f); 729 | Eof := (f.buf_page * SizeOf(BFILE_BUF) + f.buf_pos) = f.fsize; 730 | END; 731 | 732 | 733 | PROCEDURE FsSwitchPage(VAR f : BFILE; new_page : DWORD); 734 | VAR ns : DWORD; 735 | csize : WORD; 736 | BEGIN 737 | IF f.buf_update THEN UpdateFileSize(f); 738 | {$IFDEF USE_CACHE} 739 | IF (f.wcache <> NIL) AND (f.rcache <> NIL) THEN BEGIN 740 | IF f.buf_update THEN BEGIN 741 | IF excache_Put(PEXCACHE(f.wcache), f.buf_page, f.buf^, f.buf_count) THEN BEGIN 742 | IF excache_IsFull(PEXCACHE(f.wcache)) THEN BEGIN 743 | csize := excache_Size(PEXCACHE(f.wcache)); 744 | f.buf_page := PEXCACHE(f.wcache)^.items[csize].recno; 745 | excache_Get(PEXCACHE(f.wcache), f.buf_page, f.buf^, f.buf_count); 746 | excache_Put(PEXCACHE(f.rcache), f.buf_page, f.buf^, f.buf_count); 747 | f.buf_update := TRUE; 748 | END ELSE f.buf_update := FALSE; 749 | END; 750 | END ELSE excache_Put(PEXCACHE(f.rcache), f.buf_page, f.buf^, f.buf_count); 751 | END; 752 | {$ENDIF} 753 | IF f.buf_update THEN BEGIN 754 | lSeek(f.f, SEEK_BEG, f.buf_page * SizeOf(BFILE_BUF)); 755 | lWrite(f.f, f.buf^, f.buf_count); 756 | f.buf_update := FALSE; 757 | END; 758 | 759 | f.buf_page := new_page; 760 | f.buf_pos := 0; 761 | {$IFDEF USE_CACHE} 762 | IF (f.rcache <> NIL) AND excache_Get(PEXCACHE(f.rcache), f.buf_page, f.buf^, f.buf_count) THEN BEGIN 763 | f.buf_update := FALSE; 764 | END ELSE IF (f.wcache <> NIL) AND excache_Get(PEXCACHE(f.wcache), f.buf_page, f.buf^, f.buf_count) THEN BEGIN 765 | f.buf_update := TRUE; 766 | END ELSE BEGIN 767 | f.buf_update := FALSE; 768 | lSeek(f.f, SEEK_BEG, f.buf_page * SizeOf(BFILE_BUF)); 769 | f.buf_count := lRead(f.f, f.buf^, SizeOf(BFILE_BUF)); 770 | END; 771 | {$ENDIF} 772 | {$IFNDEF USE_CACHE} 773 | f.buf_update := FALSE; 774 | lSeek(f.f, SEEK_BEG, f.buf_page * SizeOf(BFILE_BUF)); 775 | f.buf_count := lRead(f.f, f.buf^, SizeOf(BFILE_BUF)); 776 | {$ENDIF} 777 | IF res <> 0 THEN BEGIN 778 | f.ioresult := 100; 779 | END; 780 | END; 781 | 782 | PROCEDURE SwitchPage(VAR f : BFILE; new_page : DWORD); 783 | BEGIN 784 | res := 0; 785 | f.ioresult := 0; 786 | 787 | IF f.buf_page = new_page THEN EXIT; 788 | FsSwitchPage(f, new_page); 789 | END; 790 | 791 | PROCEDURE BlockWrite(VAR f : BFILE; VAR d; count : WORD); 792 | VAR p : PCHAR; 793 | delta : WORD; 794 | BEGIN 795 | IF NOT f.is_open THEN BEGIN 796 | f.ioresult := 105; 797 | EXIT; 798 | END; 799 | f.ioresult := 0; 800 | res := 0; 801 | p := @d; 802 | WHILE count <> 0 DO BEGIN 803 | delta := SizeOf(BFILE_BUF) - f.buf_pos; 804 | IF delta = 0 THEN BEGIN 805 | SwitchPage(f, f.buf_page + 1); 806 | f.buf_pos := 0; 807 | IF f.ioresult <> 0 THEN BREAK; 808 | delta := SizeOf(BFILE_BUF); 809 | END; 810 | IF delta > count THEN delta := count; 811 | Move(p^, f.buf^[f.buf_pos], delta); 812 | f.buf_update := TRUE; 813 | Inc(f.buf_pos, delta); 814 | Inc(p, delta); 815 | Dec(count, delta); 816 | IF f.buf_pos > f.buf_count THEN f.buf_count := f.buf_pos; 817 | END; 818 | END; 819 | 820 | FUNCTION BlockRead(VAR f : BFILE; VAR d; count : WORD) : WORD; 821 | VAR p : PCHAR; 822 | delta : WORD; 823 | r : WORD; 824 | BEGIN 825 | IF NOT f.is_open THEN BEGIN 826 | f.ioresult := 104; 827 | EXIT; 828 | END; 829 | f.ioresult := 0; 830 | r := 0; 831 | res := 0; 832 | p := @d; 833 | WHILE count <> 0 DO BEGIN 834 | delta := f.buf_count - f.buf_pos; 835 | IF delta = 0 THEN BEGIN 836 | SwitchPage(f, f.buf_page + 1); 837 | f.buf_pos := 0; 838 | IF f.buf_count = 0 THEN BREAK; 839 | delta := f.buf_count; 840 | END; 841 | IF delta > count THEN delta := count; 842 | Move(f.buf^[f.buf_pos], p^, delta); 843 | Inc(f.buf_pos, delta); 844 | Dec(count, delta); 845 | Inc(p, delta); 846 | Inc(r, delta); 847 | END; 848 | BlockRead := r; 849 | END; 850 | 851 | PROCEDURE Seek(VAR f : BFILE; pos : DWORD); 852 | BEGIN 853 | IF NOT f.is_open THEN BEGIN 854 | f.ioresult := 103; 855 | EXIT; 856 | END; 857 | f.ioresult := 0; 858 | res := 0; 859 | SwitchPage(f, pos DIV SizeOf(BFILE_BUF)); 860 | IF f.ioresult = 0 THEN BEGIN 861 | f.buf_pos := pos MOD SizeOf(BFILE_BUF); 862 | IF f.buf_count < f.buf_pos THEN f.buf_pos := f.buf_count; 863 | END; 864 | END; 865 | 866 | FUNCTION FilePos(VAR f : BFILE) : DWORD; 867 | BEGIN 868 | f.ioresult := 0; 869 | IF NOT f.is_open THEN BEGIN 870 | f.ioresult := 103; 871 | FilePos := 0; 872 | END ELSE FilePos := DWORD(f.buf_page) * SizeOf(BFILE_BUF) + f.buf_pos; 873 | END; 874 | 875 | FUNCTION FileSize(VAR f : BFILE) : DWORD; 876 | BEGIN 877 | f.ioresult := 0; 878 | IF NOT f.is_open THEN BEGIN 879 | f.ioresult := 103; 880 | FileSize := 0; 881 | END ELSE BEGIN 882 | UpdateFileSize(f); 883 | FileSize := f.fsize; 884 | END; 885 | END; 886 | 887 | PROCEDURE FilePosAlign (VAR f : BFILE; align : WORD); 888 | VAR fpos : DWORD; 889 | npos : DWORD; 890 | fsize : DWORD; 891 | m : WORD; 892 | buf : STRING; 893 | BEGIN 894 | fpos := FilePos(f); 895 | npos := fpos DIV align; 896 | m := fpos MOD align; 897 | IF m = 0 THEN EXIT; 898 | Inc(npos); 899 | npos := npos * align; 900 | fsize := FileSize(f); 901 | IF fsize >= npos THEN BEGIN Seek(f, npos); EXIT; END; 902 | IF fpos <> fsize THEN BEGIN 903 | Seek(f, fsize); 904 | m := fsize MOD align; 905 | END; 906 | FillChar(buf[0], 256, #0); 907 | m := align - m; 908 | WHILE m <> 0 DO BEGIN 909 | IF m > 256 THEN BEGIN 910 | BlockWrite(f, buf[0], 256); 911 | Dec(m, 256); 912 | END ELSE BEGIN 913 | BlockWrite(f, buf[0], m); 914 | m := 0; 915 | END; 916 | END; 917 | END; 918 | 919 | PROCEDURE Flush(VAR f : BFILE); 920 | VAR i : INTEGER; 921 | bp : DWORD; 922 | bc : WORD; 923 | buf_used : BOOLEAN; 924 | BEGIN 925 | IF NOT f.is_open THEN EXIT; 926 | res := 0; 927 | f.ioresult := 0; 928 | 929 | IF f.filetype = FS_FILE THEN BEGIN 930 | {$IFDEF USE_CACHE} 931 | IF f.buf_update THEN BEGIN 932 | f.buf_update := NOT excache_put(PEXCACHE(f.wcache), f.buf_page, f.buf^, f.buf_count); 933 | END; 934 | {$ENDIF} 935 | IF f.buf_update THEN BEGIN 936 | lSeek(f.f, SEEK_BEG, f.buf_page * SizeOf(BFILE_BUF)); 937 | lWrite(f.f, f.buf^, f.buf_count); 938 | f.buf_update := FALSE; 939 | END; 940 | {$IFDEF USE_CACHE} 941 | buf_used := FALSE; 942 | excache_put(PEXCACHE(f.rcache), f.buf_page, f.buf^, f.buf_count); 943 | FOR i := 1 TO excache_size(PEXCACHE(f.wcache)) DO BEGIN 944 | IF PEXCACHE(f.wcache)^.items[i].is_busy THEN BEGIN 945 | bp := PEXCACHE(f.wcache)^.items[i].recno; 946 | bc := PEXCACHE(f.wcache)^.items[i].count; 947 | excache_get(PEXCACHE(f.wcache), bp, f.buf^, bc); 948 | lSeek(f.f, SEEK_BEG, bp * SizeOf(BFILE_BUF)); 949 | lWrite(f.f, f.buf^, bc); 950 | buf_used := TRUE; 951 | END; 952 | END; 953 | IF NOT excache_get(PEXCACHE(f.rcache), f.buf_page, f.buf^, f.buf_count) THEN BEGIN 954 | IF buf_used THEN BEGIN 955 | lSeek(f.f, SEEK_BEG, f.buf_page * SizeOf(BFILE_BUF)); 956 | lRead(f.f, f.buf^, f.buf_count); 957 | END; 958 | END; 959 | {$ENDIF} 960 | END; 961 | END; 962 | 963 | PROCEDURE FsClose(VAR f : BFILE); 964 | BEGIN 965 | lClose(f.f); 966 | f.is_open := FALSE; 967 | f.buf_count := 0; 968 | f.buf_pos := 0; 969 | f.buf_page := 0; 970 | f.fsize := 0; 971 | IF f.delonclose THEN Erase(f); 972 | END; 973 | 974 | PROCEDURE Close(VAR f : BFILE); 975 | BEGIN 976 | res := 0; 977 | f.ioresult := 0; 978 | 979 | IF NOT f.is_open THEN EXIT; 980 | IF NOT f.delonclose THEN Flush(f); 981 | IF f.filetype = FS_FILE THEN FsClose(f); 982 | {$IFDEF USE_CACHE} 983 | excache_free(PEXCACHE(f.rcache)); 984 | excache_free(PEXCACHE(f.wcache)); 985 | {$ENDIF} 986 | IF f.buf <> NIL THEN FreeMem(f.buf, SizeOf(BFILE_BUF)); 987 | FillChar(f, SizeOf(BFILE), #0); 988 | END; 989 | 990 | PROCEDURE Write(VAR f : BFILE; s : STRING); 991 | BEGIN 992 | BlockWrite(f, s[1], ORD(s[0])); 993 | END; 994 | 995 | PROCEDURE WriteLn(VAR f : BFILE; s : STRING); 996 | BEGIN 997 | BlockWrite(f, s[1], ORD(s[0])); 998 | IF f.ioresult = 0 THEN BlockWrite(f, LN_STR[1], ORD(LN_STR[0])); 999 | END; 1000 | 1001 | PROCEDURE WriteLnErr (s : STRING); 1002 | BEGIN 1003 | lWrite(STDERR, s[1], ORD(s[0])); 1004 | lWrite(STDERR, LN_STR[1], ORD(LN_STR[0])); 1005 | END; 1006 | 1007 | PROCEDURE ReadAsciiz(VAR f : BFile; VAR s : STRING); 1008 | VAR p : LONGINT; 1009 | BEGIN 1010 | p := FilePos(f); 1011 | BlockRead(f, s[1], 255); 1012 | s[0] := #0; 1013 | WHILE s[0] < #255 DO BEGIN 1014 | IF s[ord(s[0]) + 1] = #0 THEN BREAK; 1015 | Inc(s[0]); 1016 | END; 1017 | Seek(f, p + ord(s[0]) + 1); 1018 | END; 1019 | 1020 | PROCEDURE ReadLn(VAR f : BFILE; VAR s : STRING); 1021 | VAR c : CHAR; 1022 | p : PCHAR; 1023 | tstr : STRING; 1024 | BEGIN 1025 | IF NOT f.is_open THEN EXIT; 1026 | tstr[0] := #0; 1027 | c := #0; 1028 | WHILE (c <> #$0A) AND (tstr[0] <> #255) DO BEGIN 1029 | p := @f.buf^[f.buf_pos]; 1030 | c := #0; 1031 | WHILE (f.buf_pos < f.buf_count) AND (tstr[0] < #255) DO BEGIN 1032 | c := p^; 1033 | Inc(p); 1034 | Inc(f.buf_pos); 1035 | IF c <> #$0D THEN BEGIN 1036 | IF c = #$0A THEN BREAK; 1037 | Inc(tstr[0]); 1038 | tstr[ORD(tstr[0])] := c; 1039 | END; 1040 | END; 1041 | IF f.buf_pos = f.buf_count THEN BEGIN 1042 | SwitchPage(f, f.buf_page + 1); 1043 | IF f.ioresult <> 0 THEN BREAK; 1044 | f.buf_pos := 0; 1045 | IF f.buf_count = 0 THEN BREAK; 1046 | END; 1047 | END; 1048 | s := tstr; 1049 | END; 1050 | 1051 | PROCEDURE FsTruncate(VAR f : BFILE); 1052 | VAR i : INTEGER; 1053 | BEGIN 1054 | f.fsize := f.buf_page * SizeOf(BFILE_BUF) + f.buf_pos; 1055 | f.buf_count := f.buf_pos; 1056 | {$IFDEF USE_CACHE} 1057 | IF f.rcache <> NIL THEN excache_truncate(PEXCACHE(f.rcache), f.buf_page, f.buf_count); 1058 | IF f.wcache <> NIL THEN excache_truncate(PEXCACHE(f.wcache), f.buf_page, f.buf_count); 1059 | {$ENDIF} 1060 | res := 0; 1061 | lSeek(f.f, SEEK_BEG, f.fsize); 1062 | lTruncate(f.f); 1063 | f.ioresult := res; 1064 | IF f.ioresult <> 0 THEN BEGIN 1065 | f.ioresult := 101; 1066 | EXIT; 1067 | END; 1068 | END; 1069 | 1070 | PROCEDURE Truncate (VAR f : BFILE); 1071 | BEGIN 1072 | IF NOT f.is_open THEN BEGIN 1073 | f.ioresult := 105; 1074 | EXIT; 1075 | END; 1076 | f.ioresult := 0; 1077 | IF f.filetype = FS_FILE THEN FsTruncate(f) 1078 | END; 1079 | 1080 | PROCEDURE Erase (VAR f : BFILE); 1081 | BEGIN 1082 | IF f.is_open THEN EXIT; 1083 | fname := f.filename + #0; 1084 | lErase; 1085 | f.ioresult := res; 1086 | IF f.ioresult = 0 THEN f.ioresult := 2 ELSE f.ioresult := 0; 1087 | END; 1088 | 1089 | FUNCTION BlockCopy (VAR src, dst : BFILE; count : DWORD) : DWORD; 1090 | VAR delta : WORD; 1091 | fp, fs : DWORD; 1092 | BEGIN 1093 | IF (NOT src.is_open) OR (NOT dst.is_open) THEN BEGIN 1094 | BlockCopy := 0; 1095 | EXIT; 1096 | END; 1097 | fs := FileSize(src); 1098 | fp := FilePos(src); 1099 | IF fp + count > fs THEN count := fs - fp; 1100 | fp := 0; 1101 | WHILE count <> 0 DO BEGIN 1102 | delta := src.buf_count - src.buf_pos; 1103 | IF delta = 0 THEN BEGIN 1104 | SwitchPage(src, src.buf_page + 1); 1105 | IF src.ioresult <> 0 THEN BREAK; 1106 | src.buf_pos := 0; 1107 | delta := src.buf_count; 1108 | END; 1109 | IF delta > count THEN delta := count; 1110 | BlockWrite(dst, src.buf^[src.buf_pos], delta); 1111 | IF dst.ioresult <> 0 THEN BREAK; 1112 | Inc(src.buf_pos, delta); 1113 | Dec(count, delta); 1114 | Inc(fp, delta); 1115 | END; 1116 | BlockCopy := fp; 1117 | END; 1118 | 1119 | FUNCTION ReadByte(VAR f : BFILE) : BYTE; 1120 | VAR r : BYTE; 1121 | BEGIN 1122 | IF BlockRead(f, r, SizeOf(r)) <> 1 THEN r := 0; 1123 | ReadByte := r; 1124 | END; 1125 | 1126 | FUNCTION ReadInteger(VAR f : BFILE) : INTEGER; 1127 | VAR b : ARRAY[0..1] OF BYTE; 1128 | i : INTEGER; 1129 | BEGIN 1130 | i := 0; 1131 | IF BlockRead(f, b, SizeOf(b)) = 2 THEN BEGIN 1132 | i := b[1]; 1133 | i := i SHL 8; 1134 | i := i OR b[0]; 1135 | END; 1136 | ReadInteger := i; 1137 | END; 1138 | 1139 | FUNCTION ReadWord(VAR f : BFILE) : WORD; 1140 | VAR b : ARRAY[0..1] OF BYTE; 1141 | w : WORD; 1142 | BEGIN 1143 | w := 0; 1144 | IF BlockRead(f, b, SizeOf(b)) = 2 THEN BEGIN 1145 | w := b[1]; 1146 | w := w SHL 8; 1147 | w := w OR b[0]; 1148 | END; 1149 | ReadWord := w; 1150 | END; 1151 | 1152 | FUNCTION ReadDWord(VAR f : BFILE) : DWORD; 1153 | VAR 1154 | b : ARRAY[0..3] OF BYTE; 1155 | dw : DWORD; 1156 | BEGIN 1157 | dw := 0; 1158 | IF BlockRead(f, b, SizeOf(b)) = 4 THEN BEGIN 1159 | dw := b[3] AND $FF; 1160 | dw := dw SHL 8; 1161 | dw := dw OR b[2]; 1162 | dw := dw SHL 8; 1163 | dw := dw OR b[1]; 1164 | dw := dw SHL 8; 1165 | dw := dw OR b[0]; 1166 | END; 1167 | ReadDWord := dw; 1168 | END; 1169 | 1170 | PROCEDURE WriteByte(VAR f : BFILE; b : BYTE); 1171 | BEGIN 1172 | BlockWrite(f, b, SizeOf(b)); 1173 | END; 1174 | 1175 | PROCEDURE WriteWord(VAR f : BFILE; w : WORD); 1176 | VAR b : ARRAY[0..1] OF BYTE; 1177 | BEGIN 1178 | b[0] := w AND $FF; 1179 | w := w SHR 8; 1180 | b[1] := w AND $FF; 1181 | BlockWrite(f, b, SizeOf(b)); 1182 | END; 1183 | 1184 | PROCEDURE WriteDWord(VAR f : BFILE; dw : DWORD); 1185 | VAR b : ARRAY[0..3] OF BYTE; 1186 | BEGIN 1187 | b[0] := dw AND $FF; 1188 | dw := dw SHR 8; 1189 | b[1] := dw AND $FF; 1190 | dw := dw SHR 8; 1191 | b[2] := dw AND $FF; 1192 | dw := dw SHR 8; 1193 | b[3] := dw AND $FF; 1194 | BlockWrite(f, b, SizeOf(b)); 1195 | END; 1196 | 1197 | PROCEDURE IncByte(VAR f : BFILE; ofs : DWORD; b : BYTE); 1198 | VAR v : BYTE; 1199 | BEGIN 1200 | Seek(f, ofs); 1201 | v := ReadByte(f); 1202 | Seek(f, ofs); 1203 | WriteByte(f, v + b); 1204 | END; 1205 | 1206 | PROCEDURE IncWord(VAR f : BFILE; ofs : DWORD; w : WORD); 1207 | VAR v : WORD; 1208 | BEGIN 1209 | Seek(f, ofs); 1210 | v := ReadWord(f); 1211 | Seek(f, ofs); 1212 | WriteWord(f, v + w); 1213 | END; 1214 | 1215 | PROCEDURE IncDWord(VAR f : BFILE; ofs : DWORD; dw : DWORD); 1216 | VAR v : DWORD; 1217 | BEGIN 1218 | Seek(f, ofs); 1219 | v := ReadDWord(f); 1220 | Seek(f, ofs); 1221 | WriteDWord(f, v + dw); 1222 | END; 1223 | 1224 | PROCEDURE DecByte(VAR f : BFILE; ofs : DWORD; b : BYTE); 1225 | VAR v : BYTE; 1226 | BEGIN 1227 | Seek(f, ofs); 1228 | v := ReadByte(f); 1229 | Seek(f, ofs); 1230 | WriteByte(f, v - b); 1231 | END; 1232 | 1233 | PROCEDURE DecWord(VAR f : BFILE; ofs : DWORD; w : WORD); 1234 | VAR v : WORD; 1235 | BEGIN 1236 | Seek(f, ofs); 1237 | v := ReadWord(f); 1238 | Seek(f, ofs); 1239 | WriteWord(f, v - w); 1240 | END; 1241 | 1242 | PROCEDURE DecDWord(VAR f : BFILE; ofs : DWORD; dw : DWORD); 1243 | VAR v : DWORD; 1244 | BEGIN 1245 | Seek(f, ofs); 1246 | v := ReadDWord(f); 1247 | Seek(f, ofs); 1248 | WriteDWord(f, v - dw); 1249 | END; 1250 | 1251 | PROCEDURE SetByte(VAR f : BFILE; ofs : DWORD; b : BYTE); 1252 | BEGIN 1253 | Seek(f, ofs); 1254 | WriteByte(f, b); 1255 | END; 1256 | 1257 | PROCEDURE SetWord(VAR f : BFILE; ofs : DWORD; w : WORD); 1258 | BEGIN 1259 | Seek(f, ofs); 1260 | WriteWord(f, w); 1261 | END; 1262 | 1263 | PROCEDURE SetDWord(VAR f : BFILE; ofs : DWORD; dw : DWORD); 1264 | BEGIN 1265 | Seek(f, ofs); 1266 | WriteDWord(f, dw); 1267 | END; 1268 | 1269 | FUNCTION GetByte(VAR f : BFILE; ofs : DWORD) : BYTE; 1270 | BEGIN 1271 | Seek(f, ofs); 1272 | GetByte := ReadByte(f); 1273 | END; 1274 | 1275 | FUNCTION GetWord(VAR f : BFILE; ofs : DWORD) : WORD; 1276 | BEGIN 1277 | Seek(f, ofs); 1278 | GetWord := ReadWord(f); 1279 | END; 1280 | 1281 | FUNCTION GetDWord(VAR f : BFILE; ofs : DWORD) : DWORD; 1282 | BEGIN 1283 | Seek(f, ofs); 1284 | GetDWord := ReadDWord(f); 1285 | END; 1286 | 1287 | PROCEDURE SetDeleteOnClose(VAR f : BFILE; flag : BOOLEAN); 1288 | BEGIN 1289 | IF f.is_open AND (f.filetype = FS_FILE) THEN f.delonclose := flag; 1290 | END; 1291 | 1292 | FUNCTION FileExists(s : STRING):BOOLEAN; 1293 | VAR h : WORD; 1294 | BEGIN 1295 | fname := s + #0; 1296 | h := lReset; 1297 | IF h <> 0 THEN lclose(h); 1298 | FileExists := h <> 0; 1299 | END; 1300 | 1301 | PROCEDURE FileDelete(s : STRING); 1302 | BEGIN 1303 | fname := s + #0; 1304 | lErase; 1305 | END; 1306 | 1307 | FUNCTION GetCurrentDisk : BYTE;ASSEMBLER; 1308 | ASM 1309 | MOV AH, $19 1310 | INT $21 1311 | END; 1312 | 1313 | PROCEDURE SetCurrentDisk(disk : BYTE);ASSEMBLER; 1314 | ASM 1315 | MOV AH, $0e 1316 | MOV DL, disk 1317 | INT $21 1318 | END; 1319 | 1320 | { 1321 | PROCEDURE MyExitProc;FAR; 1322 | BEGIN 1323 | exitProc := prevExitProc; 1324 | END; 1325 | } 1326 | 1327 | BEGIN 1328 | Randomize; 1329 | { 1330 | prevExitProc := exitProc; 1331 | exitProc := @MyExitProc; 1332 | } 1333 | END. 1334 | -------------------------------------------------------------------------------- /UJSON.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2024 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT UJSON; 24 | 25 | INTERFACE 26 | 27 | (* 28 | ---------------------------------------------------------------------- 29 | Example: 30 | 31 | PROGRAM test; 32 | 33 | USES ujson; 34 | 35 | FUNCTION mycb(key, val : STRING; ctx : POINTER) : BOOLEAN; 36 | BEGIN 37 | WriteLn(key, '=', val); 38 | mycb := TRUE; 39 | END; 40 | 41 | CONST 42 | t : PCHAR = 43 | '{' + #13 + #10 + 44 | ' "pb": {' + #13 + #10 + 45 | ' "p": 75,' + #13 + #10 + 46 | ' "i": 0.5,' + #13 + #10 + 47 | ' "d": 30,' + #13 + #10 + 48 | ' "iMin": -50,' + #13 + #10 + 49 | ' "iMax": 50' + #13 + #10 + 50 | ' },' + #13 + #10 + 51 | ' "pe": {' + #13 + #10 + 52 | ' "p": 0.9,' + #13 + #10 + 53 | ' "i": 0.001,' + #13 + #10 + 54 | ' "d": 2.12,' + #13 + #10 + 55 | ' "iMin": 0,' + #13 + #10 + 56 | ' "iMax": 0' + #13 + #10 + 57 | ' },' + #13 + #10 + 58 | ' "p1": {' + #13 + #10 + 59 | ' "p2": {' + #13 + #10 + 60 | ' "p3": "12345",' + #13 + #10 + 61 | ' p4: [ 1, 2, 3, 4, 5 ]' + #13 + #10 + 62 | ' }' + #13 + #10 + 63 | ' },' + #13 + #10 + 64 | ' "bt": 24.5,' + #13 + #10 + 65 | ' "et": 4.8,' + #13 + #10 + 66 | ' "serial":"23A:001"' + #13 + #10 + 67 | '}' + #13 + #10; 68 | 69 | BEGIN 70 | WriteLn(ujson.Parse(t, @mycb, NIL)); 71 | WriteLn(ujson.Parse(' [ 1, 2, 3, 4, 5, "Hello world!" ]'+#10, @mycb, NIL)); 72 | END. 73 | ---------------------------------------------------------------------- 74 | Must produce output: 75 | 76 | pb.p=75 77 | pb.i=0.5 78 | pb.d=30 79 | pb.iMin=-50 80 | pb.iMax=50 81 | pe.p=0.9 82 | pe.i=0.001 83 | pe.d=2.12 84 | pe.iMin=0 85 | pe.iMax=0 86 | p1.p2.p3=12345 87 | p1.p2.p4.0=1 88 | p1.p2.p4.1=2 89 | p1.p2.p4.2=3 90 | p1.p2.p4.3=4 91 | p1.p2.p4.4=5 92 | p1.p2.p4.size=5 93 | bt=24.5 94 | et=4.8 95 | serial=23A:001 96 | TRUE 97 | 0=1 98 | 1=2 99 | 2=3 100 | 3=4 101 | 4=5 102 | 5=Hello world! 103 | size=6 104 | TRUE 105 | ---------------------------------------------------------------------- 106 | *) 107 | 108 | TYPE UJSON_CALL_BACK = FUNCTION(key, val : STRING; ctx : POINTER) : BOOLEAN; 109 | 110 | FUNCTION Parse(p : PCHAR; cb : UJSON_CALL_BACK; ctx : POINTER) : BOOLEAN; 111 | 112 | IMPLEMENTATION 113 | 114 | CONST 115 | OBJ_START = '{'; 116 | OBJ_END = '}'; 117 | ARR_START = '['; 118 | ARR_END = ']'; 119 | 120 | FUNCTION SkipSpaces(VAR p : PCHAR) : CHAR; BEGIN WHILE (p^ <> #0) AND (p^ <= ' ') DO INC(p); SkipSpaces := p^; END; 121 | 122 | FUNCTION IsChr(VAR p : PCHAR; c : CHAR) : BOOLEAN; 123 | BEGIN 124 | IF p^ = c THEN BEGIN INC(p); IsChr := TRUE; END ELSE IsChr := FALSE; 125 | END; 126 | 127 | FUNCTION ParseSimpleValue(VAR p : PCHAR) : STRING; 128 | VAR 129 | r : STRING; 130 | c : CHAR; 131 | BEGIN 132 | r := ''; 133 | IF IsChr(p, '"') THEN BEGIN 134 | WHILE NOT (p^ IN [#0, '"']) DO BEGIN 135 | IF IsChr(p, '\') THEN BEGIN 136 | c := p^; 137 | CASE c OF 138 | '0': c := #0; 139 | 't': c := #9; 140 | 'r': c := #13; 141 | 'n': c := #10; 142 | END; 143 | r := r + c; 144 | END ELSE BEGIN 145 | r := r + p^; 146 | END; 147 | INC(p); 148 | END; 149 | IsChr(p, '"'); 150 | END ELSE WHILE (p^ > ' ') AND (NOT (p^ IN [#0, ',', ARR_END, OBJ_END, ':'])) DO BEGIN 151 | r := r + p^; 152 | INC(p); 153 | END; 154 | SkipSpaces(p); 155 | ParseSimpleValue := r; 156 | END; 157 | 158 | FUNCTION ParseObject(VAR p : PCHAR; prefix : STRING; cb : UJSON_CALL_BACK; ctx : POINTER; endchr : CHAR) : BOOLEAN; 159 | VAR ckey : STRING; 160 | cval : STRING; 161 | r : BOOLEAN; 162 | i : LONGINT; 163 | BEGIN 164 | r := TRUE; 165 | i := 0; 166 | WHILE (NOT (SkipSpaces(p) IN [#0, OBJ_END, ARR_END])) AND r DO BEGIN 167 | IF endchr = ARR_END THEN BEGIN 168 | Str(i, ckey); 169 | INC(i); 170 | END ELSE BEGIN 171 | ckey := ParseSimpleValue(p); 172 | IF NOT IsChr(p, ':') THEN BEGIN r := FALSE; BREAK; END; 173 | SkipSpaces(p); 174 | END; 175 | IF IsChr(p, OBJ_START) THEN r := ParseObject(p, prefix + ckey + '.', cb, ctx, OBJ_END) 176 | ELSE IF IsChr(p, ARR_START) THEN r := ParseObject(p, prefix + ckey + '.', cb, ctx, ARR_END) 177 | ELSE BEGIN 178 | cval := ParseSimpleValue(p); 179 | r := cb(prefix + ckey, cval, ctx); 180 | END; 181 | IF NOT r THEN BREAK; 182 | IF NOT IsChr(p, ',') THEN BREAK; 183 | END; 184 | IF r THEN r := IsChr(p, endchr); 185 | IF r AND (endchr = ARR_END) THEN BEGIN 186 | Str(i, ckey); 187 | r := cb(prefix + 'size', ckey, ctx); 188 | END; 189 | SkipSpaces(p); 190 | ParseObject := r; 191 | END; 192 | 193 | FUNCTION Parse(p : PCHAR; cb : UJSON_CALL_BACK; ctx : POINTER) : BOOLEAN; 194 | BEGIN 195 | SkipSpaces(p); 196 | IF IsChr(p, OBJ_START) THEN Parse := ParseObject(p, '', cb, ctx, OBJ_END) 197 | ELSE IF IsChr(p, ARR_START) THEN Parse := ParseObject(p, '', cb, ctx, ARR_END) 198 | ELSE Parse := FALSE; 199 | END; 200 | 201 | END. 202 | -------------------------------------------------------------------------------- /UPPP.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2025 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | { Predictor Compression Protocol 23 | https://www.ietf.org/rfc/rfc1978.txt 24 | 25 | Predictor is a high speed compression algorithm, available without 26 | license fees. The compression ratio obtained using predictor is not 27 | as good as other compression algorithms, but it remains one of the 28 | fastest algorithms available. } 29 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 30 | UNIT UPPP; 31 | 32 | INTERFACE 33 | 34 | CONST 35 | PPP_BITS = 12; 36 | PPP_HASH_TABLE = 1 SHL PPP_BITS; 37 | PPP_HASH_TABLE_SIZE = PPP_HASH_TABLE - 1; 38 | 39 | TYPE 40 | PPP_HASH_TYPE = WORD; 41 | PPP_TABLE = ARRAY [0..PPP_HASH_TABLE_SIZE] OF CHAR; 42 | 43 | PROCEDURE Init(VAR GuessTable: PPP_TABLE; VAR Hash: PPP_HASH_TYPE); 44 | 45 | FUNCTION Compress(Source, Dest: PCHAR; Len: INTEGER; VAR GuessTable: PPP_TABLE; VAR Hash: PPP_HASH_TYPE): INTEGER; 46 | FUNCTION Decompress(Source, Dest: PCHAR; VAR Len: INTEGER; Final: BOOLEAN; VAR GuessTable: PPP_TABLE; VAR Hash: WORD): INTEGER; 47 | 48 | PROCEDURE CompressFile(src_name, dst_name : STRING); 49 | PROCEDURE DecompressFile(src_name, dst_name : STRING); 50 | 51 | IMPLEMENTATION 52 | 53 | USES SYSTEM2; 54 | 55 | CONST 56 | SIZ1 = 2048; 57 | 58 | FUNCTION HashCode(Hash : WORD; x : BYTE) : PPP_HASH_TYPE; 59 | BEGIN 60 | HashCode := ((Hash * 160) XOR (ORD(x))) AND PPP_HASH_TABLE_SIZE; 61 | END; 62 | 63 | PROCEDURE Init(VAR GuessTable: PPP_TABLE; VAR Hash: PPP_HASH_TYPE); 64 | BEGIN 65 | Hash := 0; 66 | FillChar(GuessTable, SizeOf(PPP_TABLE), #0); 67 | END; 68 | 69 | FUNCTION Compress(Source, Dest: PCHAR; Len: INTEGER; VAR GuessTable: PPP_TABLE; VAR Hash: PPP_HASH_TYPE): INTEGER; 70 | VAR 71 | I, BitMask : INTEGER; 72 | FlagDest, OrgDest : PCHAR; 73 | Flags : BYTE; 74 | BEGIN 75 | OrgDest := Dest; 76 | WHILE Len > 0 DO BEGIN 77 | FlagDest := Dest; 78 | INC(Dest); 79 | Flags := 0; 80 | BitMask := 1; 81 | I := 0; 82 | WHILE i <= 7 DO BEGIN 83 | IF Len = 0 THEN BREAK; 84 | IF GuessTable[Hash] = Source^ THEN Flags := Flags OR BitMask 85 | ELSE BEGIN 86 | GuessTable[Hash] := Source^; 87 | Dest^ := Source^; 88 | INC(Dest); 89 | END; 90 | Hash := HashCode(Hash, BYTE(Source^)); 91 | INC(Source); 92 | BitMask := BitMask SHL 1; 93 | DEC(Len); 94 | INC(I); 95 | END; 96 | FlagDest^ := CHR(Flags); 97 | END; 98 | Compress := Dest - OrgDest; 99 | END; 100 | 101 | FUNCTION Decompress(Source, Dest: PCHAR; VAR Len: INTEGER; Final: BOOLEAN; 102 | VAR GuessTable: PPP_TABLE; VAR Hash: PPP_HASH_TYPE): INTEGER; 103 | VAR 104 | I, BitMask : INTEGER; 105 | Flags : BYTE; 106 | OrgDest : PCHAR; 107 | BEGIN 108 | OrgDest := Dest; 109 | WHILE Len >= 9 DO BEGIN 110 | Flags := BYTE(Source^); 111 | INC(Source); 112 | BitMask := 1; 113 | I := 0; 114 | WHILE i <= 7 DO BEGIN 115 | IF (Flags AND BitMask) <> 0 THEN Dest^ := GuessTable[Hash] 116 | ELSE BEGIN 117 | GuessTable[Hash] := Source^; 118 | Dest^ := Source^; 119 | INC(Source); 120 | DEC(Len); 121 | END; 122 | Hash := HashCode(Hash, BYTE(Dest^)); 123 | INC(Dest); 124 | BitMask := BitMask SHL 1; 125 | INC(i); 126 | END; 127 | DEC(Len); 128 | END; 129 | WHILE Final AND (Len > 0) DO BEGIN 130 | Flags := BYTE(Source^); 131 | INC(Source); 132 | DEC(Len); 133 | BitMask := 1; 134 | FOR I := 0 TO 7 DO BEGIN 135 | IF (Flags AND BitMask) <> 0 THEN Dest^ := GuessTable[Hash] 136 | ELSE BEGIN 137 | IF Len = 0 THEN BREAK; 138 | GuessTable[Hash] := Source^; 139 | Dest^ := Source^; 140 | INC(Source); 141 | DEC(Len); 142 | END; 143 | Hash := HashCode(Hash, BYTE(Dest^)); 144 | INC(Dest); 145 | BitMask := BitMask SHL 1; 146 | END; 147 | END; 148 | Decompress := Dest - OrgDest; 149 | END; 150 | 151 | PROCEDURE CompressFile(src_name, dst_name : STRING); 152 | CONST 153 | OUTBUFSIZE = (SIZ1 DIV 8 * 9) + 9; 154 | VAR 155 | BufP: ARRAY[0..SIZ1-1] OF CHAR; 156 | BufC: ARRAY[0..OUTBUFSIZE] OF CHAR; 157 | GuessTable: PPP_TABLE; 158 | Hash: PPP_HASH_TYPE; 159 | Len1, Len2: INTEGER; 160 | INF, OUTF : BFILE; 161 | BEGIN 162 | Init(GuessTable, Hash); 163 | Assign(INF, src_name); 164 | Reset(INF); 165 | Assign(OUTF, dst_name); 166 | ReWrite(OUTF); 167 | WHILE NOT EOF(INF) DO BEGIN 168 | Len1 := BlockRead(INF, BufP, SIZ1); 169 | Len2 := Compress(@BufP, @BufC, Len1, GuessTable, Hash); 170 | BlockWrite(OUTF, BufC, Len2); 171 | END; 172 | Close(INF); 173 | Close(OUTF); 174 | END; 175 | 176 | PROCEDURE DecompressFile(src_name, dst_name : STRING); 177 | CONST 178 | OUTBUFSIZE = SIZ1*9+9; 179 | VAR 180 | BufP: ARRAY[0..SIZ1+9] OF CHAR; 181 | BufC: ARRAY[0..OUTBUFSIZE] OF CHAR; 182 | GuessTable: PPP_TABLE; 183 | Hash: PPP_HASH_TYPE; 184 | Len1, Len2, Len3: INTEGER; 185 | INF, OUTF : BFILE; 186 | BEGIN 187 | Len1 := 0; 188 | Init(GuessTable, Hash); 189 | Assign(INF, src_name); 190 | Reset(INF); 191 | Assign(OUTF, dst_name); 192 | ReWrite(OUTF); 193 | WHILE NOT EOF(INF) DO BEGIN 194 | Len3 := BlockRead(INF, BufP[Len1], SIZ1); 195 | INC(Len1, Len3); 196 | Len3 := Len1; 197 | Len2 := Decompress(@BufP, @BufC, Len1, FALSE, GuessTable, Hash); 198 | BlockWrite(OUTF, BufC, Len2); 199 | Move(BufP[Len3 - Len1], BufP, Len1); 200 | END; 201 | Len2 := Decompress(@BufP, @BufC, Len1, TRUE, GuessTable, Hash); 202 | BlockWrite(OUTF, BufC, Len2); 203 | Close(INF); 204 | Close(OUTF); 205 | END; 206 | 207 | END. 208 | -------------------------------------------------------------------------------- /UTAR.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2024 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT UTAR; 24 | 25 | INTERFACE 26 | 27 | (* Read/Write .tar file. 28 | 29 | File read example: 30 | 31 | VAR f : TAR_FILE; fname : STRING; fsize : LONGINT; 32 | BEGIN 33 | Assign(f, 'hello.tar'); 34 | Reset(f, 1); 35 | WHILE utar.Find(f, fname, fsize) DO BEGIN 36 | WriteLn(fname, ' ', fsize); 37 | Seek(f, FilePos(f) + fsize); 38 | END; 39 | Close(f); 40 | END; 41 | 42 | File write example: 43 | 44 | VAR f : TAR_FILE; str : STRING; 45 | BEGIN 46 | Assign(f, 'hello.tar'); 47 | ReWrite(f, 1); 48 | 49 | { hello.txt } 50 | str := 'Hello, world!'; 51 | utar.Add(f, 'hello.txt', Length(str)); 52 | BlockWrite(f, str[1], Length(str)); 53 | 54 | { another.txt } 55 | str := 'Hello, another world!'; 56 | utar.Add(f, 'another.txt', Length(str)); 57 | BlockWrite(f, str[1], Length(str)); 58 | 59 | { close file } 60 | utar.Finish(f); 61 | Close(f); 62 | END; *) 63 | 64 | TYPE TAR_FILE = FILE; 65 | (* Find next file. Before call: file position at header start. After, - at begin of content *) 66 | FUNCTION Find(VAR f : TAR_FILE; VAR filename : STRING; VAR filesize : LONGINT) : BOOLEAN; 67 | (* Add one more header for file. After it, you can write content *) 68 | PROCEDURE Add(VAR f : TAR_FILE; filename : STRING; filesize : LONGINT); 69 | (* Finallize, need before close .tar file*) 70 | PROCEDURE Finish(VAR f : TAR_FILE); 71 | 72 | IMPLEMENTATION 73 | 74 | CONST 75 | TAR_BLOCKSIZE = 512; 76 | TAR_OWNER = 'root'; 77 | TAR_USTAR = 'ustar '; 78 | TAR_FILEMODE = '0000640'; 79 | TAR_UGID = '0000000'; 80 | TAR_DATETIME = '00000000000'; 81 | 82 | TYPE 83 | TAR_BLOCK = ARRAY[1..TAR_BLOCKSIZE] OF CHAR; 84 | 85 | (* ----------------------------------------------------------------------------------- *) 86 | 87 | PROCEDURE WriteAlignment(VAR f : TAR_FILE); 88 | VAR buf : TAR_BLOCK; 89 | p : INTEGER; 90 | BEGIN 91 | p := FilePos(f) MOD TAR_BLOCKSIZE; 92 | IF p <> 0 THEN BEGIN 93 | FillChar(buf, TAR_BLOCKSIZE, #0); 94 | BlockWrite(f, buf, TAR_BLOCKSIZE - p); 95 | END; 96 | END; 97 | 98 | FUNCTION Int2Oct(i : LONGINT) : STRING; 99 | VAR r : STRING; 100 | c : CHAR; 101 | BEGIN 102 | c := CHR((i mod 8) + ORD('0')); 103 | i := i DIV 8; 104 | IF i <> 0 THEN r := Int2Oct(i) ELSE r := ''; 105 | Int2Oct := r + c; 106 | END; 107 | 108 | PROCEDURE SetStrMem(VAR buf : TAR_BLOCK; ofs : INTEGER; s : STRING); 109 | BEGIN 110 | Move(s[1], buf[ofs], Length(s)); 111 | END; 112 | 113 | FUNCTION GetStrMem(VAR buf : TAR_BLOCK; ofs, len : INTEGER) : STRING; 114 | VAR s : STRING; 115 | BEGIN 116 | s := ''; 117 | WHILE (len > 0) AND (buf[ofs] <> #0) DO BEGIN 118 | s := s + buf[ofs]; 119 | INC(ofs); 120 | DEC(len); 121 | END; 122 | GetStrMem := s; 123 | END; 124 | 125 | FUNCTION lpad(s : STRING; len : INTEGER) : STRING; 126 | BEGIN 127 | WHILE Length(s) < len DO s := '0' + s; 128 | lpad := s; 129 | END; 130 | 131 | FUNCTION CheckSum(VAR buf : TAR_BLOCK) : INTEGER; 132 | VAR r : INTEGER; 133 | i : INTEGER; 134 | BEGIN 135 | r := 0; 136 | FOR i := 1 TO TAR_BLOCKSIZE DO INC(r, ORD(buf[i])); 137 | CheckSum := r; 138 | END; 139 | 140 | (* ----------------------------------------------------------------------------------- *) 141 | 142 | FUNCTION Find(VAR f : TAR_FILE; VAR filename : STRING; VAR filesize : LONGINT) : BOOLEAN; 143 | VAR r : BOOLEAN; 144 | buf : TAR_BLOCK; 145 | str : STRING; 146 | i : INTEGER; 147 | p : LONGINT; 148 | BEGIN 149 | r := FALSE; 150 | p := FilePos(f); 151 | i := p MOD TAR_BLOCKSIZE; 152 | IF i <> 0 THEN Seek(f, p + (TAR_BLOCKSIZE - i)); 153 | BlockRead(f, buf, TAR_BLOCKSIZE); 154 | IF GetStrMem(buf, 258, 7) = TAR_USTAR THEN BEGIN 155 | filename := GetStrMem(buf, 1, 100); 156 | str := GetStrMem(buf, 125, 12); 157 | filesize := 0; 158 | i := 1; 159 | WHILE (i <= Length(str)) AND (str[i] IN ['0'..'7']) DO BEGIN 160 | filesize := filesize * 8; 161 | INC(filesize, ORD(str[i]) - ORD('0')); 162 | INC(i); 163 | END; 164 | r := TRUE; 165 | END ELSE Seek(f, p); 166 | Find := r; 167 | END; 168 | 169 | PROCEDURE Add(VAR f : TAR_FILE; filename : STRING; filesize : LONGINT); 170 | VAR buf : TAR_BLOCK; 171 | BEGIN 172 | FillChar(buf, TAR_BLOCKSIZE, #0); 173 | 174 | SetStrMem(buf, 1, filename); 175 | SetStrMem(buf, 125, lpad(Int2Oct(filesize), 11)); 176 | SetStrMem(buf, 101, TAR_FILEMODE); 177 | SetStrMem(buf, 109, TAR_UGID); 178 | SetStrMem(buf, 117, TAR_UGID); 179 | SetStrMem(buf, 137, TAR_DATETIME); 180 | SetStrMem(buf, 258, TAR_USTAR); 181 | SetStrMem(buf, 266, TAR_OWNER); 182 | SetStrMem(buf, 298, TAR_OWNER); 183 | FillChar(buf[149], 8, ' '); 184 | SetStrMem(buf, 149, lpad(Int2Oct(CheckSum(buf)), 8)); 185 | 186 | WriteAlignment(f); 187 | BlockWrite(f, buf, TAR_BLOCKSIZE); 188 | END; 189 | 190 | PROCEDURE Finish(VAR f : TAR_FILE); 191 | VAR buf : TAR_BLOCK; 192 | BEGIN 193 | FillChar(buf, TAR_BLOCKSIZE, #0); 194 | 195 | WriteAlignment(f); 196 | BlockWrite(f, buf, TAR_BLOCKSIZE); 197 | BlockWrite(f, buf, TAR_BLOCKSIZE); 198 | END; 199 | 200 | END. 201 | -------------------------------------------------------------------------------- /WINCB.PAS: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | } 23 | UNIT WinCB; 24 | { ========================================================================= 25 | 26 | Windows Clipboard support for MS-DOS applications. 27 | 28 | ========================================================================= } 29 | 30 | INTERFACE 31 | 32 | FUNCTION WCB_Detect : BOOLEAN; 33 | 34 | FUNCTION WCB_Copy(VAR d; size : WORD) : BOOLEAN; 35 | FUNCTION WCB_Paste(VAR d; max_size : WORD) : BOOLEAN; 36 | 37 | IMPLEMENTATION 38 | 39 | FUNCTION WCB_Detect : BOOLEAN;ASSEMBLER; 40 | ASM 41 | MOV AX, $1700 42 | INT $2F 43 | XOR BX, BX 44 | CMP AX, $1700 45 | JE @end 46 | INC BX 47 | @end: 48 | MOV AX, BX 49 | END; 50 | 51 | FUNCTION WCB_Clear : BOOLEAN;ASSEMBLER; 52 | ASM 53 | MOV AX, $1702 54 | INT $2F 55 | XOR BX, BX 56 | OR AX, AX 57 | JZ @end 58 | INC BX 59 | @end: 60 | MOV AX, BX 61 | END; 62 | 63 | FUNCTION WCB_Open : BOOLEAN;ASSEMBLER; 64 | ASM 65 | MOV AX, $1701 66 | INT $2F 67 | XOR BX, BX 68 | OR AX, AX 69 | JZ @end 70 | INC BX 71 | @end: 72 | MOV AX, BX 73 | END; 74 | 75 | PROCEDURE WCB_Close;ASSEMBLER; 76 | ASM 77 | MOV AX, $1708 78 | INT $2F 79 | END; 80 | 81 | FUNCTION WCB_SetData(VAR d; size : WORD) : BOOLEAN;ASSEMBLER; 82 | ASM 83 | PUSH ES 84 | LES BX, d 85 | MOV CX, size 86 | XOR SI,SI 87 | MOV AX, $1703 88 | MOV DX, 1 89 | INT $2F 90 | POP ES 91 | XOR BX, BX 92 | OR AX, AX 93 | JZ @end 94 | INC BX 95 | @end: 96 | MOV BX, AX 97 | END; 98 | 99 | FUNCTION WCB_GetData(VAR d) : BOOLEAN;ASSEMBLER; 100 | ASM 101 | PUSH ES 102 | LES BX, d 103 | MOV DX, 1 104 | MOV AX, $1705 105 | INT $2F 106 | POP ES 107 | XOR BX, BX 108 | OR AX, AX 109 | JZ @end 110 | INC BX 111 | @end: 112 | MOV AX, BX 113 | END; 114 | 115 | FUNCTION WCB_GetDataSize : LONGINT;ASSEMBLER; 116 | ASM 117 | MOV AX, $1704 118 | MOV DX, 1 119 | INT $2F 120 | END; 121 | 122 | FUNCTION WCB_Copy(VAR d; size : WORD) : BOOLEAN; 123 | VAR r : BOOLEAN; 124 | BEGIN 125 | r := FALSE; 126 | IF WCB_Detect THEN 127 | IF WCB_Open THEN 128 | IF WCB_Clear THEN BEGIN 129 | r := WCB_SetData(d, (size AND $FFE0) OR $1F); 130 | WCB_Close; 131 | END; 132 | WCB_Copy := r; 133 | END; 134 | 135 | FUNCTION WCB_Paste(VAR d; max_size : WORD) : BOOLEAN; 136 | VAR r : BOOLEAN; 137 | size : LONGINT; 138 | p : PCHAR; 139 | BEGIN 140 | r := FALSE; 141 | IF WCB_Detect THEN 142 | IF WCB_Open THEN BEGIN 143 | size := WCB_GetDataSize; 144 | IF (size - 1) < max_size THEN BEGIN 145 | r := WCB_GetData(d); 146 | IF r THEN BEGIN 147 | p := @d; 148 | p[size] := #0; 149 | END; 150 | END; 151 | WCB_Close; 152 | END; 153 | WCB_Paste := r; 154 | END; 155 | 156 | END. -------------------------------------------------------------------------------- /dynarr.pas: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT DynArr; 24 | 25 | INTERFACE 26 | 27 | USES memframe; 28 | 29 | TYPE 30 | DYNARR_FILE = FILE; 31 | 32 | PArray = ^TArray; 33 | TArray = RECORD 34 | Data : POINTER; 35 | Size : WORD; 36 | Capacity : WORD; 37 | ElementSize : WORD; 38 | MemFrame : PMemFrame; 39 | END; 40 | 41 | PROCEDURE Init(VAR Arr : TArray; ElementSize : WORD; MemFrame : PMemFrame); 42 | PROCEDURE Reset(VAR Arr : TArray); 43 | PROCEDURE Free(VAR Arr : TArray); 44 | 45 | PROCEDURE SetLength(VAR Arr : TArray; NewLength : WORD); 46 | FUNCTION GetLength(VAR Arr : TArray) : WORD; 47 | PROCEDURE Delete(VAR Arr : TArray; StartIndex, Count: WORD); 48 | 49 | PROCEDURE Clear(VAR Arr : TArray; StartIndex, Count: WORD); 50 | PROCEDURE Insert(VAR Arr : TArray; Index: WORD; VAR Element); 51 | PROCEDURE Add(VAR Arr : TArray; VAR Element); 52 | PROCEDURE Get(VAR Arr : TArray; Index : WORD; VAR Element); 53 | FUNCTION GetPtr(VAR Arr : TArray; Index : WORD) : POINTER; 54 | PROCEDURE Put(VAR Arr : TArray; Index : WORD; VAR Element); 55 | PROCEDURE Swap(VAR Arr : TArray; Index1, Index2 : WORD); 56 | 57 | PROCEDURE Copy(VAR SourceArr, DestArr : TArray); 58 | PROCEDURE InsertAll(VAR SourceArr : TArray; SourceStartIndex, Count: WORD; VAR DestArr : TArray; DestStartIndex : WORD); 59 | 60 | IMPLEMENTATION 61 | 62 | CONST 63 | ALLOC_STEP = 16; 64 | MAGIC = $4411; 65 | 66 | PROCEDURE Init(VAR Arr : TArray; ElementSize : WORD; MemFrame : PMemFrame); 67 | BEGIN 68 | FillChar(Arr, SizeOf(TArray), #0); 69 | Arr.ElementSize := ElementSize; 70 | Arr.MemFrame := MemFrame; 71 | END; 72 | 73 | PROCEDURE Free(VAR Arr : TArray); 74 | BEGIN 75 | IF Arr.MemFrame <> NIL THEN EXIT; 76 | IF Arr.Data <> NIL THEN FreeMem(Arr.Data, Arr.Capacity * Arr.ElementSize); 77 | Arr.Data := nil; 78 | Arr.Size := 0; 79 | Arr.Capacity := 0; 80 | END; 81 | 82 | PROCEDURE Reset(VAR Arr : TArray); 83 | BEGIN 84 | Arr.Size := 0; 85 | END; 86 | 87 | PROCEDURE Clear(VAR Arr : TArray; StartIndex, Count: WORD); 88 | BEGIN 89 | IF (StartIndex >= Arr.Size) OR (Count = 0) THEN EXIT; 90 | IF (StartIndex + Count > Arr.Size) THEN Count := Arr.Size - StartIndex; 91 | FillChar((PCHAR(Arr.Data) + StartIndex * Arr.ElementSize)^ 92 | , Count * Arr.ElementSize 93 | , #0); 94 | END; 95 | 96 | PROCEDURE ChangeCapacity(VAR Arr : TArray; NewCapacity : WORD); 97 | VAR NewData : PCHAR; 98 | BEGIN 99 | IF NewCapacity = 0 THEN Reset(Arr) 100 | ELSE BEGIN 101 | IF Arr.MemFrame = NIL THEN GetMem(NewData, NewCapacity * Arr.ElementSize) 102 | ELSE NewData := Alloc(Arr.MemFrame^, NewCapacity * Arr.ElementSize); 103 | IF NewData <> NIL THEN BEGIN 104 | IF Arr.Data <> nil THEN BEGIN 105 | Move(PCHAR(Arr.Data)^, NewData^, Arr.Size * Arr.ElementSize); 106 | IF NewCapacity > Arr.Size THEN 107 | FillChar(NewData[Arr.Size * Arr.ElementSize] 108 | , (NewCapacity - Arr.Size) * Arr.ElementSize 109 | , #0); 110 | IF Arr.MemFrame = NIL THEN FreeMem(Arr.Data, Arr.Capacity * Arr.ElementSize); 111 | END; 112 | Arr.Data := NewData; 113 | Arr.Capacity := NewCapacity; 114 | END; 115 | END; 116 | END; 117 | 118 | PROCEDURE Add(VAR Arr : TArray; VAR Element); 119 | BEGIN 120 | IF Arr.Size = Arr.Capacity THEN ChangeCapacity(Arr, Arr.Capacity + ALLOC_STEP); 121 | Move(Element 122 | , (PCHAR(Arr.Data) + Arr.Size * Arr.ElementSize)^ 123 | , Arr.ElementSize); 124 | INC(Arr.Size); 125 | END; 126 | 127 | PROCEDURE Delete(VAR Arr : TArray; StartIndex, Count: WORD); 128 | BEGIN 129 | IF (StartIndex >= Arr.Size) OR (Count = 0) THEN EXIT; 130 | IF (StartIndex + Count > Arr.Size) THEN Count := Arr.Size - StartIndex; 131 | IF StartIndex + Count < Arr.Size THEN 132 | Move((PCHAR(Arr.Data) + (StartIndex + Count) * Arr.ElementSize)^ 133 | , (PCHAR(Arr.Data) + StartIndex * Arr.ElementSize)^ 134 | , (Arr.Size - StartIndex - Count) * Arr.ElementSize); 135 | DEC(Arr.Size, Count); 136 | IF Arr.Size + ALLOC_STEP < Arr.Capacity - ALLOC_STEP * 2 THEN 137 | ChangeCapacity(Arr, Arr.Size + ALLOC_STEP); 138 | END; 139 | 140 | PROCEDURE Get(VAR Arr : TArray; Index : WORD; VAR Element); 141 | BEGIN 142 | IF Index >= Arr.Size THEN EXIT; 143 | Move((PCHAR(Arr.Data) + Index * Arr.ElementSize)^ 144 | , Element 145 | , Arr.ElementSize); 146 | END; 147 | 148 | FUNCTION GetPtr(VAR Arr : TArray; Index : WORD) : POINTER; 149 | BEGIN 150 | IF Index < Arr.Size THEN GetPtr := PCHAR(Arr.Data) + Index * Arr.ElementSize 151 | ELSE GetPtr := NIL; 152 | END; 153 | 154 | PROCEDURE Put(VAR Arr : TArray; Index : WORD; VAR Element); 155 | BEGIN 156 | IF Index >= Arr.Size THEN EXIT; 157 | Move(Element 158 | , (PCHAR(Arr.Data) + Index * Arr.ElementSize)^ 159 | , Arr.ElementSize); 160 | END; 161 | 162 | FUNCTION GetLength(VAR Arr : TArray) : WORD; 163 | BEGIN 164 | GetLength := Arr.Size; 165 | END; 166 | 167 | PROCEDURE SetLength(VAR Arr : TArray; NewLength : WORD); 168 | BEGIN 169 | IF Arr.Capacity < NewLength THEN ChangeCapacity(Arr, NewLength + ALLOC_STEP) 170 | ELSE IF Arr.Capacity > NewLength + ALLOC_STEP THEN ChangeCapacity(Arr, NewLength); 171 | Arr.Size := NewLength; 172 | END; 173 | 174 | PROCEDURE Copy(VAR SourceArr, DestArr : TArray); 175 | BEGIN 176 | DestArr.ElementSize := SourceArr.ElementSize; 177 | SetLength(DestArr, SourceArr.Size); 178 | Move(PCHAR(SourceArr.Data)^ 179 | , PCHAR(DestArr.Data)^ 180 | , SourceArr.Size * SourceArr.ElementSize); 181 | END; 182 | 183 | PROCEDURE InsertAll(VAR SourceArr : TArray; SourceStartIndex, Count: WORD; VAR DestArr : TArray; DestStartIndex : WORD); 184 | VAR MoveCount: WORD; 185 | BEGIN 186 | IF (SourceStartIndex + Count > SourceArr.Size) OR (Count = 0) THEN EXIT; 187 | IF DestStartIndex > DestArr.Size THEN EXIT; 188 | IF SourceArr.ElementSize <> DestArr.ElementSize THEN EXIT; 189 | 190 | MoveCount := DestArr.Size - DestStartIndex; 191 | SetLength(DestArr, DestArr.Size + Count); 192 | 193 | IF MoveCount > 0 THEN 194 | Move(PCHAR(DestArr.Data)[DestStartIndex * DestArr.ElementSize] 195 | , PCHAR(DestArr.Data)[(DestStartIndex + Count)* DestArr.ElementSize] 196 | , MoveCount * DestArr.ElementSize); 197 | 198 | Move(PCHAR(SourceArr.Data)[SourceStartIndex * SourceArr.ElementSize] 199 | , PCHAR(DestArr.Data)[DestStartIndex * DestArr.ElementSize] 200 | , Count * SourceArr.ElementSize); 201 | INC(DestArr.Size, Count); 202 | END; 203 | 204 | PROCEDURE Insert(VAR Arr : TArray; Index: WORD; VAR Element); 205 | BEGIN 206 | IF Index > Arr.Size THEN EXIT; 207 | IF Arr.Size = Arr.Capacity THEN SetLength(Arr, Arr.Capacity + ALLOC_STEP); 208 | 209 | IF Index < Arr.Size THEN 210 | Move(PCHAR(Arr.Data)[Index * Arr.ElementSize] 211 | , PCHAR(Arr.Data)[(Index + 1) * Arr.ElementSize] 212 | , (Arr.Size - Index) * Arr.ElementSize); 213 | 214 | Move(Element, PCHAR(Arr.Data)[Index * Arr.ElementSize], Arr.ElementSize); 215 | INC(Arr.Size); 216 | END; 217 | 218 | PROCEDURE Swap(VAR Arr : TArray; Index1, Index2 : WORD); 219 | VAR Allocated : BOOLEAN; 220 | TempBuffer : PCHAR; 221 | a1, a2 : PCHAR; 222 | BEGIN 223 | IF (Index1 >= Arr.Size) OR (Index2 >= Arr.Size) THEN EXIT; 224 | 225 | Allocated := Arr.Capacity = Arr.Size; 226 | IF Allocated THEN GetMem(TempBuffer, Arr.ElementSize) 227 | ELSE TempBuffer := PCHAR(Arr.Data) + Arr.Size * Arr.ElementSize; 228 | 229 | a1 := PCHAR(Arr.Data) + Index1 * Arr.ElementSize; 230 | a2 := PCHAR(Arr.Data) + Index2 * Arr.ElementSize; 231 | 232 | Move(a1^, TempBuffer^, Arr.ElementSize); 233 | Move(a2^, a1^, Arr.ElementSize); 234 | Move(TempBuffer^, a2^, Arr.ElementSize); 235 | 236 | IF Allocated THEN FreeMem(TempBuffer, Arr.ElementSize) ELSE FillChar(TempBuffer^, Arr.ElementSize, #0); 237 | END; 238 | 239 | END. 240 | 241 | -------------------------------------------------------------------------------- /dynstr.pas: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2025 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT dynstr; 24 | 25 | INTERFACE 26 | 27 | USES memframe; 28 | 29 | TYPE 30 | PString = ^TString; 31 | TString = RECORD 32 | Len : WORD; 33 | Capacity : WORD; 34 | Frame : PMemFrame; 35 | Data : PCHAR; 36 | END; 37 | 38 | PROCEDURE InitStr(VAR S: TString; Frame : PMemFrame; InitialCapacity: WORD); 39 | PROCEDURE AppendStr(VAR S: TString; Str: PCHAR); 40 | PROCEDURE InsertStr(VAR S: TString; Str: PCHAR; Position: WORD); 41 | PROCEDURE ClearStr(VAR S: TString); 42 | PROCEDURE FreeStr(VAR S: TString); 43 | PROCEDURE DeleteSubStr(VAR S: TString; BeginIdx, len: WORD); 44 | PROCEDURE Substring(VAR S: TString; BeginIdx, len: WORD; VAR SubStr: TString); 45 | FUNCTION CompareStr(S1, S2: TString): INTEGER; 46 | 47 | IMPLEMENTATION 48 | 49 | USES cstring; 50 | 51 | PROCEDURE InitStr(VAR S: TString; Frame : PMemFrame; InitialCapacity: WORD); 52 | BEGIN 53 | IF InitialCapacity = 0 THEN InitialCapacity := 16; 54 | S.Len := 0; 55 | S.Capacity := InitialCapacity; 56 | S.Frame := Frame; 57 | GetMem(S.Data, S.Capacity); 58 | S.Data[0] := #0; 59 | END; 60 | 61 | PROCEDURE ResizeString(VAR S: TString; NewCapacity: WORD); 62 | VAR NewData: PCHAR; 63 | BEGIN 64 | IF S.Frame = NIL THEN GetMem(NewData, NewCapacity) 65 | ELSE NewData := Alloc(S.Frame^, NewCapacity); 66 | 67 | Move(S.Data^, NewData^, S.Len + 1); 68 | IF S.Frame = NIL THEN FreeMem(S.Data, S.Capacity); 69 | S.Data := NewData; 70 | S.Capacity := NewCapacity; 71 | END; 72 | 73 | PROCEDURE AppendStr(VAR S: TString; Str: PCHAR); 74 | VAR NewLen: WORD; 75 | BEGIN 76 | NewLen := S.Len + StrLen(Str); 77 | IF NewLen + 1 > S.Capacity THEN ResizeString(S, NewLen + 32); 78 | StrCat(S.Data, Str); 79 | S.Len := NewLen; 80 | END; 81 | 82 | PROCEDURE InsertStr(VAR S: TString; Str: PCHAR; Position: WORD); 83 | VAR InsertLen, NewLen: WORD; 84 | BEGIN 85 | IF Position > S.Len THEN EXIT; 86 | 87 | InsertLen := StrLen(Str); 88 | NewLen := S.Len + InsertLen; 89 | IF NewLen > S.Capacity THEN ResizeString(S, NewLen * 2); 90 | Move(S.Data[Position], S.Data[Position + InsertLen], S.Len - Position + 1); 91 | Move(Str^, S.Data[Position], InsertLen); 92 | S.Len := NewLen; 93 | END; 94 | 95 | PROCEDURE ClearStr(VAR S: TString); 96 | BEGIN 97 | S.Len := 0; 98 | IF S.Data <> nil THEN S.Data[0] := #0; 99 | END; 100 | 101 | PROCEDURE FreeStr(VAR S: TString); 102 | BEGIN 103 | IF S.Data <> nil THEN BEGIN 104 | IF S.Frame = NIL THEN FreeMem(S.Data, S.Capacity); 105 | S.Data := nil; 106 | END; 107 | S.Len := 0; 108 | S.Capacity := 0; 109 | END; 110 | 111 | PROCEDURE DeleteSubStr(VAR S: TString; BeginIdx, len: WORD); 112 | BEGIN 113 | IF (BeginIdx >= S.Len) OR (len = 0) THEN EXIT; 114 | IF BeginIdx + len > S.Len THEN len := S.Len - BeginIdx; 115 | 116 | Move(S.Data[BeginIdx + len], S.Data[BeginIdx], S.Len - BeginIdx - len + 1); 117 | S.Len := S.Len - len; 118 | S.Data[S.Len] := #0; 119 | END; 120 | 121 | PROCEDURE SubString(VAR S: TString; BeginIdx, len: WORD; VAR SubStr: TString); 122 | BEGIN 123 | IF (BeginIdx >= S.Len) OR (len = 0) THEN BEGIN 124 | ClearStr(SubStr); 125 | EXIT; 126 | END; 127 | IF BeginIdx + len > S.Len THEN len := S.Len - BeginIdx; 128 | ClearStr(SubStr); 129 | ResizeString(SubStr, len + 1); 130 | Move(S.Data[BeginIdx], SubStr.Data^, len); 131 | SubStr.Data[len] := #0; 132 | SubStr.Len := len; 133 | END; 134 | 135 | FUNCTION CompareStr(S1, S2: TString): INTEGER; 136 | BEGIN 137 | IF S1.Len <> S2.Len THEN CompareStr := S1.Len - S2.Len 138 | ELSE CompareStr := StrCmp(S1.Data, S2.Data); 139 | END; 140 | 141 | { ---------------------------------------------------------------------- 142 | tests 143 | ---------------------------------------------------------------------- 144 | VAR S, SubStr: TString; 145 | 146 | PROCEDURE TestInit; 147 | BEGIN 148 | InitStr(S, 10); 149 | IF (S.Len <> 0) OR (S.Capacity <> 10) OR (S.Data = nil) THEN 150 | Writeln('TestInit failed') ELSE Writeln('TestInit passed'); 151 | END; 152 | 153 | PROCEDURE TestAppend; 154 | BEGIN 155 | AppendStr(S, 'Hello world'); 156 | IF (S.Len <> 5) OR (StrCmp(S.Data, 'Hello') <> 0) THEN 157 | Writeln('TestAppend failed') ELSE Writeln('TestAppend passed'); 158 | END; 159 | 160 | PROCEDURE TestInsert; 161 | BEGIN 162 | InsertStr(S, ' World', 5); 163 | IF (S.Len <> 11) OR (StrCmp(S.Data, 'Hello World') <> 0) THEN 164 | Writeln('TestInsert failed') ELSE Writeln('TestInsert passed'); 165 | END; 166 | 167 | PROCEDURE TestDelete; 168 | BEGIN 169 | DeleteSubStr(S, 5, 6); 170 | IF (S.Len <> 5) OR (StrCmp(S.Data, 'Hello') <> 0) THEN 171 | Writeln('TestDelete failed') ELSE Writeln('TestDelete passed'); 172 | END; 173 | 174 | PROCEDURE TestSubstring; 175 | BEGIN 176 | AppendStr(S, ' World'); 177 | Substring(S, 6, 5, SubStr); 178 | IF (SubStr.Len <> 5) OR (StrCmp(SubStr.Data, 'World') <> 0) THEN 179 | Writeln('TestSubstring failed') ELSE Writeln('TestSubstring passed'); 180 | END; 181 | 182 | PROCEDURE TestCompare; 183 | VAR S2: TString; 184 | BEGIN 185 | InitStr(S2, 10); 186 | AppendStr(S2, 'Hello'); 187 | IF CompareStr(S, S2) <> 0 THEN 188 | Writeln('TestCompare failed') ELSE Writeln('TestCompare passed'); 189 | FreeStr(S2); 190 | END; 191 | 192 | PROCEDURE TestClear; 193 | BEGIN 194 | ClearStr(S); 195 | IF (S.Len <> 0) OR (StrCmp(S.Data, '') <> 0) THEN 196 | Writeln('TestClear failed') ELSE Writeln('TestClear passed'); 197 | END; 198 | 199 | PROCEDURE TestFree; 200 | BEGIN 201 | FreeStr(S); 202 | IF (S.Len <> 0) OR (S.Capacity <> 0) OR (S.Data <> nil) THEN 203 | Writeln('TestFree failed') ELSE Writeln('TestFree passed'); 204 | END; 205 | 206 | BEGIN 207 | TestInit; 208 | TestAppend; 209 | TestInsert; 210 | TestDelete; 211 | TestSubstring; 212 | TestCompare; 213 | TestClear; 214 | TestFree; 215 | } 216 | END. 217 | -------------------------------------------------------------------------------- /hashmap.pas: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2022 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT HashMap; 24 | 25 | INTERFACE 26 | 27 | CONST 28 | TABLE_SIZE = 16; 29 | MAX_KEY_LENGTH = 32; 30 | 31 | TYPE 32 | TMapKeyStr = STRING[MAX_KEY_LENGTH]; 33 | TMapKey = RECORD 34 | Key : TMapKeyStr; 35 | Hash : WORD; 36 | END; 37 | 38 | PHashEntry = ^THashEntry; 39 | THashEntry = RECORD 40 | Key : TMapKey; 41 | Value : POINTER; 42 | Next : PHashEntry; 43 | END; 44 | 45 | PHashMap = ^THashMap; 46 | THashMap = RECORD 47 | Table : ARRAY[0..TABLE_SIZE-1] OF PHashEntry; 48 | ElementSize : WORD; 49 | END; 50 | 51 | PROCEDURE Init(VAR Table: THashMap; ElementSize : WORD); 52 | PROCEDURE Clear(VAR Table: THashMap); 53 | FUNCTION ContainsKey(VAR Table: THashMap; Key: STRING): BOOLEAN; 54 | FUNCTION Get(VAR Table: THashMap; Key: STRING; VAR Value): BOOLEAN; 55 | FUNCTION GetPtr(VAR Table: THashMap; Key: STRING): POINTER; 56 | PROCEDURE Put(VAR Table: THashMap; Key: STRING; VAR Value); 57 | FUNCTION Remove(VAR Table: THashMap; Key: STRING): BOOLEAN; 58 | 59 | IMPLEMENTATION 60 | 61 | FUNCTION HashCode(VAR Key: TMapKeyStr): WORD; 62 | VAR 63 | i: WORD; 64 | Hash: WORD; 65 | BEGIN 66 | Hash := 0; 67 | FOR i := 1 TO Length(Key) DO INC(Hash, Hash * 48 + Ord(Key[i])); 68 | HashCode := Hash; 69 | END; 70 | 71 | FUNCTION TableIndex(Hash : WORD): INTEGER; 72 | BEGIN 73 | TableIndex := Hash MOD TABLE_SIZE; 74 | END; 75 | 76 | FUNCTION CreateHashEntry(VAR Table: THashMap; Next : PHashEntry; VAR Key: TMapKey; VAR value): PHashEntry; 77 | VAR 78 | P: PHashEntry; 79 | BEGIN 80 | GetMem(P, SizeOf(THashEntry)); 81 | P^.Key := Key; 82 | P^.Next := Next; 83 | GetMem(P^.Value, Table.ElementSize); 84 | Move(value, P^.Value^, Table.ElementSize); 85 | CreateHashEntry := P; 86 | END; 87 | 88 | PROCEDURE Init(VAR Table: THashMap; ElementSize : WORD); 89 | BEGIN 90 | FillChar(Table, SizeOf(THashMap), 0); 91 | Table.ElementSize := ElementSize; 92 | END; 93 | 94 | PROCEDURE CreateKeys(VAR s : STRING; VAR k : TMapKey); 95 | BEGIN 96 | k.Key := s; 97 | k.Hash := HashCode(k.Key); 98 | END; 99 | 100 | FUNCTION CompareKeys(VAR k1, k2 : TMapKey) : BOOLEAN; 101 | BEGIN 102 | IF k1.Hash = k2.Hash THEN CompareKeys := k1.Key = k2.Key ELSE CompareKeys := FALSE; 103 | END; 104 | 105 | FUNCTION GetOrCreate(VAR Table: THashMap; Key: STRING; create : BOOLEAN) : PHashEntry; 106 | VAR 107 | Entry: PHashEntry; 108 | newKey: TMapKey; 109 | tIndex : INTEGER; 110 | BEGIN 111 | CreateKeys(Key, newKey); 112 | tIndex := TableIndex(newKey.Hash); 113 | Entry := Table.Table[tIndex]; 114 | 115 | WHILE Entry <> NIL DO BEGIN 116 | IF CompareKeys(Entry^.Key, newKey) THEN BEGIN 117 | GetOrCreate := Entry; 118 | EXIT; 119 | END; 120 | Entry := Entry^.Next; 121 | END; 122 | IF create THEN BEGIN 123 | Entry := CreateHashEntry(Table, Table.Table[tIndex], newKey, newKey); 124 | Table.Table[tIndex] := Entry; 125 | END; 126 | GetOrCreate := Entry; 127 | END; 128 | 129 | FUNCTION Get(VAR Table: THashMap; Key: STRING; VAR Value): BOOLEAN; 130 | VAR 131 | Entry: PHashEntry; 132 | BEGIN 133 | Entry := GetOrCreate(Table, Key, FALSE); 134 | IF Entry <> NIL THEN Move(Entry^.Value^, Value, Table.ElementSize); 135 | Get := Entry <> NIL; 136 | END; 137 | 138 | FUNCTION GetPtr(VAR Table: THashMap; Key: STRING): POINTER; 139 | VAR 140 | Entry: PHashEntry; 141 | BEGIN 142 | Entry := GetOrCreate(Table, Key, FALSE); 143 | IF Entry <> NIL THEN GetPtr := Entry^.Value ELSE GetPtr := NIL; 144 | END; 145 | 146 | FUNCTION Remove(VAR Table: THashMap; Key: STRING): BOOLEAN; 147 | VAR 148 | Entry, Prev: PHashEntry; 149 | newKey: TMapKey; 150 | tIndex : INTEGER; 151 | BEGIN 152 | CreateKeys(Key, newKey); 153 | tIndex := TableIndex(newKey.Hash); 154 | Entry := Table.Table[tIndex]; 155 | Prev := NIL; 156 | 157 | WHILE Entry <> NIL DO BEGIN 158 | IF CompareKeys(Entry^.Key, newKey) THEN BEGIN 159 | IF Prev = NIL THEN Table.Table[tIndex] := Entry^.Next 160 | ELSE Prev^.Next := Entry^.Next; 161 | FreeMem(Entry^.Value, Table.ElementSize); 162 | FreeMem(Entry, SizeOf(THashEntry)); 163 | Remove := TRUE; 164 | EXIT; 165 | END; 166 | Prev := Entry; 167 | Entry := Entry^.Next; 168 | END; 169 | 170 | Remove := FALSE; 171 | END; 172 | 173 | PROCEDURE Clear(VAR Table: THashMap); 174 | VAR 175 | i: WORD; 176 | Entry, Next: PHashEntry; 177 | BEGIN 178 | FOR i := 0 TO TABLE_SIZE-1 DO BEGIN 179 | Entry := Table.Table[i]; 180 | WHILE Entry <> NIL DO BEGIN 181 | Next := Entry^.Next; 182 | FreeMem(Entry^.Value, Table.ElementSize); 183 | FreeMem(Entry, SizeOf(THashEntry)); 184 | Entry := Next; 185 | END; 186 | END; 187 | FillChar(Table, SizeOf(THashMap), 0); 188 | END; 189 | 190 | PROCEDURE Put(VAR Table: THashMap; Key: STRING; VAR Value); 191 | VAR 192 | Entry : PHashEntry; 193 | BEGIN 194 | Entry := GetOrCreate(Table, Key, TRUE); 195 | Move(Value, Entry^.Value^, Table.ElementSize); 196 | END; 197 | 198 | FUNCTION ContainsKey(VAR Table: THashMap; Key: STRING): BOOLEAN; 199 | BEGIN 200 | ContainsKey := GetOrCreate(Table, Key, FALSE) <> NIL; 201 | END; 202 | 203 | END. 204 | -------------------------------------------------------------------------------- /lzpmem.pas: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2025 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A+,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT LZPMEM; 24 | 25 | INTERFACE 26 | 27 | FUNCTION LZP_encmem(input: PCHAR; len : WORD; output: PCHAR) : WORD; 28 | FUNCTION LZP_decmem(input: PCHAR; len : WORD; output: PCHAR) : WORD; 29 | 30 | IMPLEMENTATION 31 | 32 | CONST 33 | HASH_BITS = 12; 34 | HASH_SIZE = (1 SHL HASH_BITS); 35 | HASH_MASK = HASH_SIZE - 1; 36 | 37 | TYPE 38 | THashTable = ARRAY[0..HASH_SIZE - 1] Of CHAR; 39 | 40 | { 41 | FUNCTION HashFunc(h: WORD; x: CHAR) : WORD; 42 | BEGIN 43 | HashFunc := ((h * 160) XOR (ORD(x) AND $FF)) AND (HASH_SIZE - 1); 44 | END; 45 | } 46 | 47 | FUNCTION HashFunc(h: WORD; x: CHAR) : WORD; ASSEMBLER; 48 | ASM 49 | MOV AX, [h] 50 | XOR DX, DX 51 | MOV CL, 160 52 | MUL CL 53 | XOR AL, [x] 54 | AND AX, HASH_MASK 55 | END; 56 | 57 | FUNCTION LZP_encmem(input: PCHAR; len : WORD; output: PCHAR) : WORD; 58 | VAR hash, r, i : WORD; 59 | c : CHAR; 60 | mask : BYTE; 61 | HashTable : THashTable; 62 | maskPtr : PCHAR; 63 | BEGIN 64 | FillChar(HashTable, SizeOf(THashTable), #0); 65 | hash := 0; 66 | r := ofs(output^); 67 | WHILE (len <> 0) DO BEGIN 68 | mask := 0; 69 | i := 0; 70 | maskPtr := output; 71 | INC(output); 72 | WHILE (i <= 7) AND (len <> 0) DO BEGIN 73 | c := input^; 74 | INC(input); 75 | DEC(len); 76 | IF c = HashTable[hash] THEN mask := mask OR (1 SHL i) 77 | ELSE BEGIN 78 | HashTable[hash] := c; 79 | output^ := c; 80 | INC(output); 81 | END; 82 | hash := HashFunc(hash, c); 83 | INC(i); 84 | END; 85 | maskPtr^ := CHR(mask); 86 | END; 87 | LZP_encmem := ofs(output^) - r; 88 | END; 89 | 90 | FUNCTION LZP_decmem(input: PCHAR; len : WORD; output: PCHAR) : WORD; 91 | VAR hash, i, r : WORD; 92 | mask : BYTE; 93 | c : CHAR; 94 | HashTable : THashTable; 95 | BEGIN 96 | FillChar(HashTable, SizeOf(THashTable), #0); 97 | r := ofs(output^); 98 | hash := 0; 99 | WHILE (len <> 0) DO BEGIN 100 | mask := ORD(input^); 101 | INC(input); 102 | DEC(len); 103 | i := 0; 104 | WHILE (i <= 7) AND (len <> 0) DO BEGIN 105 | IF (mask AND (1 SHL i)) <> 0 THEN c := HashTable[hash] 106 | ELSE BEGIN 107 | c := input^; 108 | HashTable[hash] := c; 109 | INC(input); 110 | DEC(len); 111 | END; 112 | output^ := c; 113 | INC(output); 114 | hash := HashFunc(hash, c); 115 | INC(i); 116 | END; 117 | END; 118 | LZP_decmem := ofs(output^) - r; 119 | END; 120 | 121 | END. 122 | -------------------------------------------------------------------------------- /memframe.pas: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2025 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT memframe; 24 | 25 | INTERFACE 26 | 27 | CONST 28 | MemFrameNodeSize = 32; 29 | 30 | TYPE 31 | 32 | PMemFrameEntry = ^TMemFrameEntry; 33 | TMemFrameEntry = RECORD 34 | Pointers : ARRAY[1..MemFrameNodeSize] OF POINTER; 35 | Sizes : ARRAY[1..MemFrameNodeSize] OF WORD; 36 | Count : INTEGER; 37 | Next : PMemFrameEntry; 38 | END; 39 | 40 | PMemFrame = ^TMemFrame; 41 | TMemFrame = RECORD 42 | Head : PMemFrameEntry; 43 | NodeCount : INTEGER; 44 | END; 45 | 46 | PROCEDURE Init(VAR Frame: TMemFrame); 47 | FUNCTION Alloc(VAR Frame: TMemFrame; size: Word): POINTER; 48 | PROCEDURE FreeAll(VAR Frame: TMemFrame); 49 | 50 | IMPLEMENTATION 51 | 52 | PROCEDURE Init(VAR Frame: TMemFrame); 53 | BEGIN 54 | Frame.Head := NIL; 55 | Frame.NodeCount := 0; 56 | END; 57 | 58 | FUNCTION Alloc(VAR Frame: TMemFrame; size: Word): POINTER; 59 | VAR CurrentNode: PMemFrameEntry; 60 | p : POINTER; 61 | BEGIN 62 | IF Frame.Head = NIL THEN BEGIN 63 | New(Frame.Head); 64 | FillChar(Frame.Head^, SizeOf(TMemFrameEntry), 0); 65 | Inc(Frame.NodeCount); 66 | END; 67 | 68 | CurrentNode := Frame.Head; 69 | WHILE (CurrentNode^.Count = MemFrameNodeSize) AND (CurrentNode^.Next <> NIL) do BEGIN 70 | CurrentNode := CurrentNode^.Next; 71 | END; 72 | 73 | IF CurrentNode^.Count = MemFrameNodeSize THEN BEGIN 74 | New(CurrentNode^.Next); 75 | FillChar(CurrentNode^.Next^, SizeOf(TMemFrameEntry), 0); 76 | CurrentNode := CurrentNode^.Next; 77 | Inc(Frame.NodeCount); 78 | END; 79 | 80 | GetMem(p, size); 81 | IF p <> NIL THEN BEGIN 82 | CurrentNode^.Pointers[CurrentNode^.Count + 1] := p; 83 | CurrentNode^.Sizes[CurrentNode^.Count + 1] := size; 84 | Inc(CurrentNode^.Count); 85 | END; 86 | Alloc := p; 87 | END; 88 | 89 | PROCEDURE FreeAll(VAR Frame: TMemFrame); 90 | VAR CurrentNode, TempNode: PMemFrameEntry; 91 | i: INTEGER; 92 | BEGIN 93 | CurrentNode := Frame.Head; 94 | WHILE CurrentNode <> NIL DO BEGIN 95 | FOR i := 1 TO CurrentNode^.Count DO BEGIN 96 | IF CurrentNode^.Pointers[i] <> NIL THEN BEGIN 97 | FreeMem(CurrentNode^.Pointers[i], CurrentNode^.Sizes[i]); 98 | CurrentNode^.Pointers[i] := NIL; 99 | CurrentNode^.Sizes[i] := 0; 100 | END; 101 | END; 102 | TempNode := CurrentNode; 103 | CurrentNode := CurrentNode^.Next; 104 | Dispose(TempNode); 105 | END; 106 | Frame.Head := NIL; 107 | Frame.NodeCount := 0; 108 | END; 109 | 110 | END. 111 | -------------------------------------------------------------------------------- /npbm.pas: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2025 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT NPBM; 24 | 25 | INTERFACE 26 | 27 | FUNCTION LoadPBM(VAR f : FILE; VAR dest : PCHAR; VAR len, width, height : WORD) : BOOLEAN; 28 | 29 | IMPLEMENTATION 30 | 31 | PROCEDURE SkipToEol(VAR f: FILE); 32 | VAR 33 | c : CHAR; 34 | BEGIN 35 | c := #0; 36 | WHILE (NOT EOF(f)) AND (c <> #10) DO BlockRead(f, c, 1); 37 | END; 38 | 39 | FUNCTION ReadTextNumber(VAR f : FILE; VAR n : WORD) : BOOLEAN; 40 | VAR 41 | ch : CHAR; 42 | s : STRING; 43 | i : INTEGER; 44 | BEGIN 45 | WHILE NOT EOF(f) DO BEGIN 46 | BlockRead(f, ch, 1); 47 | IF (ch = '#') THEN SkipToEol(f) 48 | ELSE IF ch IN [' ', #9, #10, #13] THEN CONTINUE 49 | ELSE IF ch IN ['0'..'9'] THEN BEGIN 50 | s := ch; 51 | WHILE NOT EOF(f) DO BEGIN 52 | BlockRead(f, ch, 1); 53 | IF NOT (ch IN ['0'..'9']) THEN BEGIN Seek(f, FilePos(f) - 1); BREAK; END; 54 | INC(s[0]); 55 | s[ORD(s[0])] := ch; 56 | END; 57 | VAL(s, n, i); 58 | ReadTextNumber := i = 0; 59 | EXIT; 60 | END ELSE BREAK; 61 | END; 62 | ReadTextNumber := FALSE; 63 | END; 64 | 65 | FUNCTION LoadPBM(VAR f : FILE; VAR dest : PCHAR; VAR len, width, height : WORD) : BOOLEAN; 66 | VAR 67 | ch1, ch2: CHAR; 68 | pitch, x, y, v: WORD; 69 | format, bitpos, byteval: BYTE; 70 | p: PCHAR; 71 | BEGIN 72 | dest := NIL; 73 | len := 0; 74 | width := 0; 75 | height := 0; 76 | 77 | BlockRead(f, ch1, 1); 78 | BlockRead(f, ch2, 1); 79 | IF (ch1 <> 'P') OR NOT (ch2 IN ['1', '4']) THEN BEGIN LoadPBM := FALSE; EXIT; END; 80 | format := ORD(ch2) - ORD('0'); 81 | 82 | IF NOT ReadTextNumber(f, width) THEN BEGIN LoadPBM := FALSE; EXIT; END; 83 | IF NOT ReadTextNumber(f, height) THEN BEGIN LoadPBM := FALSE; EXIT; END; 84 | 85 | SkipToEol(f); 86 | 87 | pitch := (width + 7) SHR 3; 88 | len := pitch * height; 89 | 90 | GetMem(dest, len); 91 | IF dest = NIL THEN BEGIN LoadPBM := FALSE; EXIT; END; 92 | 93 | p := dest; 94 | 95 | IF format = 1 THEN BEGIN 96 | FOR y := 0 TO height - 1 DO BEGIN 97 | byteval := 0; 98 | bitpos := 7; 99 | FOR x := 0 TO width - 1 DO BEGIN 100 | IF NOT ReadTextNumber(f, v) THEN BEGIN FreeMem(dest, len); LoadPBM := FALSE; EXIT; END; 101 | IF v = 1 THEN byteval := byteval OR (1 SHL bitpos); 102 | DEC(bitpos); 103 | IF bitpos = $FF THEN BEGIN 104 | p^ := CHR(byteval); 105 | INC(p); 106 | byteval := 0; 107 | bitpos := 7; 108 | END; 109 | END; 110 | IF bitpos <> 7 THEN BEGIN 111 | p^ := CHR(byteval); 112 | INC(p); 113 | END; 114 | END; 115 | END ELSE IF format = 4 THEN BlockRead(f, p^, len); 116 | 117 | LoadPBM := TRUE; 118 | END; 119 | 120 | END. -------------------------------------------------------------------------------- /pcxrle.pas: -------------------------------------------------------------------------------- 1 | { MIT License 2 | 3 | Copyright (c) 2025 Viacheslav Komenda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. } 22 | {$A-,I-,S-,R-,D+,L+,Q-,F-,G-,O-,B-} 23 | UNIT pcxrle; 24 | 25 | INTERFACE 26 | 27 | FUNCTION RLE_COMPRESS(src: PCHAR; len: WORD; dst: PCHAR): WORD; 28 | FUNCTION RLE_DECOMPRESS(src: PCHAR; len: WORD; dst: PCHAR): WORD; 29 | 30 | IMPLEMENTATION 31 | 32 | FUNCTION RLE_COMPRESS(src: PCHAR; len: WORD; dst: PCHAR): WORD; 33 | VAR 34 | dstPtr: WORD; 35 | count: BYTE; 36 | c : CHAR; 37 | BEGIN 38 | dstPtr := ofs(dst^); 39 | WHILE len <> 0 DO BEGIN 40 | count := 1; 41 | c := src^; 42 | WHILE (count <= len) AND (c = src[count]) AND (count < 63) DO INC(count); 43 | IF (count > 1) OR ((ORD(c) AND $C0) = $C0) THEN BEGIN 44 | dst^ := CHR($C0 OR count); 45 | INC(dst); 46 | dst^ := c; 47 | INC(dst); 48 | END ELSE BEGIN 49 | dst^ := c; 50 | INC(dst); 51 | END; 52 | INC(src, count); 53 | DEC(len, count); 54 | END; 55 | RLE_COMPRESS := ofs(dst^) - dstPtr; 56 | END; 57 | 58 | FUNCTION RLE_DECOMPRESS(src: PCHAR; len: WORD; dst: PCHAR): WORD; 59 | VAR 60 | dstPtr: WORD; 61 | count: BYTE; 62 | c : CHAR; 63 | BEGIN 64 | dstPtr := ofs(dst^); 65 | WHILE len <> 0 DO BEGIN 66 | c := src^; 67 | IF (ORD(c) AND $C0) = $C0 THEN BEGIN 68 | count := ORD(c) AND $3F; 69 | INC(src); 70 | DEC(len); 71 | FillChar(dst^, count, src^); 72 | END ELSE BEGIN 73 | dst^ := c; 74 | count := 1; 75 | END; 76 | INC(src); 77 | DEC(len); 78 | INC(dst, count); 79 | END; 80 | RLE_DECOMPRESS := ofs(dst^) - dstPtr; 81 | END; 82 | 83 | END. 84 | -------------------------------------------------------------------------------- /rebuild.pas: -------------------------------------------------------------------------------- 1 | { (c) Stefan Reuther, Streu@gmx.de } 2 | {$M 4096,0,0} 3 | PROGRAM Rebuid; 4 | 5 | USES DOS; 6 | 7 | CONST 8 | MAX = 256; 9 | OPTIONS = '/m'; 10 | 11 | VAR 12 | files : ARRAY[1..MAX] OF STRING[8]; 13 | r : SearchRec; 14 | i, j, k : INTEGER; 15 | tpc : STRING; 16 | 17 | BEGIN 18 | i := 0; 19 | FindFirst('*.pas', AnyFile, r); 20 | WHILE DOSError=0 DO BEGIN 21 | j := Pos('.', r.Name); 22 | IF j <> 0 THEN BEGIN 23 | INC(i); 24 | IF i>MAX THEN BEGIN 25 | Writeln('Too many files.'); 26 | Halt(1); 27 | END; 28 | files[i] := Copy(r.name, 1, j-1); 29 | END; 30 | FindNext(R); 31 | END; 32 | tpc := FSearch('TPC.EXE', GetEnv('PATH')); 33 | IF Length(tpc) = 0 THEN BEGIN 34 | Writeln('tpc.exe not found.'); 35 | Halt(1); 36 | END; 37 | FOR j := 1 TO i DO BEGIN 38 | Writeln(files[j]); 39 | SwapVectors; 40 | Exec(tpc, OPTIONS + ' ' + files[j]); 41 | SwapVectors; 42 | k := DOSExitCode; 43 | IF k <> 0 THEN BEGIN 44 | Writeln('Error code: ', k); 45 | Halt(k); 46 | END; 47 | END; 48 | END. 49 | --------------------------------------------------------------------------------