2
0

video.pp 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by Florian Klaempfl
  5. member of the Free Pascal development team
  6. Video unit for linux
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12. **********************************************************************}
  13. unit Video;
  14. interface
  15. {$i videoh.inc}
  16. implementation
  17. uses
  18. BaseUnix, Unix, Strings, TermInfo;
  19. {$i video.inc}
  20. Type TConsoleType = (ttyNetwork,ttyLinux,ttyFreeBSD,ttyNetBSD);
  21. var
  22. LastCursorType : byte;
  23. TtyFd: Longint;
  24. Console: TConsoleType;
  25. {$ifdef logging}
  26. f: file;
  27. const
  28. logstart: string = '';
  29. nl: char = #10;
  30. logend: string = #10#10;
  31. {$endif logging}
  32. {$ifdef cpui386}
  33. {$ASMMODE ATT}
  34. {$endif cpui386}
  35. const
  36. can_delete_term : boolean = false;
  37. ACSIn : string = '';
  38. ACSOut : string = '';
  39. InACS : boolean =false;
  40. function IsACS(var ch,ACSchar : char): boolean;
  41. begin
  42. IsACS:=false;
  43. case ch of
  44. #24, #30: {}
  45. ch:='^';
  46. #25, #31: {}
  47. ch:='v';
  48. #26, #16: {Never introduce a ctrl-Z ... }
  49. ch:='>';
  50. {#27,needed in Escape sequences} #17: {}
  51. ch:='<';
  52. #176, #177, #178: {°±²}
  53. begin
  54. IsACS:=true;
  55. ACSChar:='a';
  56. end;
  57. #180, #181, #182, #185: {´µ¶¹}
  58. begin
  59. IsACS:=true;
  60. ACSChar:='u';
  61. end;
  62. #183, #184, #187, #191: {·¸»¿}
  63. begin
  64. IsACS:=true;
  65. ACSChar:='k';
  66. end;
  67. #188, #189, #190, #217: {¼½¾Ù}
  68. begin
  69. IsACS:=true;
  70. ACSChar:='j';
  71. end;
  72. #192, #200, #211, #212: {ÀÈÓÔ}
  73. begin
  74. IsACS:=true;
  75. ACSChar:='m';
  76. end;
  77. #193, #202, #207, #208: {ÁÊÏÐ}
  78. begin
  79. IsACS:=true;
  80. ACSChar:='v';
  81. end;
  82. #194, #203, #209, #210: {ÂËÑÒ}
  83. begin
  84. IsACS:=true;
  85. ACSChar:='w';
  86. end;
  87. #195, #198, #199, #204: {ÃÆÇÌ}
  88. begin
  89. IsACS:=true;
  90. ACSChar:='t';
  91. end;
  92. #196, #205: {ÄÍ}
  93. begin
  94. IsACS:=true;
  95. ACSChar:='q';
  96. end;
  97. #179, #186: {³º}
  98. begin
  99. IsACS:=true;
  100. ACSChar:='x';
  101. end;
  102. #197, #206, #215, #216: {ÅÎר}
  103. begin
  104. IsACS:=true;
  105. ACSChar:='n';
  106. end;
  107. #201, #213, #214, #218: {ÉÕÖÚ}
  108. begin
  109. IsACS:=true;
  110. ACSChar:='l';
  111. end;
  112. #254: { þ }
  113. begin
  114. ch:='*';
  115. end;
  116. { Shadows for Buttons }
  117. #220: { Ü }
  118. begin
  119. IsACS:=true;
  120. ACSChar:='a';
  121. end;
  122. #223: { ß }
  123. begin
  124. IsACS:=true;
  125. ACSChar:='a';
  126. end;
  127. end;
  128. end;
  129. function SendEscapeSeqNdx(Ndx: Word) : boolean;
  130. var
  131. P,pdelay: PChar;
  132. begin
  133. SendEscapeSeqNdx:=false;
  134. if not assigned(cur_term_Strings) then
  135. exit{RunError(219)};
  136. P:=cur_term_Strings^[Ndx];
  137. if assigned(p) then
  138. begin { Do not transmit the delays }
  139. pdelay:=strpos(p,'$<');
  140. if assigned(pdelay) then
  141. pdelay^:=#0;
  142. fpWrite(stdoutputhandle, P^, StrLen(P));
  143. SendEscapeSeqNdx:=true;
  144. if assigned(pdelay) then
  145. pdelay^:='$';
  146. end;
  147. end;
  148. procedure SendEscapeSeq(const S: String);
  149. begin
  150. fpWrite(stdoutputhandle, S[1], Length(S));
  151. end;
  152. Function IntStr(l:longint):string;
  153. var
  154. s : string;
  155. begin
  156. Str(l,s);
  157. IntStr:=s;
  158. end;
  159. Function XY2Ansi(x,y,ox,oy:longint):String;
  160. {
  161. Returns a string with the escape sequences to go to X,Y on the screen
  162. }
  163. Begin
  164. if y=oy then
  165. begin
  166. if x=ox then
  167. begin
  168. XY2Ansi:='';
  169. exit;
  170. end;
  171. if x=1 then
  172. begin
  173. XY2Ansi:=#13;
  174. exit;
  175. end;
  176. if x>ox then
  177. begin
  178. XY2Ansi:=#27'['+IntStr(x-ox)+'C';
  179. exit;
  180. end
  181. else
  182. begin
  183. XY2Ansi:=#27'['+IntStr(ox-x)+'D';
  184. exit;
  185. end;
  186. end;
  187. if x=ox then
  188. begin
  189. if y>oy then
  190. begin
  191. XY2Ansi:=#27'['+IntStr(y-oy)+'B';
  192. exit;
  193. end
  194. else
  195. begin
  196. XY2Ansi:=#27'['+IntStr(oy-y)+'A';
  197. exit;
  198. end;
  199. end;
  200. if ((x=1) and (oy+1=y)) and (console<>ttyfreebsd) then
  201. XY2Ansi:=#13#10
  202. else
  203. XY2Ansi:=#27'['+IntStr(y)+';'+IntStr(x)+'H';
  204. End;
  205. const
  206. AnsiTbl : string[8]='04261537';
  207. Function Attr2Ansi(Attr,OAttr:longint):string;
  208. {
  209. Convert Attr to an Ansi String, the Optimal code is calculate
  210. with use of the old OAttr
  211. }
  212. var
  213. hstr : string[16];
  214. OFg,OBg,Fg,Bg : longint;
  215. procedure AddSep(ch:char);
  216. begin
  217. if length(hstr)>0 then
  218. hstr:=hstr+';';
  219. hstr:=hstr+ch;
  220. end;
  221. begin
  222. if Attr=OAttr then
  223. begin
  224. Attr2Ansi:='';
  225. exit;
  226. end;
  227. Hstr:='';
  228. Fg:=Attr and $f;
  229. Bg:=Attr shr 4;
  230. OFg:=OAttr and $f;
  231. OBg:=OAttr shr 4;
  232. if (OFg<>7) or (Fg=7) or ((OFg>7) and (Fg<8)) or ((OBg>7) and (Bg<8)) then
  233. begin
  234. hstr:='0';
  235. OFg:=7;
  236. OBg:=0;
  237. end;
  238. if (Fg>7) and (OFg<8) then
  239. begin
  240. AddSep('1');
  241. OFg:=OFg or 8;
  242. end;
  243. if (Bg and 8)<>(OBg and 8) then
  244. begin
  245. AddSep('5');
  246. OBg:=OBg or 8;
  247. end;
  248. if (Fg<>OFg) then
  249. begin
  250. AddSep('3');
  251. hstr:=hstr+AnsiTbl[(Fg and 7)+1];
  252. end;
  253. if (Bg<>OBg) then
  254. begin
  255. AddSep('4');
  256. hstr:=hstr+AnsiTbl[(Bg and 7)+1];
  257. end;
  258. if hstr='0' then
  259. hstr:='';
  260. Attr2Ansi:=#27'['+hstr+'m';
  261. end;
  262. procedure UpdateTTY(Force:boolean);
  263. type
  264. tchattr=packed record
  265. {$ifdef ENDIAN_LITTLE}
  266. ch : char;
  267. attr : byte;
  268. {$else}
  269. attr : byte;
  270. ch : char;
  271. {$endif}
  272. end;
  273. var
  274. outbuf : array[0..1023+255] of char;
  275. chattr : tchattr;
  276. skipped : boolean;
  277. outptr,
  278. spaces,
  279. eol,
  280. x,y,
  281. LastX,LastY,
  282. SpaceAttr,
  283. LastAttr : longint;
  284. p,pold : pvideocell;
  285. LastLineWidth : Longint;
  286. procedure TransformUsingACS(var st : string);
  287. var
  288. res : string;
  289. i : longint;
  290. ch,ACSch : char;
  291. begin
  292. res:='';
  293. for i:=1 to length(st) do
  294. begin
  295. ch:=st[i];
  296. if IsACS(ch,ACSch) then
  297. begin
  298. if not InACS then
  299. begin
  300. res:=res+ACSIn;
  301. InACS:=true;
  302. end;
  303. res:=res+ACSch;
  304. end
  305. else
  306. begin
  307. if InACS then
  308. begin
  309. res:=res+ACSOut+Attr2Ansi(LastAttr,0);
  310. InACS:=false;
  311. end;
  312. res:=res+ch;
  313. end;
  314. end;
  315. st:=res;
  316. end;
  317. procedure outdata(hstr:string);
  318. begin
  319. If Length(HStr)>0 Then
  320. Begin
  321. while (eol>0) do
  322. begin
  323. hstr:=#13#10+hstr;
  324. dec(eol);
  325. end;
  326. if NoExtendedFrame and (ACSIn<>'') and (ACSOut<>'') then
  327. TransformUsingACS(Hstr);
  328. move(hstr[1],outbuf[outptr],length(hstr));
  329. inc(outptr,length(hstr));
  330. if outptr>=1024 then
  331. begin
  332. {$ifdef logging}
  333. blockwrite(f,logstart[1],length(logstart));
  334. blockwrite(f,nl,1);
  335. blockwrite(f,outptr,sizeof(outptr));
  336. blockwrite(f,nl,1);
  337. blockwrite(f,outbuf,outptr);
  338. blockwrite(f,nl,1);
  339. {$endif logging}
  340. fpWrite(stdoutputhandle,outbuf,outptr);
  341. outptr:=0;
  342. end;
  343. end;
  344. end;
  345. procedure OutClr(c:byte);
  346. begin
  347. if c=LastAttr then
  348. exit;
  349. OutData(Attr2Ansi(c,LastAttr));
  350. LastAttr:=c;
  351. end;
  352. procedure OutSpaces;
  353. begin
  354. if (Spaces=0) then
  355. exit;
  356. OutClr(SpaceAttr);
  357. OutData(Space(Spaces));
  358. LastX:=x;
  359. LastY:=y;
  360. Spaces:=0;
  361. end;
  362. function GetTermString(ndx:word):String;
  363. var
  364. P,pdelay: PChar;
  365. begin
  366. GetTermString:='';
  367. if not assigned(cur_term_Strings) then
  368. exit{RunError(219)};
  369. P:=cur_term_Strings^[Ndx];
  370. if assigned(p) then
  371. begin { Do not transmit the delays }
  372. pdelay:=strpos(p,'$<');
  373. if assigned(pdelay) then
  374. pdelay^:=#0;
  375. GetTermString:=StrPas(p);
  376. if assigned(pdelay) then
  377. pdelay^:='$';
  378. end;
  379. end;
  380. begin
  381. OutPtr:=0;
  382. Eol:=0;
  383. skipped:=true;
  384. p:=PVideoCell(VideoBuf);
  385. pold:=PVideoCell(OldVideoBuf);
  386. { init Attr, X,Y and set autowrap off }
  387. SendEscapeSeq(#27'[m'#27'[?7l'{#27'[H'} );
  388. // 1.0.x: SendEscapeSeq(#27'[m'{#27'[H'});
  389. LastAttr:=7;
  390. LastX:=-1;
  391. LastY:=-1;
  392. for y:=1 to ScreenHeight do
  393. begin
  394. SpaceAttr:=0;
  395. Spaces:=0;
  396. LastLineWidth:=ScreenWidth;
  397. If (y=ScreenHeight) And (Console=ttyFreeBSD) {And :am: is on} Then
  398. LastLineWidth:=ScreenWidth-2;
  399. for x:=1 to LastLineWidth do
  400. begin
  401. if (not force) and (p^=pold^) then
  402. begin
  403. if (Spaces>0) then
  404. OutSpaces;
  405. skipped:=true;
  406. end
  407. else
  408. begin
  409. if skipped then
  410. begin
  411. OutData(XY2Ansi(x,y,LastX,LastY));
  412. LastX:=x;
  413. LastY:=y;
  414. skipped:=false;
  415. end;
  416. chattr:=tchattr(p^);
  417. if chattr.ch in [#0,#255] then
  418. chattr.ch:=' ';
  419. if chattr.ch=' ' then
  420. begin
  421. if Spaces=0 then
  422. SpaceAttr:=chattr.Attr;
  423. if (chattr.attr and $f0)=(spaceattr and $f0) then
  424. chattr.Attr:=SpaceAttr
  425. else
  426. begin
  427. OutSpaces;
  428. SpaceAttr:=chattr.Attr;
  429. end;
  430. inc(Spaces);
  431. end
  432. else
  433. begin
  434. if (Spaces>0) then
  435. OutSpaces;
  436. if ord(chattr.ch)<32 then
  437. begin
  438. Chattr.Attr:= $ff xor Chattr.Attr;
  439. ChAttr.ch:= chr(ord(chattr.ch)+ord('A')-1);
  440. end;
  441. if LastAttr<>chattr.Attr then
  442. OutClr(chattr.Attr);
  443. OutData(chattr.ch);
  444. LastX:=x+1;
  445. LastY:=y;
  446. end;
  447. p^:=tvideocell(chattr);
  448. end;
  449. inc(p);
  450. inc(pold);
  451. end;
  452. if (Spaces>0) then
  453. OutSpaces;
  454. if force then
  455. inc(eol)
  456. else
  457. skipped:=true;
  458. end;
  459. eol:=0;
  460. {if am in capabilities? Then}
  461. If (Console=ttyFreeBSD) and (Plongint(p)^<>plongint(pold)^) Then
  462. Begin
  463. OutData(XY2Ansi(ScreenWidth,ScreenHeight,LastX,LastY));
  464. OutData(#8);
  465. {Output last char}
  466. chattr:=tchattr(p[1]);
  467. if LastAttr<>chattr.Attr then
  468. OutClr(chattr.Attr);
  469. OutData(chattr.ch);
  470. inc(LastX);
  471. // OutData(XY2Ansi(ScreenWidth-1,ScreenHeight,LastX,LastY));
  472. // OutData(GetTermString(Insert_character));
  473. OutData(#8+#27+'[1@');
  474. chattr:=tchattr(p^);
  475. if LastAttr<>chattr.Attr then
  476. OutClr(chattr.Attr);
  477. OutData(chattr.ch);
  478. inc(LastX);
  479. end;
  480. OutData(XY2Ansi(CursorX,CursorY,LastX,LastY));
  481. {$ifdef logging}
  482. blockwrite(f,logstart[1],length(logstart));
  483. blockwrite(f,nl,1);
  484. blockwrite(f,outptr,sizeof(outptr));
  485. blockwrite(f,nl,1);
  486. blockwrite(f,outbuf,outptr);
  487. blockwrite(f,nl,1);
  488. {$endif logging}
  489. fpWrite(stdoutputhandle,outbuf,outptr);
  490. if InACS then
  491. SendEscapeSeqNdx(exit_alt_charset_mode);
  492. {turn autowrap on}
  493. // SendEscapeSeq(#27'[?7h');
  494. end;
  495. var
  496. InitialVideoTio, preInitVideoTio, postInitVideoTio: Unix.termios;
  497. inputRaw, outputRaw: boolean;
  498. procedure saveRawSettings(const tio: Unix.termios);
  499. Begin
  500. with tio do
  501. begin
  502. inputRaw :=
  503. ((c_iflag and (IGNBRK or BRKINT or PARMRK or ISTRIP or
  504. INLCR or IGNCR or ICRNL or IXON)) = 0) and
  505. ((c_lflag and (ECHO or ECHONL or ICANON or ISIG or IEXTEN)) = 0);
  506. outPutRaw :=
  507. ((c_oflag and OPOST) = 0) and
  508. ((c_cflag and (CSIZE or PARENB)) = 0) and
  509. ((c_cflag and CS8) <> 0);
  510. end;
  511. end;
  512. procedure restoreRawSettings(tio: Unix.termios);
  513. begin
  514. with tio do
  515. begin
  516. if inputRaw then
  517. begin
  518. c_iflag := c_iflag and (not (IGNBRK or BRKINT or PARMRK or ISTRIP or
  519. INLCR or IGNCR or ICRNL or IXON));
  520. c_lflag := c_lflag and
  521. (not (ECHO or ECHONL or ICANON or ISIG or IEXTEN));
  522. end;
  523. if outPutRaw then
  524. begin
  525. c_oflag := c_oflag and not(OPOST);
  526. c_cflag := c_cflag and not(CSIZE or PARENB) or CS8;
  527. end;
  528. end;
  529. TCSetAttr(1,TCSANOW,tio);
  530. end;
  531. procedure TargetEntry;
  532. begin
  533. TCGetAttr(1,InitialVideoTio);
  534. end;
  535. procedure TargetExit;
  536. begin
  537. TCSetAttr(1,TCSANOW,InitialVideoTio);
  538. end;
  539. procedure prepareInitVideo;
  540. begin
  541. TCGetAttr(1,preInitVideoTio);
  542. saveRawSettings(preInitVideoTio);
  543. end;
  544. procedure videoInitDone;
  545. begin
  546. TCGetAttr(1,postInitVideoTio);
  547. restoreRawSettings(postInitVideoTio);
  548. end;
  549. procedure prepareDoneVideo;
  550. var
  551. tio: Unix.termios;
  552. begin
  553. TCGetAttr(1,tio);
  554. saveRawSettings(tio);
  555. TCSetAttr(1,TCSANOW,postInitVideoTio);
  556. end;
  557. procedure doneVideoDone;
  558. begin
  559. restoreRawSettings(preInitVideoTio);
  560. end;
  561. procedure SysInitVideo;
  562. const
  563. fontstr : string[3]=#27'(K';
  564. var
  565. ThisTTY: String[30];
  566. FName: String;
  567. WS: packed record
  568. ws_row, ws_col, ws_xpixel, ws_ypixel: Word;
  569. end;
  570. Err: Longint;
  571. prev_term : TerminalCommon_ptr1;
  572. begin
  573. {$ifndef CPUI386}
  574. LowAscii:=false;
  575. {$endif CPUI386}
  576. { check for tty }
  577. ThisTTY:=TTYName(stdinputhandle);
  578. if IsATTY(stdinputhandle) then
  579. begin
  580. { save current terminal characteristics and remove rawness }
  581. prepareInitVideo;
  582. { write code to set a correct font }
  583. fpWrite(stdoutputhandle,fontstr[1],length(fontstr));
  584. { running on a tty, find out whether locally or remotely }
  585. TTyfd:=-1;
  586. Console:=TTyNetwork; {Default: Network or other vtxxx tty}
  587. if (Copy(ThisTTY, 1, 8) = '/dev/tty') and
  588. not (ThisTTY[9] IN ['p'..'u','P']) then // FreeBSD has these
  589. begin
  590. { running on the console }
  591. Case ThisTTY[9] of
  592. '0'..'9' : begin { running Linux on native console or native-emulation }
  593. FName:='/dev/vcsa' + ThisTTY[9];
  594. TTYFd:=fpOpen(FName, Octal(666), Open_RdWr); { open console }
  595. IF TTYFd <>-1 Then
  596. Console:=ttyLinux;
  597. end;
  598. 'v' : { check for (Free?)BSD native}
  599. If (ThisTTY[10]>='0') and (ThisTTY[10]<='9') Then
  600. Console:=ttyFreeBSD; {TTYFd ?}
  601. end;
  602. end;
  603. If (Copy(fpGetEnv('TERM'),1,4)='cons') Then // cons<lines>
  604. Console:=ttyFreeBSD;
  605. If Console<>ttylinux Then
  606. begin
  607. { running on a remote terminal, no error with /dev/vcsa }
  608. LowAscii:=false;
  609. //TTYFd:=stdoutputhandle;
  610. end;
  611. fpioctl(stdinputhandle, TIOCGWINSZ, @WS);
  612. if WS.ws_Col=0 then
  613. WS.ws_Col:=80;
  614. if WS.ws_Row=0 then
  615. WS.ws_Row:=25;
  616. ScreenWidth:=WS.ws_Col;
  617. { TDrawBuffer only has FVMaxWidth elements
  618. larger values lead to crashes }
  619. if ScreenWidth> FVMaxWidth then
  620. ScreenWidth:=FVMaxWidth;
  621. ScreenHeight:=WS.ws_Row;
  622. CursorX:=1;
  623. CursorY:=1;
  624. LastCursorType:=$ff;
  625. ScreenColor:=True;
  626. { Start with a clear screen }
  627. if Console<>ttylinux then
  628. begin
  629. prev_term:=cur_term;
  630. setupterm(nil, stdoutputhandle, err);
  631. can_delete_term:=assigned(prev_term) and (prev_term<>cur_term);
  632. SendEscapeSeqNdx(cursor_home);
  633. SendEscapeSeqNdx(cursor_normal);
  634. SendEscapeSeqNdx(cursor_visible);
  635. SendEscapeSeqNdx(enter_ca_mode);
  636. SetCursorType(crUnderLine);
  637. If Console=ttyFreeBSD Then
  638. SendEscapeSeqNdx(exit_am_mode);
  639. end
  640. else if not assigned(cur_term) then
  641. begin
  642. setupterm(nil, stdoutputhandle, err);
  643. can_delete_term:=false;
  644. end;
  645. if assigned(cur_term_Strings) then
  646. begin
  647. ACSIn:=StrPas(cur_term_Strings^[enter_alt_charset_mode]);
  648. ACSOut:=StrPas(cur_term_Strings^[exit_alt_charset_mode]);
  649. if (ACSIn<>'') and (ACSOut<>'') then
  650. SendEscapeSeqNdx(ena_acs);
  651. if pos('$<',ACSIn)>0 then
  652. ACSIn:=Copy(ACSIn,1,Pos('$<',ACSIn)-1);
  653. if pos('$<',ACSOut)>0 then
  654. ACSOut:=Copy(ACSOut,1,Pos('$<',ACSOut)-1);
  655. end
  656. else
  657. begin
  658. ACSIn:='';
  659. ACSOut:='';
  660. end;
  661. {$ifdef logging}
  662. assign(f,'video.log');
  663. rewrite(f,1);
  664. {$endif logging}
  665. { save new terminal characteristics and possible restore rawness }
  666. videoInitDone;
  667. end
  668. else
  669. ErrorCode:=errVioInit; { not a TTY }
  670. end;
  671. procedure SysDoneVideo;
  672. begin
  673. prepareDoneVideo;
  674. if Console=ttylinux then
  675. SetCursorPos(1,1)
  676. else
  677. begin
  678. SendEscapeSeqNdx(exit_ca_mode);
  679. SendEscapeSeqNdx(cursor_home);
  680. SendEscapeSeqNdx(cursor_normal);
  681. SendEscapeSeqNdx(cursor_visible);
  682. SetCursorType(crUnderLine);
  683. SendEscapeSeq(#27'[H');
  684. end;
  685. ACSIn:='';
  686. ACSOut:='';
  687. doneVideoDone;
  688. { FreeBSD gives an error here.
  689. According to Pierre this could be more a NCurses version thing that
  690. a FreeBSD one. FreeBSD 4.4 has ncurses 5.
  691. MvdV102003: Since I ran 1.1 with newer FreeBSD without problem, I let it be for now}
  692. if can_delete_term then
  693. begin
  694. del_curterm(cur_term);
  695. can_delete_term:=false;
  696. end;
  697. {$ifdef logging}
  698. close(f);
  699. {$endif logging}
  700. end;
  701. procedure SysClearScreen;
  702. begin
  703. if Console=ttylinux then
  704. UpdateScreen(true)
  705. else
  706. begin
  707. SendEscapeSeq(#27'[0m');
  708. SendEscapeSeqNdx(clear_screen);
  709. end;
  710. end;
  711. procedure SysUpdateScreen(Force: Boolean);
  712. var
  713. DoUpdate : boolean;
  714. i : longint;
  715. p1,p2 : plongint;
  716. begin
  717. if not force then
  718. begin
  719. {$ifdef cpui386}
  720. asm
  721. movl VideoBuf,%esi
  722. movl OldVideoBuf,%edi
  723. movl VideoBufSize,%ecx
  724. shrl $2,%ecx
  725. repe
  726. cmpsl
  727. setne DoUpdate
  728. end;
  729. {$else not cpui386}
  730. p1:=plongint(VideoBuf);
  731. p2:=plongint(OldVideoBuf);
  732. for i:=0 to VideoBufSize div 2 do
  733. if (p1^<>p2^) then
  734. begin
  735. DoUpdate:=true;
  736. break;
  737. end
  738. else
  739. begin
  740. { Inc does add sizeof(longint) to both pointer values }
  741. inc(p1);
  742. inc(p2);
  743. end;
  744. {$endif not cpui386}
  745. end
  746. else
  747. DoUpdate:=true;
  748. if not DoUpdate then
  749. exit;
  750. if Console=ttylinux then
  751. begin
  752. fplSeek(TTYFd, 4, Seek_Set);
  753. fpWrite(TTYFd, VideoBuf^,VideoBufSize);
  754. end
  755. else
  756. begin
  757. UpdateTTY(force);
  758. end;
  759. Move(VideoBuf^, OldVideoBuf^, VideoBufSize);
  760. end;
  761. function SysGetCapabilities: Word;
  762. begin
  763. { about cpColor... we should check the terminfo database... }
  764. SysGetCapabilities:=cpUnderLine + cpBlink + cpColor;
  765. end;
  766. procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
  767. var
  768. Pos : array [1..2] of Byte;
  769. begin
  770. if (CursorX=NewCursorX+1) and (CursorY=NewCursorY+1) then
  771. exit;
  772. if Console=ttylinux then
  773. begin
  774. fplSeek(TTYFd, 2, Seek_Set);
  775. Pos[1]:=NewCursorX;
  776. Pos[2]:=NewCursorY;
  777. fpWrite(TTYFd, Pos, 2);
  778. end
  779. else
  780. begin
  781. { newcursorx,y is 0 based ! }
  782. SendEscapeSeq(XY2Ansi(NewCursorX+1,NewCursorY+1,CursorX,CursorY));
  783. end;
  784. CursorX:=NewCursorX+1;
  785. CursorY:=NewCursorY+1;
  786. end;
  787. function SysGetCursorType: Word;
  788. begin
  789. SysGetCursorType:=LastCursorType;
  790. end;
  791. procedure SysSetCursorType(NewType: Word);
  792. begin
  793. If LastCursorType=NewType then
  794. exit;
  795. LastCursorType:=NewType;
  796. case NewType of
  797. crBlock :
  798. Begin
  799. If not SendEscapeSeqNdx(cursor_visible) then
  800. If Console<>ttyFreeBSD Then // should be done only for linux?
  801. SendEscapeSeq(#27'[?17;0;64c');
  802. End;
  803. crHidden :
  804. Begin
  805. If not SendEscapeSeqNdx(cursor_invisible) then
  806. If Console<>ttyFreeBSD Then
  807. SendEscapeSeq(#27'[?1c');
  808. End;
  809. else
  810. begin
  811. If not SendEscapeSeqNdx(cursor_normal) then
  812. If Console<>ttyFreeBSD Then
  813. SendEscapeSeq(#27'[?2c');
  814. end;
  815. end;
  816. end;
  817. Const
  818. SysVideoDriver : TVideoDriver = (
  819. InitDriver : @SysInitVideo;
  820. DoneDriver : @SysDoneVideo;
  821. UpdateScreen : @SysUpdateScreen;
  822. ClearScreen : @SysClearScreen;
  823. SetVideoMode : Nil;
  824. GetVideoModeCount : Nil;
  825. GetVideoModeData : Nil;
  826. SetCursorPos : @SysSetCursorPos;
  827. GetCursorType : @SysGetCursorType;
  828. SetCursorType : @SysSetCursorType;
  829. GetCapabilities : @SysGetCapabilities;
  830. );
  831. initialization
  832. SetVideoDriver(SysVideoDriver);
  833. end.
  834. {
  835. $Log$
  836. Revision 1.18 2003-10-26 15:32:25 marco
  837. * partial fix for bug 2212.
  838. Revision 1.17 2003/10/25 22:48:52 marco
  839. * small after merge fixes
  840. Revision 1.16 2003/10/24 17:51:39 marco
  841. * merged some fixes from 1.0.x
  842. Revision 1.15 2003/10/17 22:13:30 olle
  843. * changed i386 to cpui386
  844. Revision 1.14 2003/09/14 20:15:01 marco
  845. * Unix reform stage two. Remove all calls from Unix that exist in Baseunix.
  846. Revision 1.13 2003/03/26 12:45:21 armin
  847. * added wrapoff to avoid problems in the ide with some terminal emulators
  848. Revision 1.12 2002/09/07 16:01:28 peter
  849. * old logs removed and tabs fixed
  850. Revision 1.11 2002/07/06 16:50:17 marco
  851. * Fix for corrupt color-attr after some ACS-mode changes. (Pierre, Strassbourg
  852. meeting)
  853. }