video.pp 28 KB

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