crt.pp 21 KB

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