crt.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by the Free Pascal development team.
  4. Borland Pascal 7 Compatible CRT Unit - win32 implentation
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. unit crt;
  12. interface
  13. {$i crth.inc}
  14. procedure Window32(X1,Y1,X2,Y2: DWord);
  15. procedure GotoXY32(X,Y: DWord);
  16. function WhereX32: DWord;
  17. function WhereY32: DWord;
  18. implementation
  19. uses
  20. windows;
  21. var
  22. SaveCursorSize: Longint;
  23. {
  24. definition of textrec is in textrec.inc
  25. }
  26. {$i textrec.inc}
  27. {****************************************************************************
  28. Low level Routines
  29. ****************************************************************************}
  30. procedure TurnMouseOff;
  31. var Mode: DWORD;
  32. begin
  33. if GetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), @Mode) then begin { Turn the mouse-cursor off }
  34. Mode := Mode AND cardinal(NOT enable_processed_input)
  35. AND cardinal(NOT enable_mouse_input);
  36. SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), Mode);
  37. end; { if }
  38. end; { proc. TurnMouseOff }
  39. function GetScreenHeight : DWord;
  40. var
  41. ConsoleInfo: TConsoleScreenBufferinfo;
  42. begin
  43. if (not GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo)) then begin
  44. {$ifdef SYSTEMDEBUG}
  45. Writeln(stderr,'GetScreenHeight failed GetLastError returns ',GetLastError);
  46. Halt(1);
  47. {$endif SYSTEMDEBUG}
  48. // ts: this is really silly assumption; imho better: issue a halt
  49. GetScreenHeight:=25;
  50. end else
  51. GetScreenHeight := ConsoleInfo.dwSize.Y;
  52. end; { func. GetScreenHeight }
  53. function GetScreenWidth : DWord;
  54. var
  55. ConsoleInfo: TConsoleScreenBufferInfo;
  56. begin
  57. if (not GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo)) then begin
  58. {$ifdef SYSTEMDEBUG}
  59. Writeln(stderr,'GetScreenWidth failed GetLastError returns ',GetLastError);
  60. Halt(1);
  61. {$endif SYSTEMDEBUG}
  62. // ts: this is really silly assumption; imho better: issue a halt
  63. GetScreenWidth:=80;
  64. end else
  65. GetScreenWidth := ConsoleInfo.dwSize.X;
  66. end; { func. GetScreenWidth }
  67. procedure GetScreenCursor(var x : DWord; var y : DWord);
  68. var
  69. ConsoleInfo : TConsoleScreenBufferInfo;
  70. begin
  71. FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0);
  72. GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo);
  73. X := ConsoleInfo.dwCursorPosition.X + 1;
  74. Y := ConsoleInfo.dwCursorPosition.Y + 1;
  75. end;
  76. procedure SetScreenCursor(x,y : DWord);
  77. var
  78. CurInfo: TCoord;
  79. begin
  80. FillChar(Curinfo, SizeOf(Curinfo), 0);
  81. CurInfo.X := X - 1;
  82. CurInfo.Y := Y - 1;
  83. SetConsoleCursorPosition(GetStdHandle(STD_OUTPUT_HANDLE), CurInfo);
  84. end;
  85. {****************************************************************************
  86. Public Crt Functions
  87. ****************************************************************************}
  88. procedure TextMode (Mode: word);
  89. begin
  90. {$WARNING TextMode not implemented yet!!}
  91. end;
  92. Procedure TextColor(Color: Byte);
  93. { Switch foregroundcolor }
  94. Begin
  95. TextAttr:=(Color and $8f) or (TextAttr and $70);
  96. End;
  97. Procedure TextBackground(Color: Byte);
  98. { Switch backgroundcolor }
  99. Begin
  100. TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) );
  101. End;
  102. Procedure HighVideo;
  103. { Set highlighted output. }
  104. Begin
  105. TextColor(TextAttr Or $08);
  106. End;
  107. Procedure LowVideo;
  108. { Set normal output }
  109. Begin
  110. TextColor(TextAttr And $77);
  111. End;
  112. Procedure NormVideo;
  113. { Set normal back and foregroundcolors. }
  114. Begin
  115. TextColor(7);
  116. TextBackGround(0);
  117. End;
  118. Procedure GotoXY(X: Byte; Y: Byte);
  119. begin
  120. GotoXY32(X,Y);
  121. end;
  122. Procedure GotoXY32(X: DWord; Y: DWord);
  123. { Go to coordinates X,Y in the current window. }
  124. Begin
  125. If (X > 0) and (X <= (WindMaxX - WindMinX + 1)) and
  126. (Y > 0) and (Y <= (WindMaxY - WindMinY + 1)) Then Begin
  127. Inc(X, WindMinX - 1);
  128. Inc(Y, WindMinY - 1);
  129. SetScreenCursor(x,y);
  130. End;
  131. End;
  132. Procedure Window(X1, Y1, X2, Y2: Byte);
  133. begin
  134. Window32(X1,Y1,X2,Y2);
  135. end;
  136. Procedure Window32(X1, Y1, X2, Y2: DWord);
  137. {
  138. Set screen window to the specified coordinates.
  139. }
  140. Begin
  141. if (X1 > X2) or (X2 > GetScreenWidth) or
  142. (Y1 > Y2) or (Y2 > GetScreenHeight) then
  143. exit;
  144. WindMinY := Y1;
  145. WindMaxY := Y2;
  146. WindMinX := X1;
  147. WindMaxX := X2;
  148. WindMin:=((Y1-1) Shl 8)+(X1-1);
  149. WindMax:=((Y2-1) Shl 8)+(X2-1);
  150. GotoXY(1, 1);
  151. End;
  152. procedure ClrScr;
  153. var
  154. DestCoor: TCoord;
  155. numChars, x : DWord;
  156. begin
  157. DestCoor.X := WindMinX - 1;
  158. DestCoor.Y := WindMinY - 1;
  159. numChars := (WindMaxX - WindMinX + 1);
  160. repeat
  161. FillConsoleOutputAttribute(GetStdHandle(STD_OUTPUT_HANDLE), TextAttr,
  162. numChars, DestCoor, x);
  163. FillConsoleOutputCharacter(GetStdHandle(STD_OUTPUT_HANDLE), #32,
  164. numChars, DestCoor, x);
  165. inc(DestCoor.Y);
  166. until DWord(DestCoor.Y)=WindMaxY;
  167. GotoXY(1, 1);
  168. end; { proc. ClrScr }
  169. procedure ClrEol;
  170. {
  171. Clear from current position to end of line.
  172. }
  173. var
  174. Temp: DWord;
  175. CharInfo: Char;
  176. Coord: TCoord;
  177. X,Y: DWord;
  178. begin
  179. GetScreenCursor(x, y);
  180. CharInfo := #32;
  181. Coord.X := X - 1;
  182. Coord.Y := Y - 1;
  183. FillConsoleOutputCharacter(GetStdHandle(STD_OUTPUT_HANDLE), CharInfo, WindMaxX - X + 1,
  184. Coord, @Temp);
  185. FillConsoleOutputAttribute(GetStdHandle(STD_OUTPUT_HANDLE), TextAttr, WindMaxX - X + 1,
  186. Coord, @Temp);
  187. end;
  188. Function WhereX: Byte;
  189. begin
  190. WhereX:=WhereX32 mod 256;
  191. end;
  192. Function WhereX32: DWord;
  193. {
  194. Return current X-position of cursor.
  195. }
  196. var
  197. x,y : DWord;
  198. Begin
  199. GetScreenCursor(x, y);
  200. WhereX32:= x - WindMinX +1;
  201. End;
  202. Function WhereY: Byte;
  203. begin
  204. WhereY:=WhereY32 mod 256;
  205. end;
  206. Function WhereY32: DWord;
  207. {
  208. Return current Y-position of cursor.
  209. }
  210. var
  211. x, y : DWord;
  212. Begin
  213. GetScreenCursor(x, y);
  214. WhereY32:= y - WindMinY + 1;
  215. End;
  216. {*************************************************************************
  217. KeyBoard
  218. *************************************************************************}
  219. var
  220. ScanCode : char;
  221. SpecialKey : boolean;
  222. DoingNumChars: Boolean;
  223. DoingNumCode: Byte;
  224. Function RemapScanCode (ScanCode: byte; CtrlKeyState: byte; keycode:longint): byte;
  225. { Several remappings of scancodes are necessary to comply with what
  226. we get with MSDOS. Special Windows keys, as Alt-Tab, Ctrl-Esc etc.
  227. are excluded }
  228. var
  229. AltKey, CtrlKey, ShiftKey: boolean;
  230. const
  231. {
  232. Keypad key scancodes:
  233. Ctrl Norm
  234. $77 $47 - Home
  235. $8D $48 - Up arrow
  236. $84 $49 - PgUp
  237. $8E $4A - -
  238. $73 $4B - Left Arrow
  239. $8F $4C - 5
  240. $74 $4D - Right arrow
  241. $4E $4E - +
  242. $75 $4F - End
  243. $91 $50 - Down arrow
  244. $76 $51 - PgDn
  245. $92 $52 - Ins
  246. $93 $53 - Del
  247. }
  248. CtrlKeypadKeys: array[$47..$53] of byte =
  249. ($77, $8D, $84, $8E, $73, $8F, $74, $4E, $75, $91, $76, $92, $93);
  250. begin
  251. AltKey := ((CtrlKeyState AND
  252. (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
  253. CtrlKey := ((CtrlKeyState AND
  254. (RIGHT_CTRL_PRESSED OR LEFT_CTRL_PRESSED)) > 0);
  255. ShiftKey := ((CtrlKeyState AND SHIFT_PRESSED) > 0);
  256. if AltKey then
  257. begin
  258. case ScanCode of
  259. // Digits, -, =
  260. $02..$0D: inc(ScanCode, $76);
  261. // Function keys
  262. $3B..$44: inc(Scancode, $2D);
  263. $57..$58: inc(Scancode, $34);
  264. // Extended cursor block keys
  265. $47..$49, $4B, $4D, $4F..$53:
  266. inc(Scancode, $50);
  267. // Other keys
  268. $1C: Scancode := $A6; // Enter
  269. $35: Scancode := $A4; // / (keypad and normal!)
  270. end
  271. end
  272. else if CtrlKey then
  273. case Scancode of
  274. // Tab key
  275. $0F: Scancode := $94;
  276. // Function keys
  277. $3B..$44: inc(Scancode, $23);
  278. $57..$58: inc(Scancode, $32);
  279. // Keypad keys
  280. $35: Scancode := $95; // \
  281. $37: Scancode := $96; // *
  282. $47..$53: Scancode := CtrlKeypadKeys[Scancode];
  283. end
  284. else if ShiftKey then
  285. case Scancode of
  286. // Function keys
  287. $3B..$44: inc(Scancode, $19);
  288. $57..$58: inc(Scancode, $30);
  289. end
  290. else
  291. case Scancode of
  292. // Function keys
  293. $57..$58: inc(Scancode, $2E); // F11 and F12
  294. end;
  295. RemapScanCode := ScanCode;
  296. end;
  297. function KeyPressed : boolean;
  298. var
  299. nevents,nread : dword;
  300. buf : TINPUTRECORD;
  301. AltKey: Boolean;
  302. c : longint;
  303. begin
  304. KeyPressed := FALSE;
  305. if ScanCode <> #0 then
  306. KeyPressed := TRUE
  307. else
  308. begin
  309. GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents);
  310. while nevents>0 do
  311. begin
  312. ReadConsoleInputA(TextRec(input).Handle,buf,1,nread);
  313. if buf.EventType = KEY_EVENT then
  314. if buf.Event.KeyEvent.bKeyDown then
  315. begin
  316. { Alt key is VK_MENU }
  317. { Capslock key is VK_CAPITAL }
  318. AltKey := ((Buf.Event.KeyEvent.dwControlKeyState AND
  319. (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
  320. if not(Buf.Event.KeyEvent.wVirtualKeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL,
  321. VK_CAPITAL, VK_NUMLOCK,
  322. VK_SCROLL]) then
  323. begin
  324. keypressed:=true;
  325. if (ord(buf.Event.KeyEvent.AsciiChar) = 0) or
  326. (buf.Event.KeyEvent.dwControlKeyState and (LEFT_ALT_PRESSED or ENHANCED_KEY) > 0) then
  327. begin
  328. SpecialKey := TRUE;
  329. ScanCode := Chr(RemapScanCode(Buf.Event.KeyEvent.wVirtualScanCode, Buf.Event.KeyEvent.dwControlKeyState,
  330. Buf.Event.KeyEvent.wVirtualKeyCode));
  331. end
  332. else
  333. begin
  334. { Map shift-tab }
  335. if (buf.Event.KeyEvent.AsciiChar=#9) and
  336. (buf.Event.KeyEvent.dwControlKeyState and SHIFT_PRESSED > 0) then
  337. begin
  338. SpecialKey := TRUE;
  339. ScanCode := #15;
  340. end
  341. else
  342. begin
  343. SpecialKey := FALSE;
  344. ScanCode := Chr(Ord(buf.Event.KeyEvent.AsciiChar));
  345. end;
  346. end;
  347. if AltKey then
  348. begin
  349. case Buf.Event.KeyEvent.wVirtualScanCode of
  350. 71 : c:=7;
  351. 72 : c:=8;
  352. 73 : c:=9;
  353. 75 : c:=4;
  354. 76 : c:=5;
  355. 77 : c:=6;
  356. 79 : c:=1;
  357. 80 : c:=2;
  358. 81 : c:=3;
  359. 82 : c:=0;
  360. else
  361. break;
  362. end;
  363. DoingNumChars := true;
  364. DoingNumCode := Byte((DoingNumCode * 10) + c);
  365. Keypressed := false;
  366. Specialkey := false;
  367. ScanCode := #0;
  368. end
  369. else
  370. break;
  371. end;
  372. end
  373. else
  374. begin
  375. if (Buf.Event.KeyEvent.wVirtualKeyCode in [VK_MENU]) then
  376. if DoingNumChars then
  377. if DoingNumCode > 0 then
  378. begin
  379. ScanCode := Chr(DoingNumCode);
  380. Keypressed := true;
  381. DoingNumChars := false;
  382. DoingNumCode := 0;
  383. break
  384. end; { if }
  385. end;
  386. { if we got a key then we can exit }
  387. if keypressed then
  388. exit;
  389. GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents);
  390. end;
  391. end;
  392. end;
  393. function ReadKey: char;
  394. begin
  395. while (not KeyPressed) do
  396. Sleep(1);
  397. if SpecialKey then begin
  398. ReadKey := #0;
  399. SpecialKey := FALSE;
  400. end else begin
  401. ReadKey := ScanCode;
  402. ScanCode := #0;
  403. end;
  404. end;
  405. {*************************************************************************
  406. Delay
  407. *************************************************************************}
  408. procedure Delay(MS: Word);
  409. begin
  410. Sleep(ms);
  411. end; { proc. Delay }
  412. procedure sound(hz : word);
  413. begin
  414. MessageBeep(0); { lame ;-) }
  415. end;
  416. procedure nosound;
  417. begin
  418. end;
  419. {****************************************************************************
  420. HighLevel Crt Functions
  421. ****************************************************************************}
  422. procedure removeline(y : DWord);
  423. var
  424. ClipRect: TSmallRect;
  425. SrcRect: TSmallRect;
  426. DestCoor: TCoord;
  427. CharInfo: TCharInfo;
  428. begin
  429. CharInfo.UnicodeChar := #32;
  430. CharInfo.Attributes := TextAttr;
  431. Y := (WindMinY - 1) + (Y - 1) + 1;
  432. SrcRect.Top := Y;
  433. SrcRect.Left := WindMinX - 1;
  434. SrcRect.Right := WindMaxX - 1;
  435. SrcRect.Bottom := WindMaxY - 1;
  436. DestCoor.X := WindMinX - 1;
  437. DestCoor.Y := Y - 1;
  438. ClipRect := SrcRect;
  439. cliprect.top := destcoor.y;
  440. ScrollConsoleScreenBuffer(GetStdHandle(STD_OUTPUT_HANDLE), SrcRect, ClipRect,
  441. DestCoor, CharInfo);
  442. end; { proc. RemoveLine }
  443. procedure delline;
  444. begin
  445. removeline(wherey);
  446. end; { proc. DelLine }
  447. procedure insline;
  448. var
  449. ClipRect: TSmallRect;
  450. SrcRect: TSmallRect;
  451. DestCoor: TCoord;
  452. CharInfo: TCharInfo;
  453. X,Y: DWord;
  454. begin
  455. GetScreenCursor(X, Y);
  456. CharInfo.UnicodeChar := #32;
  457. CharInfo.Attributes := TextAttr;
  458. SrcRect.Top := Y - 1;
  459. SrcRect.Left := WindMinX - 1;
  460. SrcRect.Right := WindMaxX - 1;
  461. SrcRect.Bottom := WindMaxY - 1 + 1;
  462. DestCoor.X := WindMinX - 1;
  463. DestCoor.Y := Y;
  464. ClipRect := SrcRect;
  465. ClipRect.Bottom := WindMaxY - 1;
  466. ScrollConsoleScreenBuffer(GetStdHandle(STD_OUTPUT_HANDLE), SrcRect, ClipRect,
  467. DestCoor, CharInfo);
  468. end; { proc. InsLine }
  469. {****************************************************************************
  470. Extra Crt Functions
  471. ****************************************************************************}
  472. procedure cursoron;
  473. var CursorInfo: TConsoleCursorInfo;
  474. begin
  475. GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
  476. CursorInfo.dwSize := SaveCursorSize;
  477. CursorInfo.bVisible := true;
  478. SetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
  479. end;
  480. procedure cursoroff;
  481. var CursorInfo: TConsoleCursorInfo;
  482. begin
  483. GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
  484. CursorInfo.bVisible := false;
  485. SetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
  486. end;
  487. procedure cursorbig;
  488. var CursorInfo: TConsoleCursorInfo;
  489. begin
  490. GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
  491. CursorInfo.dwSize := 93;
  492. CursorInfo.bVisible := true;
  493. SetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
  494. end;
  495. {*****************************************************************************
  496. Read and Write routines
  497. *****************************************************************************}
  498. var
  499. CurrX, CurrY : DWord;
  500. procedure WriteChar(c : char);
  501. var
  502. WritePos: Coord; { Upper-left cell to write from }
  503. numWritten : DWord;
  504. WinAttr : word;
  505. begin
  506. Case C of
  507. #10 : begin
  508. Inc(CurrY);
  509. end;
  510. #13 : begin
  511. CurrX := WindMinX;
  512. end; { if }
  513. #08 : begin
  514. if CurrX > WindMinX then Dec(CurrX);
  515. end; { ^H }
  516. #07 : begin
  517. //MessagBeep(0);
  518. end; { ^G }
  519. else begin
  520. WritePos.X := currX - 1;
  521. WritePos.Y := currY - 1;
  522. WriteConsoleOutputCharacter(GetStdhandle(STD_OUTPUT_HANDLE),
  523. @c, 1, writePos, numWritten);
  524. WinAttr:=TextAttr;
  525. WriteConsoleOutputAttribute(GetStdhandle(STD_OUTPUT_HANDLE),
  526. @WinAttr, 1, writePos, numWritten);
  527. Inc(CurrX);
  528. end; { else }
  529. end; { case }
  530. if CurrX > WindMaxX then begin
  531. CurrX := WindMinX;
  532. Inc(CurrY);
  533. end; { if }
  534. While CurrY > WindMaxY do begin
  535. RemoveLine(1);
  536. Dec(CurrY);
  537. end; { while }
  538. end;
  539. procedure WriteStr(const s: string);
  540. var
  541. WritePos: Coord; { Upper-left cell to write from }
  542. numWritten : DWord;
  543. WinAttr : word;
  544. i: integer;
  545. begin
  546. WritePos.X := currX - 1;
  547. WritePos.Y := currY - 1;
  548. WriteConsoleOutputCharacter(GetStdhandle(STD_OUTPUT_HANDLE), @s[1], Length(s), writePos, numWritten);
  549. WinAttr:=TextAttr;
  550. dec(WritePos.X);
  551. for i:=0 to Length(s)-1 do
  552. begin
  553. inc(WritePos.X);
  554. WriteConsoleOutputAttribute(GetStdhandle(STD_OUTPUT_HANDLE),@WinAttr, 1, writePos, numWritten);
  555. end;
  556. Inc(CurrX,Length(s));
  557. end;
  558. Function CrtWrite(var f : textrec) : integer;
  559. var
  560. i : longint;
  561. s : string;
  562. OldConsoleOutputCP : Word;
  563. begin
  564. OldConsoleOutputCP:=GetConsoleOutputCP;
  565. SetConsoleOutputCP(GetACP);
  566. GetScreenCursor(CurrX, CurrY);
  567. s:='';
  568. for i:=0 to f.bufpos-1 do
  569. if f.buffer[i] in [#7,#8,#10,#13] then // special chars directly.
  570. begin
  571. if s<>'' then
  572. begin
  573. WriteStr(s);
  574. s:='';
  575. end;
  576. WriteChar(f.buffer[i]);
  577. end
  578. else
  579. s:=s+f.buffer[i];
  580. if s<>'' then
  581. WriteStr(s);
  582. SetScreenCursor(CurrX, CurrY);
  583. SetConsoleOutputCP(OldConsoleOutputCP);
  584. f.bufpos:=0;
  585. CrtWrite:=0;
  586. end;
  587. Function CrtRead(Var F: TextRec): Integer;
  588. procedure BackSpace;
  589. begin
  590. if (f.bufpos>0) and (f.bufpos=f.bufend) then begin
  591. WriteChar(#8);
  592. WriteChar(' ');
  593. WriteChar(#8);
  594. dec(f.bufpos);
  595. dec(f.bufend);
  596. end;
  597. end;
  598. var
  599. ch : Char;
  600. OldConsoleOutputCP : Word;
  601. Begin
  602. OldConsoleOutputCP:=GetConsoleOutputCP;
  603. SetConsoleOutputCP(GetACP);
  604. GetScreenCursor(CurrX,CurrY);
  605. f.bufpos:=0;
  606. f.bufend:=0;
  607. repeat
  608. if f.bufpos>f.bufend then
  609. f.bufend:=f.bufpos;
  610. SetScreenCursor(CurrX,CurrY);
  611. ch:=readkey;
  612. case ch of
  613. #0 : case readkey of
  614. #71 : while f.bufpos>0 do begin
  615. dec(f.bufpos);
  616. WriteChar(#8);
  617. end;
  618. #75 : if f.bufpos>0 then begin
  619. dec(f.bufpos);
  620. WriteChar(#8);
  621. end;
  622. #77 : if f.bufpos<f.bufend then begin
  623. WriteChar(f.bufptr^[f.bufpos]);
  624. inc(f.bufpos);
  625. end;
  626. #79 : while f.bufpos<f.bufend do begin
  627. WriteChar(f.bufptr^[f.bufpos]);
  628. inc(f.bufpos);
  629. end;
  630. #28: begin // numpad enter
  631. WriteChar(#13);
  632. WriteChar(#10);
  633. f.bufptr^[f.bufend]:=#13;
  634. f.bufptr^[f.bufend+1]:=#10;
  635. inc(f.bufend,2);
  636. break;
  637. end;
  638. #53: begin
  639. ch:='/';
  640. if f.bufpos<f.bufsize-2 then begin
  641. f.buffer[f.bufpos]:=ch;
  642. inc(f.bufpos);
  643. WriteChar(ch);
  644. end;
  645. end;
  646. end;
  647. ^S,
  648. #8 : BackSpace;
  649. ^Y,
  650. #27 : begin
  651. while f.bufpos<f.bufend do begin
  652. WriteChar(f.bufptr^[f.bufpos]);
  653. inc(f.bufpos);
  654. end;
  655. while f.bufend>0 do
  656. BackSpace;
  657. end;
  658. #13 : begin
  659. WriteChar(#13);
  660. WriteChar(#10);
  661. f.bufptr^[f.bufend]:=#13;
  662. f.bufptr^[f.bufend+1]:=#10;
  663. inc(f.bufend,2);
  664. break;
  665. end;
  666. #26 : if CheckEOF then begin
  667. f.bufptr^[f.bufend]:=#26;
  668. inc(f.bufend);
  669. break;
  670. end;
  671. else begin
  672. if f.bufpos<f.bufsize-2 then begin
  673. f.bufptr^[f.bufpos]:=ch;
  674. inc(f.bufpos);
  675. WriteChar(ch);
  676. end;
  677. end;
  678. end;
  679. until false;
  680. SetConsoleOutputCP(OldConsoleOutputCP);
  681. f.bufpos:=0;
  682. SetScreenCursor(CurrX, CurrY);
  683. CrtRead:=0;
  684. End;
  685. Function CrtReturn(Var F:TextRec):Integer;
  686. Begin
  687. CrtReturn:=0;
  688. end;
  689. Function CrtClose(Var F: TextRec): Integer;
  690. Begin
  691. F.Mode:=fmClosed;
  692. CrtClose:=0;
  693. End;
  694. Function CrtOpen(Var F: TextRec): Integer;
  695. Begin
  696. If F.Mode=fmOutput Then begin
  697. TextRec(F).InOutFunc:=@CrtWrite;
  698. TextRec(F).FlushFunc:=@CrtWrite;
  699. end Else begin
  700. F.Mode:=fmInput;
  701. TextRec(F).InOutFunc:=@CrtRead;
  702. TextRec(F).FlushFunc:=@CrtReturn;
  703. end;
  704. TextRec(F).CloseFunc:=@CrtClose;
  705. CrtOpen:=0;
  706. End;
  707. procedure AssignCrt(var F: Text);
  708. begin
  709. Assign(F,'');
  710. TextRec(F).OpenFunc:=@CrtOpen;
  711. end;
  712. var
  713. CursorInfo : TConsoleCursorInfo;
  714. ConsoleInfo : TConsoleScreenBufferinfo;
  715. // ts
  716. begin
  717. { Initialize the output handles }
  718. LastMode := 3;
  719. SetActiveWindow(0);
  720. {--------------------- Get the cursor size and such -----------------------}
  721. FillChar(CursorInfo, SizeOf(CursorInfo), 00);
  722. GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
  723. SaveCursorSize := CursorInfo.dwSize;
  724. {------------------ Get the current cursor position and attr --------------}
  725. FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0);
  726. GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo);
  727. TextAttr := ConsoleInfo.wAttributes;
  728. { Not required, the dos crt does also not touch the mouse }
  729. {TurnMouseOff;}
  730. WindMinX := (ConsoleInfo.srWindow.Left) + 1;
  731. WindMinY := (ConsoleInfo.srWindow.Top) + 1;
  732. WindMaxX := (ConsoleInfo.srWindow.Right) + 1;
  733. WindMaxY := (ConsoleInfo.srWindow.Bottom) + 1;
  734. WindMax:=((WindMaxY-1) Shl 8)+(WindMaxX-1);
  735. DoingNumChars := false;
  736. DoingNumCode := 0;
  737. { Redirect the standard output }
  738. AssignCrt(Output);
  739. Rewrite(Output);
  740. TextRec(Output).Handle:= GetStdHandle(STD_OUTPUT_HANDLE);
  741. AssignCrt(Input);
  742. Reset(Input);
  743. TextRec(Input).Handle:= GetStdHandle(STD_INPUT_HANDLE);
  744. end. { unit Crt }