1
2 unit erweiter;
3
4 {
5 ERWEITER.PAS - Copyright (C) 1998 by Sven Bursch, Germany
6
7 Revision 1.8 1998/10/16 18:10:41 sven
8 - geterrortext
9
10 Revision 1.7 1998/10/04 17:10:47 sven
11 - �nderungen f�r DPMI vorgenommen
12
13 Revision 1.6 1998/10/03 14:52:34 sven
14 - diverse �nderungen wegen verschiedenenen Compilern
15
16 Revision 1.5 1998/10/02 19:34:32 sven
17 - diverses
18
19 Revision 1.4 1998/06/03 18:01:41 ingo
20 - Copyrightnotiz
21
22 Revision 1.3 1998/06/03 17:15:01 ingo
23 - Funktionen fuer Cursorgroesse von MPEDITOR in ERWEITER verschoben
24
25 Revision 1.2 1998/06/02 09:48:38 ingo
26 Neue Funktion: Getlines
27 Gibt die derzeitige Zeilenanzahl zurueck
28
29 Revision 1.1 1998/06/02 09:12:36 ingo
30 Initial revision
31
32 }
33
34 interface
35
36 {$ifdef __GPC__}
37 {$X+}
38 uses gpcstrings;
39 {$endif}
40
41 {$ifdef fpc}
42 {$ifdef linux}
43 uses strings,dos;
44 {$define havedosunit}
45 {$endif}
46 {$endif}
47
48
49 {$ifdef ver70}
50 {$ifdef dpmi}
51 uses strings,dos,winapi;
52 {$define havedosunit}
53 {$define realmode}
54 {$else}
55 uses strings,dos;
56 {$define havedosunit}
57 {$endif}
58 {$endif}
59
60
61 const
62 k_down=20480;
63 k_up=18432;
64 k_altn=12544;
65 k_esc=27;
66
67 {$ifdef ver70}{$ifdef dpmi}
68 type
69 dpmiRegisters = record
70 EDI, ESI, EBP, shouldbezero, EBX, EDX, ECX, EAX : longint;
71 Flags, ES, DS, FS, GS, IP, CS, SP, SS : word;
72 end;
73 {$endif} {$endif}
74 {$i err.inc}
75
76 {$ifdef __GPC__}
Existnull77 FUNCTION Exist (Filename : STRING):BOOLEAN;
78 {$endif}
79
80 {$ifdef havedosunit}
Existnull81 FUNCTION Exist (Filename : STRING):BOOLEAN;
checkpathnull82 function checkpath(var path:string):boolean;
83 {$endif}
84
85 {$ifdef realmode}
GetLinesnull86 FUNCTION GetLines: Word;
87 PROCEDURE SetCursor(StartLine,EndLine: Byte);
GetCursornull88 FUNCTION GetCursor(Page: Byte): Word; { High: Start Low: End }
GetPagenull89 FUNCTION GetPage: Byte;
90 procedure cursoroff;
91 {$endif}
92
93 {$ifndef linux}
keynull94 function key:word;
95 procedure beep;
96 procedure writexyc(x,y,c1,c2:byte;s:string);
97 procedure writexy(x,y:byte;s:String);
98 procedure color(i,j:byte);
99 {$endif}
100 var vram:word;
anzahlnull101 function anzahl(haupt:string;se:string):byte;
replacenull102 function replace(haupt:string;se:string;er:string):string;
hochnull103 function hoch(a,b:integer):longint;
getzeichennull104 function getzeichen(x,y:integer):string;
leernull105 function leer(x:integer):String;
kill_last_spacenull106 function kill_last_space(a:string):string;
zahl2stringnull107 function zahl2string(I: Longint): String;
zennull108 function zen(a:string;b:integer):string;
upnull109 function up(a:string):string;
z2snull110 function z2s(I: Longint): String;
z2s_nullennull111 function z2s_nullen(I: Longint;j:longint): String;
s2znull112 function s2z(i:string):integer;
Hex2Stringnull113 FUNCTION Hex2String(n: Byte): String;
ascnull114 function asc(i:byte;c:char):string;
killspaceAEnull115 function killspaceAE(t:String):string;
find_lastnull116 function find_last(s:String;c:char):byte;
geterrortextnull117 function geterrortext(x:word):string;
psearchnull118 function psearch(p:pchar;tosearch:pchar):pchar;
psearchInull119 function psearchI(p:pchar;tosearch:pchar):pchar;
120
121
122 implementation
123
124 {$ifdef __GPC__}
Existnull125 FUNCTION Exist (Filename : STRING):BOOLEAN;
126 begin
127 writeln('exist: Nicht implementiert');
128 halt;
129 end;
130 {$endif}
131
132 {===========================================================================}
133 {===========================================================================}
134 {===========================================================================}
135 {===========================================================================}
136
137 {$ifdef havedosunit}
Existnull138 FUNCTION Exist (Filename : STRING):BOOLEAN;
139 var
140 dir:searchrec;
141 i:word;
142 BEGIN
143 FindFirst(filename, anyfile, Dir);
144 Exist := (doserror=0);
145 END;
146
checkpathnull147 function checkpath(var path:string):boolean;
148 var
149 old:string;
150 s:string;
151 begin
152 if ioresult=0 then ;
153 checkpath:=false;
154 while (length(path)>0) and (path[length(path)]='\') do delete(path,length(path),1);
155 {$i-}
156 getdir(0,old); if ioresult<>0 then exit;
157 chdir(path); if ioresult<>0 then exit;
158 getdir(0,s); if ioresult<>0 then exit;
159 chdir(old); if ioresult<>0 then exit;
160 path:=s+'\';
161 checkpath:=true;
162 {$i+}
163 end;
164 {$endif}
165
166 {===========================================================================}
167 {===========================================================================}
168 {===========================================================================}
169 {===========================================================================}
170 {$ifdef realmode}
GetLinesnull171 FUNCTION GetLines: Word;
172 type
173 tbuf=array[0..63] of byte;
174 VAR
175 buf: ^tbuf;
176 r: Registers;
177 {$ifdef ver70}{$ifdef dpmi}
178 rr:dpmiregisters;
179 result:byte;
180 allocres:longint;
181 {$endif}{$endif}
182 BEGIN
183 getlines:=20;
184
185 {$ifdef fpc}
186 getlines:=25;
187 exit;
188 {$endif}
189
190 {Borland-Pascal 7.0 Real-Mode}
191 {$ifdef ver70}
192 {$ifndef dpmi}
193 getmem(buf,64);
194 r.ax := $1b00;
195 r.bx := 0;
196 r.es := Seg(buf^);
197 r.di := Ofs(buf^);
198 Intr($10,r);
199 IF r.al <> $1b THEN GetLines := 25
200 ELSE GetLines := Buf^[$22];
201 freemem(buf,64);
202 exit;
203 {$endif}
204 {$endif}
205
206 {Borland-Pascal 7.0 DPMI-Mode}
207 {$ifdef ver70}
208 {$ifdef dpmi}
209 fillchar(rr,sizeof(rr),0);
210 AllocRes := GlobalDosAlloc(64);
211 rr.eax := $1b00;
212 rr.es:=AllocRes SHR 16;
213 result:=realmodeint($10,rr);
214 buf:=Ptr(AllocRes AND 65535,0);
215 IF (result=0) and ( (rr.eax and $ff)=$1b ) then begin
216 getlines := buf^[$22];
217 end else begin
218 getlines:=25;
219 end;
220 IF GlobalDosFree(AllocRes AND 65535) <> 0 THEN ;
221 exit;
222 {$endif}
223 {$endif}
224 END;
225
226 procedure cursoroff;
227 var
228 a:Registers;
229 begin
230 a.al:=15;
231 a.ah:=0;
232 intr($10,a);
233 end;
234
235 PROCEDURE SetCursor(StartLine,EndLine: Byte);
236 VAR r: Registers;
237 BEGIN
238 r.ah := 1;
239 r.ch := StartLine;
240 r.cl := EndLine;
241 Intr($10,r);
242 END;
243
GetCursornull244 FUNCTION GetCursor(Page: Byte): Word; { High: Start Low: End }
245 VAR r: Registers;
246 BEGIN
247 getcursor:=0;
248 r.ah := 3;
249 r.bh := Page;
250 Intr($10,r);
251 GetCursor := 256*r.ch+r.cl;
252 END;
253
GetPagenull254 FUNCTION GetPage: Byte;
255 VAR r: Registers;
256 BEGIN
257 getpage:=$ff;
258 r.ah := $0f;
259 Intr($10,r);
260 GetPage := r.bh;
261 END;
262
263 {$endif}
264
265 {===========================================================================}
266 {===========================================================================}
267 {===========================================================================}
268 {===========================================================================}
269
270 {$ifndef linux}
271 procedure color(i,j:byte);
272 begin
273 textcolor(i);
274 textbackground(j);
275 end;
keynull276 function key:word;
277 var
278 ch:char;
279 begin
280 ch:=readkey;
281 if ch=#0 then begin
282 key:=byte(readkey)*256;
283 end else begin
284 key:=byte(ch);
285 end;
286 end;
287 procedure beep;
288 begin
289 sound(220);
290 delay(299);
291 nosound;
292 end;
293 procedure writexyc(x,y,c1,c2:byte;s:string);
294 begin
295 textcolor(c1);
296 textbackground(c2);
297 gotoxy(x,y);
298 write(s);
299 end;
300 procedure writexy(x,y:byte;s:String);
301 begin
302 gotoxy(x,y);
303 write(s);
304 end;
305
306 {$endif}
307
psearchnull308 function psearch(p:pchar;tosearch:pchar):pchar;
309 var
310 i,j:longint;
311 found:boolean;
312 begin
313 i:=0;
314 found:=false;
315 while (p[i]<>#0) and (not found) do begin
316 found:=true;
317 for j:=0 to Strlen(tosearch)-1 do begin
318 if p[i+j]<>tosearch[j] then begin found:=false; break; end;
319 end;
320 inc(i);
321 end;
322 if found then
323 psearch:=@p[i-1]
324 else
325 psearch:=nil;
326 end;
327
psearchInull328 function psearchI(p:pchar;tosearch:pchar):pchar;
329 var
330 i,j:longint;
331 found:boolean;
332 begin
333 i:=0;
334 found:=false;
335 while (p[i]<>#0) and (not found) do begin
336 found:=true;
337 for j:=0 to Strlen(tosearch)-1 do begin
338 if upcase(p[i+j])<>upcase(tosearch[j]) then begin found:=false; break; end;
339 end;
340 inc(i);
341 end;
342 if found then begin
343 psearchi:=@p[i-1]
344 end else begin
345 psearchi:=nil;
346 end;
347 end;
348
geterrortextnull349 function geterrortext(x:word):string;
350 var
351 i:word;
352 begin
353 for i:=low(errorcodes) to high(errorcodes) do begin
354 if x=errorcodes[i].nr then begin
355 geterrortext:=errorcodes[i].s; exit;
356 end;
357 end;
358 geterrortext:='Error '+z2s(x);
359 end;
360
find_lastnull361 function find_last(s:String;c:char):byte;
362 var
363 i:byte;
364 begin
365 for i:=length(s) downto 1 do begin
366 if s[i]=c then break;
367 end;
368 if i>1 then find_last:=i;
369 if (i=1) and (s[i]=c) then find_last:=1;
370 if (i=1) and (s[i]<>c) then find_last:=0;
371 end;
killspaceAEnull372 function killspaceAE(t:String):string;
373 var
374 s:string;
375 begin
376 s:=t;
377 while (length(s)>0) and (s[1]=' ') do delete(s,1,1);
378 while (length(s)>0) and (s[length(s)]=' ') do delete(s,length(s),1);
379 killspaceae:=s;
380 end;
381
382
383
Hex2Stringnull384 FUNCTION Hex2String(n: Byte): String;
385 CONST hex: ARRAY[0..15] OF Char = '0123456789ABCDEF';
386 BEGIN
387 Hex2String := hex[n SHR 4] + hex[n AND 15];
388 END;
389
390
391
392 {slow, but portable}
ascnull393 function asc(i:byte;c:char):string;
394 var
395 s:string;
396 j:byte;
397 begin
398 s:='';
399 for j:=1 to i do s:=s+c;
400 asc:=s;
401 end;
402
403
zahl2stringnull404 function zahl2string(I: Longint): String;
405 var
406 S: string[11];
407 begin
408 Str(I, S);
409 zahl2string := S;
410 end;
411
s2znull412 function s2z(i:string):integer;
413 var
414 tmp2,tmp:integer;
415 begin
416 val(i,tmp2,tmp);
417 s2z:=tmp2;
418 end;
419
z2s_nullennull420 function z2s_nullen(I: Longint;j:longint): String;
421 var
422 S: string;
423 begin
424 Str(I, S);
425 while length(s)<j do s:='0'+s;
426 z2s_nullen := S;
427 end;
428
z2snull429 function z2s(I: Longint): String;
430 var
431 S: string;
432 begin
433 s:='';
434 Str(I, S);
435 z2s := S;
436 end;
437
438
439
upnull440 function up(a:string):string;
441 var
442 tmp:string;
443 i:integer;
444 begin
445 tmp:='';
446 for i:=1 to length(a) do tmp:=tmp+upcase(a[i]);
447 up:=tmp;
448 end;
449
zennull450 function zen(a:string;b:integer):string;
451 var
452 i:integer;
453 begin
454 i:=(b-length(a)) div 2;
455 zen:=leer(i)+a;
456 end;
457
458
getzeichennull459 function getzeichen(x,y:integer):string;
460 begin
461 {getzeichen:=chr(mem[vram:((x-1)+((y-1)*80))*2]);}
462 getzeichen:='';
463 end;
464
kill_last_spacenull465 function kill_last_space(a:string):string;
466 var i:integer;
467 begin
468 i:=length(a)+1;
469 repeat
470 i:=i-1;
471 until a[i]<>' ';
472 kill_last_space:=copy(a,1,i);
473 end;
474
leernull475 function leer(x:integer):String;
476 var
477 a:string;
478 i:integer;
479 begin
480 a:='';
481 for i:=1 to x do a:=a+' ';
482 leer:=a
483 end;
484
anzahlnull485 function anzahl(haupt:string;se:string):byte;
486 var
487 b:byte;
488 d:char;
489 begin
490 b:=0;
491 if se=' ' then d:='�' else d:=' ';
492 while pos(se,haupt)>0 do begin
493 haupt[pos(se,haupt)]:=d;
494 b:=b+1;
495 end;
496 anzahl:=b
497 end;
498
hochnull499 function hoch(a,b:integer):longint;
500 var
501 i,j:longint;
502 begin
503 j:=1;
504 if b>1 then j:=a;
505 for i:=2 to b do j:=j*a;
506 hoch:=J;
507 end;
508
replacenull509 function replace(haupt:string;se:string;er:string):string;
510 var i,j,k:integer;
511 begin
512 j:=anzahl(haupt,se);
513 for i:=1 to j do begin
514 k:=pos(se,haupt);
515 delete(haupt,k,length(se));
516 insert(er,haupt,k);
517 end;
518 replace:=haupt;
519 end;
520
521
522 {$ifdef ver70}
523 {$ifdef dpmi}
RealModeIntnull524 function RealModeInt(int:word; regs:dpmiregisters): word; assembler;
525 asm
526 push bp
527 mov ax,$300
528 les di, regs
529 xor cx,cx
530 mov bx,int
531 int $31
532 jc @ende
533 xor ax,ax
534 @ende:
535 pop bp
536 end;
537 {$endif}
538 {$endif}
539
540
541
542 end.
543