fpusrscr.pas 42 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610
  1. {
  2. This file is part of the Free Pascal Integrated Development Environment
  3. Copyright (c) 1998 by Berczi Gabor
  4. User screen support routines
  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. {$i globdir.inc}
  12. unit FPUsrScr;
  13. interface
  14. uses
  15. {$ifdef Windows}
  16. windows,
  17. {$endif Windows}
  18. {$ifdef Unix}
  19. baseunix,
  20. termio,
  21. {$ifdef linux}
  22. linuxvcs,
  23. {$endif}
  24. {$endif}
  25. video,Objects;
  26. type
  27. PScreen = ^TScreen;
  28. TScreen = object(TObject)
  29. function GetWidth: integer; virtual;
  30. function GetHeight: integer; virtual;
  31. procedure GetLine(Line: integer; var Text, Attr: string); virtual;
  32. procedure GetCursorPos(var P: TPoint); virtual;
  33. { remember the initial video screen }
  34. procedure Capture; virtual;
  35. { restore the initial video mode }
  36. procedure Restore; virtual;
  37. { move up or down if supported by OS }
  38. function Scroll(i : integer) : integer; virtual;
  39. { is moving supported by OS }
  40. function CanScroll : boolean; virtual;
  41. { saves the current IDE screen }
  42. procedure SaveIDEScreen; virtual;
  43. { saves the current console screen }
  44. procedure SaveConsoleScreen; virtual;
  45. { restores the saved console screen }
  46. procedure SwitchToConsoleScreen; virtual;
  47. { restores the saved IDE screen }
  48. procedure SwitchBackToIDEScreen; virtual;
  49. end;
  50. {$IFDEF netwlibc}
  51. PNWLScreen = ^TNWLScreen;
  52. TNWLScreen = object(TScreen)
  53. function GetWidth: integer; virtual;
  54. function GetHeight: integer; virtual;
  55. procedure GetLine(Line: integer; var Text, Attr: string); virtual;
  56. procedure GetCursorPos(var P: TPoint); virtual;
  57. { remember the initial video screen }
  58. procedure Capture; virtual;
  59. { restore the initial video mode }
  60. procedure Restore; virtual;
  61. { saves the current IDE screen }
  62. procedure SaveIDEScreen; virtual;
  63. { saves the current console screen }
  64. procedure SaveConsoleScreen; virtual;
  65. { restores the saved console screen }
  66. procedure SwitchToConsoleScreen; virtual;
  67. { restores the saved IDE screen }
  68. procedure SwitchBackToIDEScreen; virtual;
  69. end;
  70. {$ENDIF}
  71. {$IFDEF AMIGA}
  72. {$DEFINE AMIGASCREEN}
  73. {$ENDIF}
  74. {$IFDEF MORPHOS}
  75. {$DEFINE AMIGASCREEN}
  76. {$ENDIF}
  77. {$IFDEF AROS}
  78. {$DEFINE AMIGASCREEN}
  79. {$ENDIF}
  80. {$IFDEF AMIGASCREEN}
  81. PAmigaScreen = ^TAmigaScreen;
  82. TAmigaScreen = object(TScreen)
  83. function GetWidth: integer; virtual;
  84. function GetHeight: integer; virtual;
  85. procedure GetLine(Line: integer; var Text, Attr: string); virtual;
  86. procedure GetCursorPos(var P: TPoint); virtual;
  87. { remember the initial video screen }
  88. procedure Capture; virtual;
  89. { restore the initial video mode }
  90. procedure Restore; virtual;
  91. { saves the current IDE screen }
  92. procedure SaveIDEScreen; virtual;
  93. { saves the current console screen }
  94. procedure SaveConsoleScreen; virtual;
  95. { restores the saved console screen }
  96. procedure SwitchToConsoleScreen; virtual;
  97. { restores the saved IDE screen }
  98. procedure SwitchBackToIDEScreen; virtual;
  99. end;
  100. {$ENDIF}
  101. {$IFDEF OS2}
  102. POS2Screen = ^TOS2Screen;
  103. TOS2Screen = object(TScreen)
  104. constructor Init;
  105. destructor Done; virtual;
  106. public
  107. function GetWidth: integer; virtual;
  108. function GetHeight: integer; virtual;
  109. procedure GetLine(Line: integer; var Text, Attr: string); virtual;
  110. procedure GetCursorPos(var P: TPoint); virtual;
  111. { remember the initial video screen }
  112. procedure Capture; virtual;
  113. { restore the initial video mode }
  114. procedure Restore; virtual;
  115. { move up or down if supported by OS }
  116. function Scroll(i : integer) : integer; virtual;
  117. { saves the current IDE screen }
  118. procedure SaveIDEScreen; virtual;
  119. { saves the current console screen }
  120. procedure SaveConsoleScreen; virtual;
  121. { restores the saved console screen }
  122. procedure SwitchToConsoleScreen; virtual;
  123. { restores the saved IDE screen }
  124. procedure SwitchBackToIDEScreen; virtual;
  125. end;
  126. {$ENDIF}
  127. {$ifdef DOS}
  128. TDOSVideoInfo = record
  129. Mode : word;
  130. ScreenSize: word;
  131. Page : byte;
  132. Rows,Cols : integer;
  133. CurPos : TPoint;
  134. CurShapeT : integer;
  135. CurShapeB : integer;
  136. StateSize : word;
  137. StateBuf : pointer;
  138. end;
  139. PDOSScreen = ^TDOSScreen;
  140. TDOSScreen = object(TScreen)
  141. constructor Init;
  142. destructor Done; virtual;
  143. public
  144. function GetWidth: integer; virtual;
  145. function GetHeight: integer; virtual;
  146. procedure GetLine(Line: integer; var Text, Attr: string); virtual;
  147. procedure GetCursorPos(var P: TPoint); virtual;
  148. procedure Capture; virtual;
  149. procedure Restore; virtual;
  150. procedure SaveIDEScreen; virtual;
  151. procedure SaveConsoleScreen; virtual;
  152. procedure SwitchToConsoleScreen; virtual;
  153. procedure SwitchBackToIDEScreen; virtual;
  154. procedure FreeGraphBuffer;
  155. private
  156. LastTextConsoleVideoInfo,
  157. ConsoleVideoInfo : TDOSVideoInfo;
  158. VBufferSize : longint;
  159. VIDEBufferSize : longint;
  160. VBuffer : PByteArray;
  161. VIDEBuffer : PByteArray;
  162. IDEVideoInfo : TDOSVideoInfo;
  163. ctrl_c_state : boolean;
  164. {$ifdef USE_GRAPH_SWITCH}
  165. GraphImageSize : longint;
  166. GraphDriverName,
  167. GraphModeName : string;
  168. GraphXres,GraphYres : longint;
  169. GraphBuffer : pointer;
  170. GraphCGABkColor: Integer;
  171. ConsoleGraphDriver, ConsoleGraphMode : smallint;
  172. {$endif USE_GRAPH_SWITCH}
  173. function GetLineStartOfs(Line: integer): word;
  174. procedure GetBuffer(Size: word);
  175. procedure FreeBuffer;
  176. procedure GetVideoMode(var MI: TDOSVideoInfo);
  177. procedure SetVideoMode(MI: TDOSVideoInfo);
  178. end;
  179. {$endif}
  180. {$ifdef Unix}
  181. TConsoleType = (ttyNetwork,ttyLinux,ttyFreeBSD,ttyNetBSD);
  182. PLinuxScreen = ^TLinuxScreen;
  183. TLinuxScreen = object(TScreen)
  184. constructor Init;
  185. destructor Done; virtual;
  186. public
  187. function GetWidth: integer; virtual;
  188. function GetHeight: integer; virtual;
  189. procedure GetLine(Line: integer; var Text, Attr: string); virtual;
  190. procedure GetCursorPos(var P: TPoint); virtual;
  191. procedure Capture; virtual;
  192. procedure Restore; virtual;
  193. procedure SaveIDEScreen; virtual;
  194. procedure SaveConsoleScreen; virtual;
  195. procedure SwitchToConsoleScreen; virtual;
  196. procedure SwitchBackToIDEScreen; virtual;
  197. private
  198. IdeScreen: PByteArray;
  199. IdeSize : longint;
  200. IsXterm : boolean;
  201. Console : TConsoleType;
  202. TTyfd : longint;
  203. ConsVideoBuf : PByteArray;
  204. ConsHeight, ConsWidth,
  205. ConsCursorX, ConsCursorY : byte;
  206. ConsVideoBufSize : longint;
  207. ConsTio : termios;
  208. ConsTioValid : boolean;
  209. end;
  210. {$endif}
  211. {$ifdef Windows}
  212. PWindowsScreen = ^TWindowsScreen;
  213. TWindowsScreen = object(TScreen)
  214. constructor Init;
  215. destructor Done; virtual;
  216. public
  217. function GetWidth: integer; virtual;
  218. function GetHeight: integer; virtual;
  219. procedure GetLine(Line: integer; var Text, Attr: string); virtual;
  220. procedure GetCursorPos(var P: TPoint); virtual;
  221. function CanScroll : boolean; virtual;
  222. function Scroll(i : integer) : integer; virtual;
  223. procedure Capture; virtual;
  224. procedure Restore; virtual;
  225. procedure SaveIDEScreen; virtual;
  226. procedure SaveConsoleScreen; virtual;
  227. procedure SwitchToConsoleScreen; virtual;
  228. procedure SwitchBackToIDEScreen; virtual;
  229. private
  230. DosScreenBufferHandle,
  231. IDEScreenBufferHandle,
  232. StartScreenBufferHandle,
  233. DummyScreenBufferHandle,
  234. NewScreenBufferHandle : THandle;
  235. IDEActive : boolean;
  236. ConsoleMode,IdeMode : Dword;
  237. IdeScreenMode : TVideoMode;
  238. procedure BufferCopy(src,dest : THandle);
  239. {$ifdef debug}
  240. procedure Complain(St : string);
  241. Procedure SetConsoleMode(FH : Handle;Mode : DWord);
  242. {$endif debug}
  243. end;
  244. {$endif}
  245. procedure InitUserScreen;
  246. procedure DoneUserScreen;
  247. const UserScreen : PScreen = nil;
  248. implementation
  249. uses
  250. Dos,WUtils
  251. {$ifdef GO32V2}
  252. ,Dpmiexcp, Go32
  253. {$endif}
  254. ,Drivers,App
  255. {$ifdef USE_GRAPH_SWITCH}
  256. ,Graph,VESA
  257. {$else not USE_GRAPH_SWITCH}
  258. {$ifdef VESA}
  259. ,VESA
  260. {$endif VESA}
  261. {$endif not USE_GRAPH_SWITCH}
  262. ;
  263. function TScreen.GetWidth: integer;
  264. begin
  265. Getwidth:=0;
  266. Abstract;
  267. end;
  268. function TScreen.GetHeight: integer;
  269. begin
  270. Getheight:=0;
  271. Abstract;
  272. end;
  273. procedure TScreen.GetLine(Line: integer; var Text, Attr: string);
  274. begin
  275. Abstract;
  276. end;
  277. procedure TScreen.GetCursorPos(var P: TPoint);
  278. begin
  279. Abstract;
  280. end;
  281. procedure TScreen.Capture;
  282. begin
  283. Abstract;
  284. end;
  285. procedure TScreen.Restore;
  286. begin
  287. Abstract;
  288. end;
  289. procedure TScreen.SwitchToConsoleScreen;
  290. begin
  291. Abstract;
  292. end;
  293. procedure TScreen.SwitchBackToIDEScreen;
  294. begin
  295. Abstract;
  296. end;
  297. procedure TScreen.SaveIDEScreen;
  298. begin
  299. Abstract;
  300. end;
  301. function TScreen.Scroll(i : integer) : integer;
  302. begin
  303. Scroll:=0;
  304. end;
  305. function TScreen.CanScroll : boolean;
  306. begin
  307. CanScroll:=false;
  308. end;
  309. procedure TScreen.SaveConsoleScreen;
  310. begin
  311. Abstract;
  312. end;
  313. {****************************************************************************
  314. TDOSScreen
  315. ****************************************************************************}
  316. {$ifdef DOS}
  317. constructor TDOSScreen.Init;
  318. begin
  319. inherited Init;
  320. FillChar(LastTextConsoleVideoInfo,Sizeof(TDOSVideoInfo),#0);
  321. Capture;
  322. { get the current ctrl-C state }
  323. Ctrl_c_state:=djgpp_set_ctrl_c(false);
  324. djgpp_set_ctrl_c(false);
  325. end;
  326. destructor TDOSScreen.Done;
  327. begin
  328. FreeBuffer;
  329. if assigned(VIDEBuffer) then
  330. FreeMem(VIDEBuffer,VIDEBufferSize);
  331. inherited Done;
  332. end;
  333. function TDOSScreen.GetWidth: integer;
  334. begin
  335. GetWidth:=ConsoleVideoInfo.Cols;
  336. end;
  337. function TDOSScreen.GetHeight: integer;
  338. begin
  339. GetHeight:=ConsoleVideoInfo.Rows;
  340. end;
  341. procedure TDOSScreen.GetLine(Line: integer; var Text, Attr: string);
  342. var
  343. X: integer;
  344. W: word;
  345. begin
  346. Text:=''; Attr:='';
  347. if (Line<GetHeight) and
  348. {$ifdef USE_GRAPH_SWITCH}
  349. not assigned(GraphBuffer) and
  350. {$endif USE_GRAPH_SWITCH}
  351. assigned(VBuffer) then
  352. begin
  353. W:=GetLineStartOfs(Line);
  354. for X:=0 to GetWidth-1 do
  355. begin
  356. {Text:=Text+chr(VBuffer^[W+X*2]);
  357. Attr:=Attr+chr(VBuffer^[W+X*2+1]);}
  358. System.Insert(chr(VBuffer^[W+X*2]),Text,Length(Text)+1);
  359. System.Insert(chr(VBuffer^[W+X*2+1]),Attr,Length(Attr)+1);
  360. end;
  361. {$ifdef USE_GRAPH_SWITCH}
  362. end
  363. else if assigned(GraphBuffer) then
  364. begin
  365. if (Line=0) then
  366. Text:='Console in graph mode, use Alt+F5'
  367. else if (Line=1) then
  368. Text:='Graph driver: '+GraphDriverName
  369. else if (Line=2) then
  370. Text:='Graph mode: '+GraphModeName+' ('+
  371. IntToStr(GraphXres+1)+'x'+IntToStr(GraphYres+1)+')';
  372. Attr:=CharStr(chr($0F),Length(Text));
  373. end;
  374. {$else not USE_GRAPH_SWITCH}
  375. end;
  376. {$endif USE_GRAPH_SWITCH}
  377. end;
  378. procedure TDOSScreen.GetCursorPos(var P: TPoint);
  379. begin
  380. P:=ConsoleVideoInfo.CurPos;
  381. end;
  382. procedure TDOSScreen.Capture;
  383. begin
  384. SaveConsoleScreen;
  385. end;
  386. procedure TDOSScreen.FreeGraphBuffer;
  387. begin
  388. { We don't want to restore the last user screen if
  389. it was a grpahic screen, for example if we
  390. leave in the middle of the debugging of a
  391. graphic program, so we first
  392. dispose the graphic buffer, thus
  393. SwitchToConsoleScreen will restore the
  394. last used text mode }
  395. if LastTextConsoleVideoInfo.Mode<>0 then
  396. begin
  397. ConsoleVideoInfo:=LastTextConsoleVideoInfo;
  398. {$ifdef USE_GRAPH_SWITCH}
  399. if assigned(GraphBuffer) then
  400. begin
  401. FreeMem(GraphBuffer,GraphImageSize);
  402. GraphBuffer:=nil;
  403. GraphImageSize:=0;
  404. end;
  405. {$endif USE_GRAPH_SWITCH}
  406. end;
  407. end;
  408. procedure TDosScreen.Restore;
  409. begin
  410. FreeGraphBuffer;
  411. SwitchToConsoleScreen;
  412. end;
  413. procedure TDosScreen.SaveIDEScreen;
  414. var
  415. VSeg,SOfs: word;
  416. begin
  417. GetVideoMode(IDEVideoInfo);
  418. { First keep a copy of IDE screen }
  419. if ConsoleVideoInfo.Mode=7 then
  420. VSeg:=SegB000
  421. else
  422. VSeg:=SegB800;
  423. SOfs:=MemW[Seg0040:$4e];
  424. if not assigned(VIDEBuffer) or (VIDEBufferSize<>IDEVideoInfo.ScreenSize) then
  425. begin
  426. if assigned(VIDEBuffer) then
  427. FreeMem(VIDEBuffer,VIDEBufferSize);
  428. GetMem(VIDEBuffer,IDEVideoInfo.ScreenSize);
  429. VIDEBufferSize:=IDEVideoInfo.ScreenSize;
  430. end;
  431. HideMouse;
  432. DosmemGet(VSeg,SOfs,VIDEBuffer^,IDEVideoInfo.ScreenSize);
  433. ShowMouse;
  434. end;
  435. procedure TDosScreen.SaveConsoleScreen;
  436. var
  437. VSeg,SOfs: word;
  438. {$ifdef USE_GRAPH_SWITCH}
  439. saved : boolean;
  440. GraphDriver,GraphMode : integer;
  441. {$endif USE_GRAPH_SWITCH}
  442. begin
  443. GetVideoMode(ConsoleVideoInfo);
  444. {$ifdef USE_GRAPH_SWITCH}
  445. saved:=false;
  446. if assigned(GraphBuffer) then
  447. begin
  448. FreeMem(GraphBuffer,GraphImageSize);
  449. GraphBuffer:=nil;
  450. GraphImageSize:=0;
  451. end;
  452. if (ConsoleVideoInfo.Mode>= $100) or
  453. (ConsoleVideoInfo.Mode=$13) or
  454. (ConsoleVideoInfo.Mode=$12) or
  455. (ConsoleVideoInfo.Mode=$10) or
  456. (ConsoleVideoInfo.Mode=$E) or
  457. (ConsoleVideoInfo.Mode=$6) or
  458. (ConsoleVideoInfo.Mode=$4) then
  459. begin
  460. Graph.DontClearGraphMemory:=true;
  461. if ConsoleVideoInfo.Mode>=$100 then
  462. begin
  463. GraphDriver:=Graph.Vesa;
  464. GraphMode:=ConsoleVideoInfo.Mode and $fff;
  465. end
  466. else
  467. begin
  468. case ConsoleVideoInfo.Mode of
  469. $4 : begin
  470. GraphDriver:=Graph.CGA;
  471. case (Mem[$40:$66] shr 4) and 3 of
  472. 0: GraphMode:=CGAC2;
  473. 1: GraphMode:=CGAC0;
  474. 2: GraphMode:=CGAC3;
  475. 3: GraphMode:=CGAC1;
  476. end;
  477. GraphCGABkColor:=Mem[$40:$66] and $0F;
  478. end;
  479. $6 : begin
  480. GraphDriver:=Graph.CGA;
  481. GraphMode:=CGAHi;
  482. end;
  483. $E : begin
  484. GraphDriver:=Graph.VGA;
  485. GraphMode:=VGALo;
  486. end;
  487. $10 : begin
  488. GraphDriver:=Graph.VGA;
  489. GraphMode:=VGAMed;
  490. end;
  491. $12 : begin
  492. GraphDriver:=Graph.VGA;
  493. GraphMode:=VGAHi;
  494. end;
  495. $13 : begin
  496. GraphDriver:=Graph.LowRes;
  497. GraphMode:=0;
  498. end;
  499. end;
  500. end;
  501. Graph.InitGraph(GraphDriver,GraphMode,'');
  502. if graphresult=grOk then
  503. begin
  504. ConsoleGraphDriver:=GraphDriver;
  505. GraphDriverName:=GetDriverName;
  506. GraphModeName:=GetModeName(GraphMode);
  507. ConsoleGraphMode:=GraphMode;
  508. Graph.DontClearGraphMemory:=false;
  509. GraphXres:=Graph.GetmaxX;
  510. GraphYres:=Graph.GetmaxY;
  511. GraphImageSize:=ImageSize(0,0,GraphXres,GraphYres);
  512. GetMem(GraphBuffer,GraphImageSize);
  513. FillChar(GraphBuffer^,GraphImageSize,#0);
  514. GetImage(0,0,GraphXres,GraphYres,GraphBuffer^);
  515. ConsoleVideoInfo.Rows:=GraphYres div 8;
  516. ConsoleVideoInfo.Cols:=GraphXres div 8;
  517. {FreeBuffer;}
  518. saved:=true;
  519. end
  520. {$ifdef DEBUG}
  521. else
  522. Writeln(stderr,'Error in InitGraph ',Graphdriver, ' ',Graphmode)
  523. {$endif DEBUG}
  524. ;
  525. end;
  526. { mode < $100 so use standard Save code }
  527. if not saved then
  528. {$endif USE_GRAPH_SWITCH}
  529. begin
  530. LastTextConsoleVideoInfo:=ConsoleVideoInfo;
  531. GetBuffer(ConsoleVideoInfo.ScreenSize);
  532. if ConsoleVideoInfo.Mode=7 then
  533. VSeg:=SegB000
  534. else
  535. VSeg:=SegB800;
  536. SOfs:=MemW[Seg0040:$4e];
  537. DosmemGet(VSeg,SOfs,VBuffer^,ConsoleVideoInfo.ScreenSize);
  538. end;
  539. end;
  540. procedure TDOSScreen.SwitchToConsoleScreen;
  541. var
  542. VSeg,SOfs: word;
  543. {$ifdef USE_GRAPH_SWITCH}
  544. restored : boolean;
  545. {$endif USE_GRAPH_SWITCH}
  546. begin
  547. {$ifdef USE_GRAPH_SWITCH}
  548. restored:=false;
  549. if assigned(GraphBuffer) then
  550. begin
  551. Graph.InitGraph(ConsoleGraphDriver,ConsoleGraphMode,'');
  552. if graphresult=grOk then
  553. begin
  554. if (ConsoleGraphDriver=CGA) and
  555. (ConsoleGraphMode>=CGAC0) and
  556. (ConsoleGraphMode<=CGAC3) then
  557. SetBkColor(GraphCGABkColor);
  558. PutImage(0,0,GraphBuffer^,CopyPut);
  559. FreeMem(GraphBuffer,GraphImageSize);
  560. GraphBuffer:=nil;
  561. GraphImageSize:=0;
  562. restored:=true;
  563. end;
  564. end;
  565. { mode < $100 so use standard Save code }
  566. if not restored then
  567. {$endif USE_GRAPH_SWITCH}
  568. begin
  569. SetVideoMode(ConsoleVideoInfo);
  570. if ConsoleVideoInfo.Mode=7 then
  571. VSeg:=SegB000
  572. else
  573. VSeg:=SegB800;
  574. SOfs:=MemW[Seg0040:$4e];
  575. DosmemPut(VSeg,SOfs,VBuffer^,ConsoleVideoInfo.ScreenSize);
  576. djgpp_set_ctrl_c(Ctrl_c_state);
  577. end;
  578. end;
  579. procedure TDOSScreen.SwitchBackToIDEScreen;
  580. var
  581. VSeg,SOfs: word;
  582. begin
  583. SetVideoMode(IDEVideoInfo);
  584. if ConsoleVideoInfo.Mode=7 then
  585. VSeg:=SegB000
  586. else
  587. VSeg:=SegB800;
  588. SOfs:=MemW[Seg0040:$4e];
  589. if assigned(VIDEBuffer) then
  590. DosmemPut(VSeg,SOfs,VIDEBuffer^,IDEVideoInfo.ScreenSize);
  591. Ctrl_c_state := djgpp_set_ctrl_c(false);
  592. { Its difficult to know
  593. the state of the mouse
  594. so simply show it always
  595. fixes bug 2253 PM }
  596. ShowMouse;
  597. end;
  598. function TDOSScreen.GetLineStartOfs(Line: integer): word;
  599. begin
  600. GetLineStartOfs:=(ConsoleVideoInfo.Cols*Line)*2;
  601. end;
  602. procedure TDOSScreen.GetBuffer(Size: word);
  603. begin
  604. if (VBuffer<>nil) and (VBufferSize=Size) then Exit;
  605. if VBuffer<>nil then FreeBuffer;
  606. VBufferSize:=Size;
  607. GetMem(VBuffer,VBufferSize);
  608. end;
  609. procedure TDOSScreen.FreeBuffer;
  610. begin
  611. if (VBuffer<>nil) and (VBufferSize>0) then FreeMem(VBuffer,VBufferSize);
  612. VBuffer:=nil;
  613. end;
  614. procedure TDOSScreen.GetVideoMode(var MI: TDOSVideoInfo);
  615. var
  616. r: registers;
  617. begin
  618. if (MI.StateSize>0) and (MI.StateBuf<>nil) then
  619. begin FreeMem(MI.StateBuf,MI.StateSize); MI.StateBuf:=nil; end;
  620. MI.ScreenSize:=MemW[Seg0040:$4c];
  621. r.ah:=$0f;
  622. intr($10,r);
  623. MI.Mode:=r.al;
  624. MI.Page:=r.bh;
  625. MI.Cols:=r.ah;
  626. {$ifdef VESA}
  627. VESAGetMode(MI.Mode);
  628. MI.Mode:=MI.Mode and $fff;
  629. {$endif}
  630. MI.Rows:=MI.ScreenSize div (MI.Cols*2);
  631. if MI.Rows=51 then MI.Rows:=50;
  632. r.ah:=$03;
  633. r.bh:=MI.Page;
  634. intr($10,r);
  635. with MI do
  636. begin
  637. CurPos.X:=r.dl; CurPos.Y:=r.dh;
  638. CurShapeT:=r.ch; CurShapeB:=r.cl;
  639. end;
  640. end;
  641. procedure TDOSScreen.SetVideoMode(MI: TDOSVideoInfo);
  642. var r: registers;
  643. CM: TDOSVideoInfo;
  644. begin
  645. FillChar(CM,sizeof(CM),0);
  646. GetVideoMode(CM);
  647. if (CM.Mode<>MI.Mode) or (CM.Cols<>MI.Cols) or (CM.Rows<>MI.Rows) then
  648. begin
  649. {$ifdef VESA}
  650. if MI.Mode>=$100 then
  651. VESASetMode(MI.Mode)
  652. else
  653. {$endif}
  654. begin
  655. r.ah:=$00; r.al:=MI.Mode; intr($10,r);
  656. end;
  657. if (MI.Mode=3) and (MI.Cols=80) and (MI.Rows=50) then
  658. begin
  659. r.ax:=$1112; r.bx:=$0;
  660. intr($10,r);
  661. end;
  662. end;
  663. r.ah:=$05; r.al:=MI.Page; intr($10,r);
  664. r.ah:=$02; r.bh:=MI.Page; r.dl:=MI.CurPos.X; r.dh:=MI.CurPos.Y; intr($10,r);
  665. r.ah:=$01; r.ch:=MI.CurShapeT; r.cl:=MI.CurShapeB; intr($10,r);
  666. end;
  667. {$endif}
  668. {****************************************************************************
  669. TLinuxScreen
  670. ****************************************************************************}
  671. {$ifdef Unix}
  672. constructor TLinuxScreen.Init;
  673. var
  674. ThisTTY: string[30];
  675. FName: string;
  676. WS: packed record
  677. ws_row, ws_col, ws_xpixel, ws_ypixel: Word;
  678. end;
  679. begin
  680. inherited Init;
  681. IdeScreen := nil;
  682. TTYFd:=-1;
  683. IsXterm:=getenv('TERM')='xterm';
  684. ThisTTY:=TTYName(stdinputhandle);
  685. if Not IsXterm and (IsATTY(stdinputhandle)<>-1) then
  686. begin
  687. Console:=TTyNetwork; {Default: Network or other vtxxx tty}
  688. if ((Copy(ThisTTY, 1, 8) = '/dev/tty') and (ThisTTY[9]<>'p')) or (Copy(ThisTTY,1,8)='/dev/vc/') Then
  689. begin
  690. Case ThisTTY[9] of
  691. '0'..'9' :
  692. begin { running Linux on native console or native-emulation }
  693. {$ifdef linux}
  694. FName:='/dev/vcsa' + ThisTTY[9];
  695. TTYFd:=fpOpen(FName, &666, O_RdWr); { open console }
  696. if TTYFd = -1 then
  697. begin
  698. if try_grab_vcsa then
  699. TTYFd:=fpOpen(FName, &666, O_RdWr); { try again }
  700. end;
  701. If TTYFd <>-1 Then
  702. Console:=ttyLinux;
  703. {$endif}
  704. end;
  705. 'v' : { check for (Free?)BSD native}
  706. If (ThisTTY[10]>='0') and (ThisTTY[10]<='9') Then
  707. Console:=ttyFreeBSD; {TTYFd ?}
  708. end;
  709. end;
  710. If Copy(GetEnv('TERM'),1,6)='cons25' Then
  711. Console:=ttyFreeBSD;
  712. fpioctl(stdinputhandle, TIOCGWINSZ, @WS);
  713. if WS.ws_Col=0 then
  714. WS.ws_Col:=80;
  715. if WS.ws_Row=0 then
  716. WS.ws_Row:=25;
  717. ConsWidth:=WS.ws_Col;
  718. ConsHeight:=WS.ws_row;
  719. end;
  720. Capture;
  721. end;
  722. destructor TLinuxScreen.Done;
  723. begin
  724. if assigned(IdeScreen) then
  725. freemem(IdeScreen,IdeSize);
  726. if assigned(ConsVideoBuf) then
  727. freemem(ConsVideoBuf,ConsVideoBufSize);
  728. inherited Done;
  729. end;
  730. function TLinuxScreen.GetWidth: integer;
  731. begin
  732. GetWidth:=ConsWidth;
  733. end;
  734. function TLinuxScreen.GetHeight: integer;
  735. begin
  736. GetHeight:=ConsHeight;
  737. end;
  738. procedure TLinuxScreen.GetLine(Line: integer; var Text, Attr: string);
  739. var
  740. X, W : longint;
  741. begin
  742. Text:='';
  743. Attr:='';
  744. if (TtyFd<>-1) and assigned(ConsVideoBuf) then
  745. begin
  746. if Line<GetHeight then
  747. begin
  748. W:=(ConsWidth*Line)*Sizeof(word);
  749. for X:=0 to GetWidth-1 do
  750. begin
  751. {Text:=Text+chr(VBuffer^[W+X*2]);
  752. Attr:=Attr+chr(VBuffer^[W+X*2+1]);}
  753. System.Insert(chr(ConsVideoBuf^[W+X*2]),Text,Length(Text)+1);
  754. System.Insert(chr(ConsVideoBuf^[W+X*2+1]),Attr,Length(Attr)+1);
  755. end;
  756. end;
  757. end;
  758. end;
  759. procedure TLinuxScreen.GetCursorPos(var P: TPoint);
  760. begin
  761. P.X:=ConsCursorX+1;
  762. P.Y:=ConsCursorY+1;
  763. end;
  764. procedure TLinuxScreen.Capture;
  765. begin
  766. SaveConsoleScreen;
  767. end;
  768. procedure TLinuxScreen.Restore;
  769. begin
  770. SwitchToConsoleScreen;
  771. end;
  772. procedure TLinuxScreen.SaveIDEScreen;
  773. begin
  774. if assigned(IdeScreen) then
  775. freemem(IdeScreen,IdeSize);
  776. getmem(IdeScreen,videobufsize);
  777. IdeSize:=videobufsize;
  778. move(videobuf^,IdeScreen^,videobufsize);
  779. end;
  780. procedure TLinuxScreen.SaveConsoleScreen;
  781. var
  782. NewSize : longint;
  783. begin
  784. write(#27'7'#27'[?47h');
  785. if IsXTerm then
  786. {write(#27'7'#27'[?47h')}
  787. else if (TTYfd<>-1) then
  788. begin
  789. fpLSeek(TTYFd, 0, Seek_Set);
  790. fpread(TTYFd,ConsHeight,sizeof(byte));
  791. fpread(TTYFd,ConsWidth,sizeof(byte));
  792. fpread(TTYFd,ConsCursorX,sizeof(byte));
  793. fpread(TTYFd,ConsCursorY,sizeof(byte));
  794. NewSize:=ConsWidth*ConsHeight*sizeof(word);
  795. if (NewSize<>ConsVideoBufSize) and
  796. assigned(ConsVideoBuf) then
  797. Begin
  798. FreeMem(ConsVideoBuf,ConsVideoBufSize);
  799. ConsVideoBuf:=nil;
  800. End;
  801. If not assigned(ConsVideoBuf) then
  802. GetMem(ConsVideoBuf,NewSize);
  803. ConsVideoBufSize:=NewSize;
  804. fpread(TTYFd,ConsVideoBuf^,ConsVideoBufSize);
  805. end
  806. else
  807. begin
  808. ConsWidth:=80;
  809. ConsHeight:=25;
  810. ConsCursorX:=0;
  811. ConsCursorY:=0;
  812. ConsVideoBuf:=nil;
  813. end;
  814. ConsTioValid:=(TCGetAttr(1,ConsTio)<>-1);
  815. end;
  816. procedure TLinuxScreen.SwitchToConsoleScreen;
  817. begin
  818. write(#27'[0m');
  819. write(#27'[?47l'#27'8'#27'[m');
  820. if IsXterm then
  821. begin
  822. {write(#27'[0m');
  823. write(#27'[?47l'#27'8'#27'[m');}
  824. end
  825. else if (TTyfd<>-1) then
  826. begin
  827. fplSeek(TTYFd, 2, Seek_Set);
  828. fpwrite(TTYFd, ConsCursorX, sizeof(byte));
  829. fpwrite(TTYFd, ConsCursorY, sizeof(byte));
  830. fpwrite(TTYFd, ConsVideoBuf^,ConsVideoBufSize);
  831. { FreeMem(ConsVideoBuf,ConsVideoBufSize);
  832. ConsVideoBuf:=nil; }
  833. end;
  834. If ConsTioValid then
  835. TCSetAttr(1,TCSANOW,ConsTio);
  836. end;
  837. procedure TLinuxScreen.SwitchBackToIDEScreen;
  838. begin
  839. if IdeScreen = nil then
  840. exit;
  841. move(IdeScreen^,videobuf^,videobufsize);
  842. freemem(IdeScreen,IdeSize);
  843. IdeScreen := nil;
  844. end;
  845. {$endif}
  846. {****************************************************************************
  847. TWindowsScreen
  848. ****************************************************************************}
  849. {$ifdef Windows}
  850. { Seems to be missing in windows unit PM }
  851. const
  852. ENABLE_INSERT_MODE = $20;
  853. ENABLE_QUICK_EDIT_MODE = $40;
  854. ENABLE_EXTENDED_FLAGS = $80;
  855. ENABLE_AUTO_POSITION = $100;
  856. procedure UpdateFileHandles;
  857. begin
  858. {StdInputHandle:=longint(GetStdHandle(STD_INPUT_HANDLE));}
  859. StdOutputHandle:=THandle(GetStdHandle(cardinal(STD_OUTPUT_HANDLE)));
  860. {StdErrorHandle:=longint(GetStdHandle(STD_ERROR_HANDLE));}
  861. TextRec(Output).Handle:=StdOutputHandle;
  862. VideoSetConsoleOutHandle(StdOutputHandle);
  863. TextRec(StdOut).Handle:=StdOutputHandle;
  864. {TextRec(StdErr).Handle:=StdErrorHandle;}
  865. end;
  866. constructor TWindowsScreen.Init;
  867. var
  868. SecurityAttr : Security_attributes;
  869. BigWin : Coord;
  870. res : longbool;
  871. Error : dword;
  872. ConsoleScreenBufferInfo : Console_screen_buffer_info;
  873. begin
  874. inherited Init;
  875. {if GetConsoleOutputCP<>437 then
  876. res:=SetConsoleOutputCP(437);}
  877. SecurityAttr.nLength:=SizeOf(Security_attributes);
  878. SecurityAttr.lpSecurityDescriptor:=nil;
  879. SecurityAttr.bInheritHandle:=true;
  880. NewScreenBufferHandle:=CreateConsoleScreenBuffer(
  881. GENERIC_READ or GENERIC_WRITE,
  882. FILE_SHARE_READ or FILE_SHARE_WRITE,SecurityAttr,
  883. CONSOLE_TEXTMODE_BUFFER,nil);
  884. DummyScreenBufferHandle:=CreateConsoleScreenBuffer(
  885. GENERIC_READ or GENERIC_WRITE,
  886. FILE_SHARE_READ or FILE_SHARE_WRITE,SecurityAttr,
  887. CONSOLE_TEXTMODE_BUFFER,nil);
  888. StartScreenBufferHandle:=GetStdHandle(cardinal(STD_OUTPUT_HANDLE));
  889. GetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), @ConsoleMode);
  890. IdeMode:=ConsoleMode;
  891. {$ifdef debug}
  892. Complain('Starting ConsoleMode is $'+hexstr(ConsoleMode,8));
  893. {define Windowsbigwin}
  894. {$endif debug}
  895. {$ifdef Windowsbigwin}
  896. GetConsoleScreenBufferInfo(StartScreenBufferHandle,
  897. @ConsoleScreenBufferInfo);
  898. BigWin.X:=ConsoleScreenBufferInfo.dwSize.X;
  899. BigWin.Y:=ConsoleScreenBufferInfo.srwindow.bottom-ConsoleScreenBufferInfo.srwindow.top; // mants 15779 was 200
  900. { Try to allow to store more info }
  901. res:=SetConsoleScreenBufferSize(NewScreenBufferHandle,BigWin);
  902. if not res then
  903. error:=GetLastError;
  904. res:=SetConsoleScreenBufferSize(StartScreenBufferHandle,BigWin);
  905. if not res then
  906. error:=GetLastError;
  907. {$endif Windowsbigwin}
  908. GetConsoleScreenBufferInfo(StartScreenBufferHandle,
  909. @ConsoleScreenBufferInfo);
  910. { make sure that the IDE Screen Handle has the maximum display size
  911. this removes the scroll bars if it is maximized }
  912. BigWin.X:=ConsoleScreenBufferInfo.dwSize.X;
  913. BigWin.Y:=ConsoleScreenBufferInfo.srwindow.bottom-ConsoleScreenBufferInfo.srwindow.top;
  914. res:=SetConsoleScreenBufferSize(NewScreenBufferHandle,
  915. BigWin);
  916. // mants 15779 : was
  917. // res:=SetConsoleScreenBufferSize(NewScreenBufferHandle,
  918. // ConsoleScreenBufferInfo.dwMaximumWindowSize);
  919. if not res then
  920. error:=GetLastError;
  921. IDEScreenBufferHandle:=NewScreenBufferHandle;
  922. DosScreenBufferHandle:=StartScreenBufferHandle;
  923. Capture;
  924. IdeScreenMode.row:=0;
  925. SwitchBackToIDEScreen;
  926. end;
  927. destructor TWindowsScreen.Done;
  928. begin
  929. { copy the Dos buffer content into the original ScreenBuffer
  930. which remains the startup std_output_handle PM }
  931. {if StartScreenBufferHandle=IDEScreenBufferHandle then}
  932. BufferCopy(DosScreenBufferHandle,IDEScreenBufferHandle);
  933. SetConsoleActiveScreenBuffer(StartScreenBufferHandle);
  934. SetStdHandle(cardinal(Std_Output_Handle),StartScreenBufferHandle);
  935. UpdateFileHandles;
  936. CloseHandle(NewScreenBufferHandle);
  937. CloseHandle(DummyScreenBufferHandle);
  938. inherited Done;
  939. end;
  940. function TWindowsScreen.GetWidth: integer;
  941. var
  942. ConsoleScreenBufferInfo : Console_screen_buffer_info;
  943. begin
  944. GetConsoleScreenBufferInfo(DosScreenBufferHandle,
  945. @ConsoleScreenBufferInfo);
  946. GetWidth:=ConsoleScreenBufferInfo.dwSize.X;
  947. end;
  948. function TWindowsScreen.GetHeight: integer;
  949. var
  950. ConsoleScreenBufferInfo : Console_screen_buffer_info;
  951. begin
  952. GetConsoleScreenBufferInfo(DosScreenBufferHandle,
  953. @ConsoleScreenBufferInfo);
  954. GetHeight:=ConsoleScreenBufferInfo.dwSize.Y;
  955. end;
  956. function TWindowsScreen.CanScroll : boolean;
  957. var
  958. ConsoleScreenBufferInfo : Console_screen_buffer_info;
  959. BufferLines : longint;
  960. WindowLines : longint;
  961. begin
  962. GetConsoleScreenBufferInfo(DosScreenBufferHandle,
  963. @ConsoleScreenBufferInfo);
  964. WindowLines:=ConsoleScreenBufferInfo.srWindow.Bottom-
  965. ConsoleScreenBufferInfo.srWindow.Top;
  966. BufferLines:= ConsoleScreenBufferInfo.dwSize.Y-1;
  967. CanScroll:=(BufferLines>WindowLines);
  968. end;
  969. function TWindowsScreen.Scroll(i : integer) : integer;
  970. var
  971. ConsoleScreenBufferInfo : Console_screen_buffer_info;
  972. ConsoleWindow : Small_rect;
  973. begin
  974. GetConsoleScreenBufferInfo(DosScreenBufferHandle,
  975. @ConsoleScreenBufferInfo);
  976. if (ConsoleScreenBufferInfo.srWindow.Top + i < 0) then
  977. i:= -ConsoleScreenBufferInfo.srWindow.Top;
  978. if (ConsoleScreenBufferInfo.srWindow.Bottom + i > ConsoleScreenBufferInfo.dwSize.Y) then
  979. i:= ConsoleScreenBufferInfo.dwSize.Y - ConsoleScreenBufferInfo.srWindow.Bottom;
  980. if i<>0 then
  981. begin
  982. ConsoleWindow.Left:=ConsoleScreenBufferInfo.srWindow.Left;
  983. ConsoleWindow.Right:=ConsoleScreenBufferInfo.srWindow.Right;
  984. ConsoleWindow.Top:=ConsoleScreenBufferInfo.srWindow.Top+i;
  985. ConsoleWindow.Bottom:=ConsoleScreenBufferInfo.srWindow.Bottom+i;
  986. SetConsoleWindowInfo(DosScreenBufferHandle,true,ConsoleWindow);
  987. Scroll:=i;
  988. end
  989. else
  990. Scroll:=0;
  991. end;
  992. procedure TWindowsScreen.GetLine(Line: integer; var Text, Attr: string);
  993. type
  994. CharInfoArray = Array [0..255] of Char_Info;
  995. var
  996. LineBuf : ^CharInfoArray;
  997. BufSize,BufCoord : Coord;
  998. i,LineSize : longint;
  999. WriteRegion : SMALL_RECT;
  1000. begin
  1001. GetMem(LineBuf,SizeOf(CharInfoArray));
  1002. LineSize:=ScreenWidth;
  1003. If LineSize>256 then
  1004. LineSize:=256;
  1005. BufSize.X:=LineSize;
  1006. BufSize.Y:=1;
  1007. BufCoord.X:=0;
  1008. BufCoord.Y:=0;
  1009. with WriteRegion do
  1010. begin
  1011. Top :=Line;
  1012. Left :=0;
  1013. Bottom := Line+1;
  1014. Right := LineSize-1;
  1015. end;
  1016. ReadConsoleOutput(DosScreenBufferHandle, PChar_info(LineBuf),
  1017. BufSize, BufCoord, @WriteRegion);
  1018. for i:=1 to LineSize do
  1019. begin
  1020. Text[i]:=LineBuf^[i-1].AsciiChar;
  1021. Attr[i]:=AnsiChar(byte(LineBuf^[i-1].Attributes));
  1022. end;
  1023. FreeMem(LineBuf,SizeOf(CharInfoArray));
  1024. Text[0]:=AnsiChar(byte(LineSize));
  1025. Attr[0]:=AnsiChar(byte(LineSize));
  1026. end;
  1027. procedure TWindowsScreen.GetCursorPos(var P: TPoint);
  1028. var
  1029. ConsoleScreenBufferInfo : Console_screen_buffer_info;
  1030. begin
  1031. GetConsoleScreenBufferInfo(DosScreenBufferHandle,
  1032. @ConsoleScreenBufferInfo);
  1033. P.X:=ConsoleScreenBufferInfo.dwCursorPosition.X;
  1034. P.Y:=ConsoleScreenBufferInfo.dwCursorPosition.Y;
  1035. end;
  1036. procedure TWindowsScreen.BufferCopy(Src, Dest : THandle);
  1037. type
  1038. CharInfoArray = Array [0..256*255-1] of Char_Info;
  1039. var
  1040. LineBuf : ^CharInfoArray;
  1041. BufSize,BufCoord : Coord;
  1042. Error, LineSize,
  1043. Part, OnePartY: longint;
  1044. res : boolean;
  1045. WriteRegion : SMALL_RECT;
  1046. ConsoleScreenBufferInfo : Console_screen_buffer_info;
  1047. DestConsoleScreenBufferInfo : Console_screen_buffer_info;
  1048. begin
  1049. GetConsoleScreenBufferInfo(Src,
  1050. @ConsoleScreenBufferInfo);
  1051. GetConsoleScreenBufferInfo(Dest,
  1052. @DestConsoleScreenBufferInfo);
  1053. GetMem(LineBuf,SizeOf(CharInfoArray));
  1054. FillChar(LineBuf^,SizeOf(CharInfoArray),#0);
  1055. LineSize:=ConsoleScreenBufferInfo.dwSize.X;
  1056. If LineSize>256 then
  1057. LineSize:=256;
  1058. BufSize.X:=LineSize;
  1059. BufSize.Y:=ConsoleScreenBufferInfo.dwSize.Y;
  1060. BufCoord.X:=0;
  1061. BufCoord.Y:=0;
  1062. with WriteRegion do
  1063. begin
  1064. Top :=0;
  1065. Left :=0;
  1066. Bottom := ConsoleScreenBufferInfo.dwSize.Y-1;
  1067. Right := LineSize-1;
  1068. end;
  1069. if BufSize.X*BufSize.Y*Sizeof(CHAR_INFO) >= $8000 then
  1070. begin
  1071. OnePartY := ($8000 -1) div (BufSize.X * SizeOf(Char_Info) );
  1072. BufSize.Y:=OnePartY;
  1073. Part:=0;
  1074. while ((Part+1)*OnePartY < ConsoleScreenBufferInfo.dwSize.Y) do
  1075. begin
  1076. WriteRegion.Top := Part*OnePartY;
  1077. WriteRegion.Bottom := (Part+1)*OnePartY-1;
  1078. res:=ReadConsoleOutput(Src, PChar_info(LineBuf),
  1079. BufSize, BufCoord, @WriteRegion);
  1080. if not res then
  1081. Error:=GetLastError;
  1082. res:=WriteConsoleOutput(Dest, PChar_info(LineBuf),
  1083. BufSize, BufCoord, @WriteRegion);
  1084. if not res then
  1085. Error:=GetLastError;
  1086. Inc(Part);
  1087. end;
  1088. BufSize.Y:=ConsoleScreenBufferInfo.dwSize.Y - Part*OnePartY;
  1089. WriteRegion.Top := Part*OnePartY;
  1090. WriteRegion.Bottom := ConsoleScreenBufferInfo.dwSize.Y-1;
  1091. res:=ReadConsoleOutput(Src, PChar_info(LineBuf),
  1092. BufSize, BufCoord, @WriteRegion);
  1093. if not res then
  1094. Error:=GetLastError;
  1095. res:=WriteConsoleOutput(Dest, PChar_info(LineBuf),
  1096. BufSize, BufCoord, @WriteRegion);
  1097. if not res then
  1098. Error:=GetLastError;
  1099. end
  1100. else
  1101. begin
  1102. res:=ReadConsoleOutput(Src, PChar_info(LineBuf),
  1103. BufSize, BufCoord, @WriteRegion);
  1104. if not res then
  1105. Error:=GetLastError;
  1106. res:=WriteConsoleOutput(Dest, PChar_info(LineBuf),
  1107. BufSize, BufCoord, @WriteRegion);
  1108. if not res then
  1109. Error:=GetLastError;
  1110. end;
  1111. FreeMem(LineBuf,SizeOf(CharInfoArray));
  1112. SetConsoleCursorPosition(Dest, ConsoleScreenBufferInfo.dwCursorPosition);
  1113. end;
  1114. procedure TWindowsScreen.Capture;
  1115. begin
  1116. {if StartScreenBufferHandle=IdeScreenBufferHandle then
  1117. BufferCopy(IDEScreenBufferHandle,DosScreenBufferHandle)
  1118. else
  1119. BufferCopy(DosScreenBufferHandle,IDEScreenBufferHandle);}
  1120. SaveConsoleScreen;
  1121. end;
  1122. procedure TWindowsScreen.Restore;
  1123. begin
  1124. SwitchToConsoleScreen;
  1125. end;
  1126. { dummy for Windows as the Buffer screen
  1127. do hold all the info }
  1128. procedure TWindowsScreen.SaveIDEScreen;
  1129. var
  1130. NowIdeMode : Dword;
  1131. begin
  1132. IdeScreenMode:=ScreenMode;
  1133. GetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), @NowIdeMode);
  1134. {$ifdef debug}
  1135. Complain('IDE ConsoleMode is $'+hexstr(NowIdeMode,8));
  1136. if NowIdeMode<>IdeMode then
  1137. Complain('is not equal to IDEMode $'+hexstr(IdeMode,8));
  1138. {$endif debug}
  1139. IdeMode:=NowIdeMode;
  1140. { set the dummy buffer as active already now PM }
  1141. SetStdHandle(cardinal(Std_Output_Handle),DummyScreenBufferHandle);
  1142. UpdateFileHandles;
  1143. end;
  1144. { dummy for Windows as the Buffer screen
  1145. do hold all the info }
  1146. procedure TWindowsScreen.SaveConsoleScreen;
  1147. begin
  1148. GetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), @ConsoleMode);
  1149. {$ifdef debug}
  1150. Complain('ConsoleMode now is $'+hexstr(ConsoleMode,8));
  1151. {$endif debug}
  1152. { set the dummy buffer as active already now PM }
  1153. SetStdHandle(cardinal(Std_Output_Handle),DummyScreenBufferHandle);
  1154. UpdateFileHandles;
  1155. end;
  1156. procedure TWindowsScreen.SwitchToConsoleScreen;
  1157. begin
  1158. SetConsoleActiveScreenBuffer(DosScreenBufferHandle);
  1159. SetStdHandle(cardinal(Std_Output_Handle),DosScreenBufferHandle);
  1160. SetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), ConsoleMode);
  1161. UpdateFileHandles;
  1162. IDEActive:=false;
  1163. end;
  1164. procedure TWindowsScreen.SwitchBackToIDEScreen;
  1165. var
  1166. ConsoleScreenBufferInfo : Console_screen_buffer_info;
  1167. WindowPos : Small_rect;
  1168. res : boolean;
  1169. error : longint;
  1170. begin
  1171. SetStdHandle(cardinal(Std_Output_Handle),IDEScreenBufferHandle);
  1172. UpdateFileHandles;
  1173. GetConsoleScreenBufferInfo(IDEScreenBufferHandle,
  1174. @ConsoleScreenBufferInfo);
  1175. SetConsoleActiveScreenBuffer(IDEScreenBufferHandle);
  1176. { Needed to force InitSystemMsg to use the right console handle }
  1177. DoneEvents;
  1178. InitEvents;
  1179. IdeMode:=({IdeMode or }ENABLE_MOUSE_INPUT or
  1180. ENABLE_WINDOW_INPUT or
  1181. ENABLE_EXTENDED_FLAGS)
  1182. and not (ENABLE_PROCESSED_INPUT or
  1183. ENABLE_LINE_INPUT or
  1184. ENABLE_ECHO_INPUT or
  1185. ENABLE_INSERT_MODE or
  1186. ENABLE_QUICK_EDIT_MODE);
  1187. SetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), IdeMode);
  1188. WindowPos.left:=0;
  1189. WindowPos.right:=ConsoleScreenBufferInfo.srWindow.right
  1190. -ConsoleScreenBufferInfo.srWindow.left;
  1191. WindowPos.top:=0;
  1192. WindowPos.bottom:=ConsoleScreenBufferInfo.srWindow.bottom
  1193. -ConsoleScreenBufferInfo.srWindow.top;
  1194. with ConsoleScreenBufferInfo.dwMaximumWindowSize do
  1195. begin
  1196. if WindowPos.Right<X-1 then
  1197. WindowPos.right:=X-1;
  1198. if WindowPos.Bottom<Y-1 then
  1199. WindowPos.Bottom:=Y-1;
  1200. end;
  1201. res:=SetConsoleWindowInfo(IDEScreenBufferHandle,true,WindowPos);
  1202. if not res then
  1203. error:=GetLastError;
  1204. {$ifdef DEBUG}
  1205. IdeScreenMode.row:=WindowPos.bottom+1;
  1206. IdeScreenMode.col:=WindowPos.right+1;
  1207. {$endif DEBUG}
  1208. { needed to force the correct size for videobuf }
  1209. if Assigned(Application) and (IdeScreenMode.row<>0)then
  1210. Application^.SetScreenVideoMode(IdeScreenMode);
  1211. IDEActive:=true;
  1212. end;
  1213. {$ifdef debug}
  1214. procedure TWindowsScreen.Complain(St : string);
  1215. begin
  1216. if IDEActive then
  1217. DebugMessage('',St,0,0)
  1218. else
  1219. Writeln(stderr,St);
  1220. end;
  1221. procedure TWindowsScreen.SetConsoleMode(FH : Handle;Mode: DWord);
  1222. var
  1223. Test: DWord;
  1224. begin
  1225. If not Windows.SetConsoleMode(FH,Mode) then
  1226. begin
  1227. Complain('SetConsoleMode call failed GetLastError='+IntToStr(GetLastError));
  1228. end
  1229. else
  1230. begin
  1231. if not GetConsoleMode(FH,Test) then
  1232. begin
  1233. Complain('GetConsoleMode call failed GetLastError='+IntToStr(GetLastError));
  1234. end
  1235. else if (Test<>Mode) then
  1236. begin
  1237. Complain('GetConsoleMode result '+IntToStr(Test)+' <> '+
  1238. IntToStr(Mode));
  1239. end;
  1240. end;
  1241. end;
  1242. {$endif DEBUG}
  1243. {$endif}
  1244. {****************************************************************************
  1245. TOS2Screen
  1246. ****************************************************************************}
  1247. {$ifdef OS2}
  1248. function TOS2Screen.GetWidth: integer;
  1249. begin
  1250. GetWidth:=80;
  1251. end;
  1252. function TOS2Screen.GetHeight: integer;
  1253. begin
  1254. GetHeight:=25;
  1255. end;
  1256. procedure TOS2Screen.GetLine(Line: integer; var Text, Attr: string);
  1257. begin
  1258. Text:=' ';
  1259. Attr:=' ';
  1260. end;
  1261. procedure TOS2Screen.GetCursorPos(var P: TPoint);
  1262. begin
  1263. P.X:=1;
  1264. P.Y:=1;
  1265. end;
  1266. { remember the initial video screen }
  1267. procedure TOS2Screen.Capture;
  1268. begin
  1269. end;
  1270. { restore the initial video mode }
  1271. procedure TOS2Screen.Restore;
  1272. begin
  1273. end;
  1274. { move up or down if supported by OS }
  1275. function TOS2Screen.Scroll(i : integer) : integer;
  1276. begin
  1277. end;
  1278. { saves the current IDE screen }
  1279. procedure TOS2Screen.SaveIDEScreen;
  1280. begin
  1281. end;
  1282. { saves the current console screen }
  1283. procedure TOS2Screen.SaveConsoleScreen;
  1284. begin
  1285. end;
  1286. { restores the saved console screen }
  1287. procedure TOS2Screen.SwitchToConsoleScreen;
  1288. begin
  1289. end;
  1290. { restores the saved IDE screen }
  1291. procedure TOS2Screen.SwitchBackToIDEScreen;
  1292. begin
  1293. end;
  1294. constructor TOS2Screen.Init;
  1295. begin
  1296. end;
  1297. destructor TOS2Screen.Done;
  1298. begin
  1299. end;
  1300. {$ENDIF}
  1301. {****************************************************************************
  1302. TNWLScreen
  1303. ****************************************************************************}
  1304. {$ifdef netwlibc}
  1305. function TNWLScreen.GetWidth: integer;
  1306. begin
  1307. GetWidth:=80;
  1308. end;
  1309. function TNWLScreen.GetHeight: integer;
  1310. begin
  1311. GetHeight:=25;
  1312. end;
  1313. procedure TNWLScreen.GetLine(Line: integer; var Text, Attr: string);
  1314. begin
  1315. Text:=' ';
  1316. Attr:=' ';
  1317. end;
  1318. procedure TNWLScreen.GetCursorPos(var P: TPoint);
  1319. begin
  1320. P.X:=1;
  1321. P.Y:=1;
  1322. end;
  1323. { remember the initial video screen }
  1324. procedure TNWLScreen.Capture;
  1325. begin
  1326. end;
  1327. { restore the initial video mode }
  1328. procedure TNWLScreen.Restore;
  1329. begin
  1330. end;
  1331. { saves the current IDE screen }
  1332. procedure TNWLScreen.SaveIDEScreen;
  1333. begin
  1334. end;
  1335. { saves the current console screen }
  1336. procedure TNWLScreen.SaveConsoleScreen;
  1337. begin
  1338. end;
  1339. { restores the saved console screen }
  1340. procedure TNWLScreen.SwitchToConsoleScreen;
  1341. begin
  1342. end;
  1343. { restores the saved IDE screen }
  1344. procedure TNWLScreen.SwitchBackToIDEScreen;
  1345. begin
  1346. end;
  1347. {$ENDIF}
  1348. {****************************************************************************
  1349. TAmigaScreen
  1350. ****************************************************************************}
  1351. {$IFDEF AMIGASCREEN}
  1352. function TAmigaScreen.GetWidth: integer;
  1353. begin
  1354. GetWidth:=80;
  1355. end;
  1356. function TAmigaScreen.GetHeight: integer;
  1357. begin
  1358. GetHeight:=25;
  1359. end;
  1360. procedure TAmigaScreen.GetLine(Line: integer; var Text, Attr: string);
  1361. begin
  1362. Text:=' ';
  1363. Attr:=' ';
  1364. end;
  1365. procedure TAmigaScreen.GetCursorPos(var P: TPoint);
  1366. begin
  1367. P.X:=1;
  1368. P.Y:=1;
  1369. end;
  1370. { remember the initial video screen }
  1371. procedure TAmigaScreen.Capture;
  1372. begin
  1373. end;
  1374. { restore the initial video mode }
  1375. procedure TAmigaScreen.Restore;
  1376. begin
  1377. end;
  1378. { saves the current IDE screen }
  1379. procedure TAmigaScreen.SaveIDEScreen;
  1380. begin
  1381. end;
  1382. { saves the current console screen }
  1383. procedure TAmigaScreen.SaveConsoleScreen;
  1384. begin
  1385. end;
  1386. { restores the saved console screen }
  1387. procedure TAmigaScreen.SwitchToConsoleScreen;
  1388. begin
  1389. end;
  1390. { restores the saved IDE screen }
  1391. procedure TAmigaScreen.SwitchBackToIDEScreen;
  1392. begin
  1393. end;
  1394. {$ENDIF}
  1395. {****************************************************************************
  1396. Initialize
  1397. ****************************************************************************}
  1398. procedure InitUserScreen;
  1399. begin
  1400. {$ifdef DOS}
  1401. UserScreen:=New(PDOSScreen, Init);
  1402. {$else}
  1403. {$ifdef Unix}
  1404. UserScreen:=New(PLinuxScreen, Init);
  1405. {$else}
  1406. {$ifdef Windows}
  1407. UserScreen:=New(PWindowsScreen, Init);
  1408. {$else}
  1409. {$ifdef OS2}
  1410. UserScreen:=New(POS2Screen, Init);
  1411. {$else}
  1412. {$ifdef netwlibc}
  1413. UserScreen:=New(PNWLScreen, Init);
  1414. {$else}
  1415. {$ifdef AMIGASCREEN}
  1416. UserScreen:=New(PAmigaScreen, Init);
  1417. {$else}
  1418. UserScreen:=New(PScreen, Init);
  1419. {$endif AMIGASCREEN}
  1420. {$endif netwlibc}
  1421. {$endif OS2}
  1422. {$endif Windows}
  1423. {$endif Unix}
  1424. {$endif Dos}
  1425. end;
  1426. procedure DoneUserScreen;
  1427. begin
  1428. if UserScreen<>nil then
  1429. begin
  1430. UserScreen^.Restore;
  1431. Dispose(UserScreen, Done);
  1432. UserScreen:=nil;
  1433. end;
  1434. end;
  1435. end.