123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602 |
- {
- This file is part of the Free Pascal Integrated Development Environment
- Copyright (c) 1998 by Berczi Gabor
- User screen support routines
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- {$i globdir.inc}
- unit FPUsrScr;
- interface
- uses
- {$ifdef Windows}
- windows,
- {$endif Windows}
- {$ifdef Unix}
- baseunix,
- termio,
- {$ifdef linux}
- linuxvcs,
- {$endif}
- {$endif}
- video,Objects;
- type
- PScreen = ^TScreen;
- TScreen = object(TObject)
- function GetWidth: integer; virtual;
- function GetHeight: integer; virtual;
- procedure GetLine(Line: integer; var Text, Attr: string); virtual;
- procedure GetCursorPos(var P: TPoint); virtual;
- { remember the initial video screen }
- procedure Capture; virtual;
- { restore the initial video mode }
- procedure Restore; virtual;
- { move up or down if supported by OS }
- function Scroll(i : integer) : integer; virtual;
- { is moving supported by OS }
- function CanScroll : boolean; virtual;
- { saves the current IDE screen }
- procedure SaveIDEScreen; virtual;
- { saves the current console screen }
- procedure SaveConsoleScreen; virtual;
- { restores the saved console screen }
- procedure SwitchToConsoleScreen; virtual;
- { restores the saved IDE screen }
- procedure SwitchBackToIDEScreen; virtual;
- end;
- {$IFDEF netwlibc}
- PNWLScreen = ^TNWLScreen;
- TNWLScreen = object(TScreen)
- function GetWidth: integer; virtual;
- function GetHeight: integer; virtual;
- procedure GetLine(Line: integer; var Text, Attr: string); virtual;
- procedure GetCursorPos(var P: TPoint); virtual;
- { remember the initial video screen }
- procedure Capture; virtual;
- { restore the initial video mode }
- procedure Restore; virtual;
- { saves the current IDE screen }
- procedure SaveIDEScreen; virtual;
- { saves the current console screen }
- procedure SaveConsoleScreen; virtual;
- { restores the saved console screen }
- procedure SwitchToConsoleScreen; virtual;
- { restores the saved IDE screen }
- procedure SwitchBackToIDEScreen; virtual;
- end;
- {$ENDIF}
- {$IFDEF AMIGA}
- {$DEFINE AMIGASCREEN}
- {$ENDIF}
- {$IFDEF MORPHOS}
- {$DEFINE AMIGASCREEN}
- {$ENDIF}
- {$IFDEF AROS}
- {$DEFINE AMIGASCREEN}
- {$ENDIF}
- {$IFDEF AMIGASCREEN}
- PAmigaScreen = ^TAmigaScreen;
- TAmigaScreen = object(TScreen)
- function GetWidth: integer; virtual;
- function GetHeight: integer; virtual;
- procedure GetLine(Line: integer; var Text, Attr: string); virtual;
- procedure GetCursorPos(var P: TPoint); virtual;
- { remember the initial video screen }
- procedure Capture; virtual;
- { restore the initial video mode }
- procedure Restore; virtual;
- { saves the current IDE screen }
- procedure SaveIDEScreen; virtual;
- { saves the current console screen }
- procedure SaveConsoleScreen; virtual;
- { restores the saved console screen }
- procedure SwitchToConsoleScreen; virtual;
- { restores the saved IDE screen }
- procedure SwitchBackToIDEScreen; virtual;
- end;
- {$ENDIF}
- {$IFDEF OS2}
- POS2Screen = ^TOS2Screen;
- TOS2Screen = object(TScreen)
- constructor Init;
- destructor Done; virtual;
- public
- function GetWidth: integer; virtual;
- function GetHeight: integer; virtual;
- procedure GetLine(Line: integer; var Text, Attr: string); virtual;
- procedure GetCursorPos(var P: TPoint); virtual;
- { remember the initial video screen }
- procedure Capture; virtual;
- { restore the initial video mode }
- procedure Restore; virtual;
- { move up or down if supported by OS }
- function Scroll(i : integer) : integer; virtual;
- { saves the current IDE screen }
- procedure SaveIDEScreen; virtual;
- { saves the current console screen }
- procedure SaveConsoleScreen; virtual;
- { restores the saved console screen }
- procedure SwitchToConsoleScreen; virtual;
- { restores the saved IDE screen }
- procedure SwitchBackToIDEScreen; virtual;
- end;
- {$ENDIF}
- {$ifdef DOS}
- TDOSVideoInfo = record
- Mode : word;
- ScreenSize: word;
- Page : byte;
- Rows,Cols : integer;
- CurPos : TPoint;
- CurShapeT : integer;
- CurShapeB : integer;
- StateSize : word;
- StateBuf : pointer;
- end;
- PDOSScreen = ^TDOSScreen;
- TDOSScreen = object(TScreen)
- constructor Init;
- destructor Done; virtual;
- public
- function GetWidth: integer; virtual;
- function GetHeight: integer; virtual;
- procedure GetLine(Line: integer; var Text, Attr: string); virtual;
- procedure GetCursorPos(var P: TPoint); virtual;
- procedure Capture; virtual;
- procedure Restore; virtual;
- procedure SaveIDEScreen; virtual;
- procedure SaveConsoleScreen; virtual;
- procedure SwitchToConsoleScreen; virtual;
- procedure SwitchBackToIDEScreen; virtual;
- procedure FreeGraphBuffer;
- private
- LastTextConsoleVideoInfo,
- ConsoleVideoInfo : TDOSVideoInfo;
- VBufferSize : longint;
- VIDEBufferSize : longint;
- VBuffer : PByteArray;
- VIDEBuffer : PByteArray;
- IDEVideoInfo : TDOSVideoInfo;
- ctrl_c_state : boolean;
- {$ifdef USE_GRAPH_SWITCH}
- GraphImageSize : longint;
- GraphDriverName,
- GraphModeName : string;
- GraphXres,GraphYres : longint;
- GraphBuffer : pointer;
- ConsoleGraphDriver, ConsoleGraphMode : word;
- {$endif USE_GRAPH_SWITCH}
- function GetLineStartOfs(Line: integer): word;
- procedure GetBuffer(Size: word);
- procedure FreeBuffer;
- procedure GetVideoMode(var MI: TDOSVideoInfo);
- procedure SetVideoMode(MI: TDOSVideoInfo);
- end;
- {$endif}
- {$ifdef Unix}
- TConsoleType = (ttyNetwork,ttyLinux,ttyFreeBSD,ttyNetBSD);
- PLinuxScreen = ^TLinuxScreen;
- TLinuxScreen = object(TScreen)
- constructor Init;
- destructor Done; virtual;
- public
- function GetWidth: integer; virtual;
- function GetHeight: integer; virtual;
- procedure GetLine(Line: integer; var Text, Attr: string); virtual;
- procedure GetCursorPos(var P: TPoint); virtual;
- procedure Capture; virtual;
- procedure Restore; virtual;
- procedure SaveIDEScreen; virtual;
- procedure SaveConsoleScreen; virtual;
- procedure SwitchToConsoleScreen; virtual;
- procedure SwitchBackToIDEScreen; virtual;
- private
- IdeScreen: PByteArray;
- IdeSize : longint;
- IsXterm : boolean;
- Console : TConsoleType;
- TTyfd : longint;
- ConsVideoBuf : PByteArray;
- ConsHeight, ConsWidth,
- ConsCursorX, ConsCursorY : byte;
- ConsVideoBufSize : longint;
- ConsTio : termios;
- ConsTioValid : boolean;
- end;
- {$endif}
- {$ifdef Windows}
- PWindowsScreen = ^TWindowsScreen;
- TWindowsScreen = object(TScreen)
- constructor Init;
- destructor Done; virtual;
- public
- function GetWidth: integer; virtual;
- function GetHeight: integer; virtual;
- procedure GetLine(Line: integer; var Text, Attr: string); virtual;
- procedure GetCursorPos(var P: TPoint); virtual;
- function CanScroll : boolean; virtual;
- function Scroll(i : integer) : integer; virtual;
- procedure Capture; virtual;
- procedure Restore; virtual;
- procedure SaveIDEScreen; virtual;
- procedure SaveConsoleScreen; virtual;
- procedure SwitchToConsoleScreen; virtual;
- procedure SwitchBackToIDEScreen; virtual;
- private
- DosScreenBufferHandle,
- IDEScreenBufferHandle,
- StartScreenBufferHandle,
- DummyScreenBufferHandle,
- NewScreenBufferHandle : THandle;
- IDEActive : boolean;
- ConsoleMode,IdeMode : Dword;
- IdeScreenMode : TVideoMode;
- procedure BufferCopy(src,dest : THandle);
- {$ifdef debug}
- procedure Complain(St : string);
- Procedure SetConsoleMode(FH : Handle;Mode : DWord);
- {$endif debug}
- end;
- {$endif}
- procedure InitUserScreen;
- procedure DoneUserScreen;
- const UserScreen : PScreen = nil;
- implementation
- uses
- Dos,WUtils
- {$ifdef GO32V2}
- ,Dpmiexcp, Go32
- {$endif}
- ,Drivers,App
- {$ifdef USE_GRAPH_SWITCH}
- ,Graph,VESA
- {$else not USE_GRAPH_SWITCH}
- {$ifdef VESA}
- ,VESA
- {$endif VESA}
- {$endif not USE_GRAPH_SWITCH}
- ;
- function TScreen.GetWidth: integer;
- begin
- Getwidth:=0;
- Abstract;
- end;
- function TScreen.GetHeight: integer;
- begin
- Getheight:=0;
- Abstract;
- end;
- procedure TScreen.GetLine(Line: integer; var Text, Attr: string);
- begin
- Abstract;
- end;
- procedure TScreen.GetCursorPos(var P: TPoint);
- begin
- Abstract;
- end;
- procedure TScreen.Capture;
- begin
- Abstract;
- end;
- procedure TScreen.Restore;
- begin
- Abstract;
- end;
- procedure TScreen.SwitchToConsoleScreen;
- begin
- Abstract;
- end;
- procedure TScreen.SwitchBackToIDEScreen;
- begin
- Abstract;
- end;
- procedure TScreen.SaveIDEScreen;
- begin
- Abstract;
- end;
- function TScreen.Scroll(i : integer) : integer;
- begin
- Scroll:=0;
- end;
- function TScreen.CanScroll : boolean;
- begin
- CanScroll:=false;
- end;
- procedure TScreen.SaveConsoleScreen;
- begin
- Abstract;
- end;
- {****************************************************************************
- TDOSScreen
- ****************************************************************************}
- {$ifdef DOS}
- constructor TDOSScreen.Init;
- begin
- inherited Init;
- FillChar(LastTextConsoleVideoInfo,Sizeof(TDOSVideoInfo),#0);
- Capture;
- { get the current ctrl-C state }
- Ctrl_c_state:=djgpp_set_ctrl_c(false);
- djgpp_set_ctrl_c(Ctrl_c_state);
- end;
- destructor TDOSScreen.Done;
- begin
- FreeBuffer;
- if assigned(VIDEBuffer) then
- FreeMem(VIDEBuffer,VIDEBufferSize);
- inherited Done;
- end;
- function TDOSScreen.GetWidth: integer;
- begin
- GetWidth:=ConsoleVideoInfo.Cols;
- end;
- function TDOSScreen.GetHeight: integer;
- begin
- GetHeight:=ConsoleVideoInfo.Rows;
- end;
- procedure TDOSScreen.GetLine(Line: integer; var Text, Attr: string);
- var
- X: integer;
- W: word;
- begin
- Text:=''; Attr:='';
- if (Line<GetHeight) and
- {$ifdef USE_GRAPH_SWITCH}
- not assigned(GraphBuffer) and
- {$endif USE_GRAPH_SWITCH}
- assigned(VBuffer) then
- begin
- W:=GetLineStartOfs(Line);
- for X:=0 to GetWidth-1 do
- begin
- {Text:=Text+chr(VBuffer^[W+X*2]);
- Attr:=Attr+chr(VBuffer^[W+X*2+1]);}
- System.Insert(chr(VBuffer^[W+X*2]),Text,Length(Text)+1);
- System.Insert(chr(VBuffer^[W+X*2+1]),Attr,Length(Attr)+1);
- end;
- {$ifdef USE_GRAPH_SWITCH}
- end
- else if assigned(GraphBuffer) then
- begin
- if (Line=0) then
- Text:='Console in graph mode, use Alt+F5'
- else if (Line=1) then
- Text:='Graph driver: '+GraphDriverName
- else if (Line=2) then
- Text:='Graph mode: '+GraphModeName+' ('+
- IntToStr(GraphXres+1)+'x'+IntToStr(GraphYres+1)+')';
- Attr:=CharStr(chr($0F),Length(Text));
- end;
- {$else not USE_GRAPH_SWITCH}
- end;
- {$endif USE_GRAPH_SWITCH}
- end;
- procedure TDOSScreen.GetCursorPos(var P: TPoint);
- begin
- P:=ConsoleVideoInfo.CurPos;
- end;
- procedure TDOSScreen.Capture;
- begin
- SaveConsoleScreen;
- end;
- procedure TDOSScreen.FreeGraphBuffer;
- begin
- { We don't want to restore the last user screen if
- it was a grpahic screen, for example if we
- leave in the middle of the debugging of a
- graphic program, so we first
- dispose the graphic buffer, thus
- SwitchToConsoleScreen will restore the
- last used text mode }
- if LastTextConsoleVideoInfo.Mode<>0 then
- begin
- ConsoleVideoInfo:=LastTextConsoleVideoInfo;
- {$ifdef USE_GRAPH_SWITCH}
- if assigned(GraphBuffer) then
- begin
- FreeMem(GraphBuffer,GraphImageSize);
- GraphBuffer:=nil;
- GraphImageSize:=0;
- end;
- {$endif USE_GRAPH_SWITCH}
- end;
- end;
- procedure TDosScreen.Restore;
- begin
- FreeGraphBuffer;
- SwitchToConsoleScreen;
- end;
- procedure TDosScreen.SaveIDEScreen;
- var
- VSeg,SOfs: word;
- begin
- GetVideoMode(IDEVideoInfo);
- { First keep a copy of IDE screen }
- if ConsoleVideoInfo.Mode=7 then
- VSeg:=SegB000
- else
- VSeg:=SegB800;
- SOfs:=MemW[Seg0040:$4e];
- if not assigned(VIDEBuffer) or (VIDEBufferSize<>IDEVideoInfo.ScreenSize) then
- begin
- if assigned(VIDEBuffer) then
- FreeMem(VIDEBuffer,VIDEBufferSize);
- GetMem(VIDEBuffer,IDEVideoInfo.ScreenSize);
- VIDEBufferSize:=IDEVideoInfo.ScreenSize;
- end;
- DosmemGet(VSeg,SOfs,VIDEBuffer^,IDEVideoInfo.ScreenSize);
- end;
- procedure TDosScreen.SaveConsoleScreen;
- var
- VSeg,SOfs: word;
- {$ifdef USE_GRAPH_SWITCH}
- saved : boolean;
- GraphDriver,GraphMode : integer;
- {$endif USE_GRAPH_SWITCH}
- begin
- GetVideoMode(ConsoleVideoInfo);
- {$ifdef USE_GRAPH_SWITCH}
- saved:=false;
- if assigned(GraphBuffer) then
- begin
- FreeMem(GraphBuffer,GraphImageSize);
- GraphBuffer:=nil;
- GraphImageSize:=0;
- end;
- if (ConsoleVideoInfo.Mode>= $100) or
- (ConsoleVideoInfo.Mode=$13) or
- (ConsoleVideoInfo.Mode=$12) or
- (ConsoleVideoInfo.Mode=$10) or
- (ConsoleVideoInfo.Mode=$E) then
- begin
- if VesaSetMode(ConsoleVideoInfo.Mode or $8000) then
- begin
- Graph.DontClearGraphMemory:=true;
- if ConsoleVideoInfo.Mode>=$100 then
- begin
- GraphDriver:=Graph.Vesa;
- GraphMode:=ConsoleVideoInfo.Mode and $fff;
- end
- else
- begin
- GraphDriver:=Graph.VGA;
- case ConsoleVideoInfo.Mode of
- $E : GraphMode:=VGALo;
- $10 : GraphMode:=VGAMed;
- $12 : GraphMode:=VGAHi;
- $13 : begin
- GraphDriver:=Graph.LowRes;
- GraphMode:=0;
- end;
- end;
- end;
- Graph.InitGraph(GraphDriver,GraphMode,'');
- if graphresult=grOk then
- begin
- ConsoleGraphDriver:=GraphDriver;
- GraphDriverName:=GetDriverName;
- GraphModeName:=GetModeName(GraphMode);
- ConsoleGraphMode:=GraphMode;
- Graph.DontClearGraphMemory:=false;
- GraphXres:=Graph.GetmaxX;
- GraphYres:=Graph.GetmaxY;
- GraphImageSize:=ImageSize(0,0,GraphXres,GraphYres);
- GetMem(GraphBuffer,GraphImageSize);
- FillChar(GraphBuffer^,GraphImageSize,#0);
- GetImage(0,0,GraphXres,GraphYres,GraphBuffer^);
- ConsoleVideoInfo.Rows:=GraphYres div 8;
- ConsoleVideoInfo.Cols:=GraphXres div 8;
- {FreeBuffer;}
- saved:=true;
- end
- {$ifdef DEBUG}
- else
- Writeln(stderr,'Error in InitGraph ',Graphdriver, ' ',Graphmode)
- {$endif DEBUG}
- ;
- end;
- end;
- { mode < $100 so use standard Save code }
- if not saved then
- {$endif USE_GRAPH_SWITCH}
- begin
- LastTextConsoleVideoInfo:=ConsoleVideoInfo;
- GetBuffer(ConsoleVideoInfo.ScreenSize);
- if ConsoleVideoInfo.Mode=7 then
- VSeg:=SegB000
- else
- VSeg:=SegB800;
- SOfs:=MemW[Seg0040:$4e];
- DosmemGet(VSeg,SOfs,VBuffer^,ConsoleVideoInfo.ScreenSize);
- end;
- end;
- procedure TDOSScreen.SwitchToConsoleScreen;
- var
- VSeg,SOfs: word;
- {$ifdef USE_GRAPH_SWITCH}
- restored : boolean;
- GraphDriver,GraphMode : integer;
- {$endif USE_GRAPH_SWITCH}
- begin
- SetVideoMode(ConsoleVideoInfo);
- {$ifdef USE_GRAPH_SWITCH}
- restored:=false;
- if assigned(GraphBuffer) then
- begin
- if VesaSetMode(ConsoleVideoInfo.Mode) then
- begin
- if ConsoleVideoInfo.Mode>=$100 then
- begin
- GraphDriver:=Graph.Vesa;
- GraphMode:=ConsoleVideoInfo.Mode and $fff;
- end
- else
- begin
- GraphDriver:=Graph.VGA;
- case ConsoleVideoInfo.Mode of
- $E : GraphMode:=VGALo;
- $10 : GraphMode:=VGAMed;
- $12 : GraphMode:=VGAHi;
- $13 : begin
- GraphDriver:=Graph.LowRes;
- GraphMode:=0;
- end;
- end;
- end;
- if (ConsoleGraphDriver<>GraphDriver) or
- (ConsoleGraphMode<>GraphMode) then
- Graph.InitGraph(GraphDriver,GraphMode,'');
- if graphresult=grOk then
- begin
- PutImage(0,0,GraphBuffer^,CopyPut);
- FreeMem(GraphBuffer,GraphImageSize);
- GraphBuffer:=nil;
- GraphImageSize:=0;
- restored:=true;
- end;
- end;
- end;
- { mode < $100 so use standard Save code }
- if not restored then
- {$endif USE_GRAPH_SWITCH}
- begin
- if ConsoleVideoInfo.Mode=7 then
- VSeg:=SegB000
- else
- VSeg:=SegB800;
- SOfs:=MemW[Seg0040:$4e];
- DosmemPut(VSeg,SOfs,VBuffer^,ConsoleVideoInfo.ScreenSize);
- djgpp_set_ctrl_c(Ctrl_c_state);
- end;
- end;
- procedure TDOSScreen.SwitchBackToIDEScreen;
- var
- VSeg,SOfs: word;
- begin
- SetVideoMode(IDEVideoInfo);
- if ConsoleVideoInfo.Mode=7 then
- VSeg:=SegB000
- else
- VSeg:=SegB800;
- SOfs:=MemW[Seg0040:$4e];
- if assigned(VIDEBuffer) then
- DosmemPut(VSeg,SOfs,VIDEBuffer^,IDEVideoInfo.ScreenSize);
- Ctrl_c_state := djgpp_set_ctrl_c(false);
- { Its difficult to know
- the state of the mouse
- so simply show it always
- fixes bug 2253 PM }
- ShowMouse;
- end;
- function TDOSScreen.GetLineStartOfs(Line: integer): word;
- begin
- GetLineStartOfs:=(ConsoleVideoInfo.Cols*Line)*2;
- end;
- procedure TDOSScreen.GetBuffer(Size: word);
- begin
- if (VBuffer<>nil) and (VBufferSize=Size) then Exit;
- if VBuffer<>nil then FreeBuffer;
- VBufferSize:=Size;
- GetMem(VBuffer,VBufferSize);
- end;
- procedure TDOSScreen.FreeBuffer;
- begin
- if (VBuffer<>nil) and (VBufferSize>0) then FreeMem(VBuffer,VBufferSize);
- VBuffer:=nil;
- end;
- procedure TDOSScreen.GetVideoMode(var MI: TDOSVideoInfo);
- var
- r: registers;
- begin
- if (MI.StateSize>0) and (MI.StateBuf<>nil) then
- begin FreeMem(MI.StateBuf,MI.StateSize); MI.StateBuf:=nil; end;
- MI.ScreenSize:=MemW[Seg0040:$4c];
- r.ah:=$0f;
- intr($10,r);
- MI.Mode:=r.al;
- MI.Page:=r.bh;
- MI.Cols:=r.ah;
- {$ifdef VESA}
- VESAGetMode(MI.Mode);
- MI.Mode:=MI.Mode and $fff;
- {$endif}
- MI.Rows:=MI.ScreenSize div (MI.Cols*2);
- if MI.Rows=51 then MI.Rows:=50;
- r.ah:=$03;
- r.bh:=MI.Page;
- intr($10,r);
- with MI do
- begin
- CurPos.X:=r.dl; CurPos.Y:=r.dh;
- CurShapeT:=r.ch; CurShapeB:=r.cl;
- end;
- end;
- procedure TDOSScreen.SetVideoMode(MI: TDOSVideoInfo);
- var r: registers;
- CM: TDOSVideoInfo;
- begin
- FillChar(CM,sizeof(CM),0);
- GetVideoMode(CM);
- if (CM.Mode<>MI.Mode) or (CM.Cols<>MI.Cols) or (CM.Rows<>MI.Rows) then
- begin
- {$ifdef VESA}
- if MI.Mode>=$100 then
- VESASetMode(MI.Mode)
- else
- {$endif}
- begin
- r.ah:=$00; r.al:=MI.Mode; intr($10,r);
- end;
- if (MI.Mode=3) and (MI.Cols=80) and (MI.Rows=50) then
- begin
- r.ax:=$1112; r.bx:=$0;
- intr($10,r);
- end;
- end;
- r.ah:=$05; r.al:=MI.Page; intr($10,r);
- r.ah:=$02; r.bh:=MI.Page; r.dl:=MI.CurPos.X; r.dh:=MI.CurPos.Y; intr($10,r);
- r.ah:=$01; r.ch:=MI.CurShapeT; r.cl:=MI.CurShapeB; intr($10,r);
- end;
- {$endif}
- {****************************************************************************
- TLinuxScreen
- ****************************************************************************}
- {$ifdef Unix}
- constructor TLinuxScreen.Init;
- var
- ThisTTY: string[30];
- FName: string;
- WS: packed record
- ws_row, ws_col, ws_xpixel, ws_ypixel: Word;
- end;
- begin
- inherited Init;
- IdeScreen := nil;
- TTYFd:=-1;
- IsXterm:=getenv('TERM')='xterm';
- ThisTTY:=TTYName(stdinputhandle);
- if Not IsXterm and (IsATTY(stdinputhandle)<>-1) then
- begin
- Console:=TTyNetwork; {Default: Network or other vtxxx tty}
- if ((Copy(ThisTTY, 1, 8) = '/dev/tty') and (ThisTTY[9]<>'p')) or (Copy(ThisTTY,1,8)='/dev/vc/') Then
- begin
- Case ThisTTY[9] of
- '0'..'9' :
- begin { running Linux on native console or native-emulation }
- {$ifdef linux}
- FName:='/dev/vcsa' + ThisTTY[9];
- TTYFd:=fpOpen(FName, &666, O_RdWr); { open console }
- if TTYFd = -1 then
- begin
- if try_grab_vcsa then
- TTYFd:=fpOpen(FName, &666, O_RdWr); { try again }
- end;
- If TTYFd <>-1 Then
- Console:=ttyLinux;
- {$endif}
- end;
- 'v' : { check for (Free?)BSD native}
- If (ThisTTY[10]>='0') and (ThisTTY[10]<='9') Then
- Console:=ttyFreeBSD; {TTYFd ?}
- end;
- end;
- If Copy(GetEnv('TERM'),1,6)='cons25' Then
- Console:=ttyFreeBSD;
- fpioctl(stdinputhandle, TIOCGWINSZ, @WS);
- if WS.ws_Col=0 then
- WS.ws_Col:=80;
- if WS.ws_Row=0 then
- WS.ws_Row:=25;
- ConsWidth:=WS.ws_Col;
- ConsHeight:=WS.ws_row;
- end;
- Capture;
- end;
- destructor TLinuxScreen.Done;
- begin
- if assigned(IdeScreen) then
- freemem(IdeScreen,IdeSize);
- if assigned(ConsVideoBuf) then
- freemem(ConsVideoBuf,ConsVideoBufSize);
- inherited Done;
- end;
- function TLinuxScreen.GetWidth: integer;
- begin
- GetWidth:=ConsWidth;
- end;
- function TLinuxScreen.GetHeight: integer;
- begin
- GetHeight:=ConsHeight;
- end;
- procedure TLinuxScreen.GetLine(Line: integer; var Text, Attr: string);
- var
- X, W : longint;
- begin
- Text:='';
- Attr:='';
- if (TtyFd<>-1) and assigned(ConsVideoBuf) then
- begin
- if Line<GetHeight then
- begin
- W:=(ConsWidth*Line)*Sizeof(word);
- for X:=0 to GetWidth-1 do
- begin
- {Text:=Text+chr(VBuffer^[W+X*2]);
- Attr:=Attr+chr(VBuffer^[W+X*2+1]);}
- System.Insert(chr(ConsVideoBuf^[W+X*2]),Text,Length(Text)+1);
- System.Insert(chr(ConsVideoBuf^[W+X*2+1]),Attr,Length(Attr)+1);
- end;
- end;
- end;
- end;
- procedure TLinuxScreen.GetCursorPos(var P: TPoint);
- begin
- P.X:=ConsCursorX+1;
- P.Y:=ConsCursorY+1;
- end;
- procedure TLinuxScreen.Capture;
- begin
- SaveConsoleScreen;
- end;
- procedure TLinuxScreen.Restore;
- begin
- SwitchToConsoleScreen;
- end;
- procedure TLinuxScreen.SaveIDEScreen;
- begin
- if assigned(IdeScreen) then
- freemem(IdeScreen,IdeSize);
- getmem(IdeScreen,videobufsize);
- IdeSize:=videobufsize;
- move(videobuf^,IdeScreen^,videobufsize);
- end;
- procedure TLinuxScreen.SaveConsoleScreen;
- var
- NewSize : longint;
- begin
- if IsXTerm then
- write(#27'7'#27'[?47h')
- else if (TTYfd<>-1) then
- begin
- fpLSeek(TTYFd, 0, Seek_Set);
- fpread(TTYFd,ConsHeight,sizeof(byte));
- fpread(TTYFd,ConsWidth,sizeof(byte));
- fpread(TTYFd,ConsCursorX,sizeof(byte));
- fpread(TTYFd,ConsCursorY,sizeof(byte));
- NewSize:=ConsWidth*ConsHeight*sizeof(word);
- if (NewSize<>ConsVideoBufSize) and
- assigned(ConsVideoBuf) then
- Begin
- FreeMem(ConsVideoBuf,ConsVideoBufSize);
- ConsVideoBuf:=nil;
- End;
- If not assigned(ConsVideoBuf) then
- GetMem(ConsVideoBuf,NewSize);
- ConsVideoBufSize:=NewSize;
- fpread(TTYFd,ConsVideoBuf^,ConsVideoBufSize);
- end
- else
- begin
- ConsWidth:=80;
- ConsHeight:=25;
- ConsCursorX:=0;
- ConsCursorY:=0;
- ConsVideoBuf:=nil;
- end;
- ConsTioValid:=(TCGetAttr(1,ConsTio)<>-1);
- end;
- procedure TLinuxScreen.SwitchToConsoleScreen;
- begin
- if IsXterm then
- begin
- write(#27'[0m');
- write(#27'[?47l'#27'8'#27'[m');
- end
- else if (TTyfd<>-1) then
- begin
- fplSeek(TTYFd, 2, Seek_Set);
- fpwrite(TTYFd, ConsCursorX, sizeof(byte));
- fpwrite(TTYFd, ConsCursorY, sizeof(byte));
- fpwrite(TTYFd, ConsVideoBuf^,ConsVideoBufSize);
- { FreeMem(ConsVideoBuf,ConsVideoBufSize);
- ConsVideoBuf:=nil; }
- end;
- If ConsTioValid then
- TCSetAttr(1,TCSANOW,ConsTio);
- end;
- procedure TLinuxScreen.SwitchBackToIDEScreen;
- begin
- if IdeScreen = nil then
- exit;
- move(IdeScreen^,videobuf^,videobufsize);
- freemem(IdeScreen,IdeSize);
- IdeScreen := nil;
- end;
- {$endif}
- {****************************************************************************
- TWindowsScreen
- ****************************************************************************}
- {$ifdef Windows}
- { Seems to be missing in windows unit PM }
- const
- ENABLE_INSERT_MODE = $20;
- ENABLE_QUICK_EDIT_MODE = $40;
- ENABLE_EXTENDED_FLAGS = $80;
- ENABLE_AUTO_POSITION = $100;
- procedure UpdateFileHandles;
- begin
- {StdInputHandle:=longint(GetStdHandle(STD_INPUT_HANDLE));}
- StdOutputHandle:=longint(GetStdHandle(cardinal(STD_OUTPUT_HANDLE)));
- {StdErrorHandle:=longint(GetStdHandle(STD_ERROR_HANDLE));}
- TextRec(Output).Handle:=StdOutputHandle;
- TextRec(StdOut).Handle:=StdOutputHandle;
- {TextRec(StdErr).Handle:=StdErrorHandle;}
- end;
- constructor TWindowsScreen.Init;
- var
- SecurityAttr : Security_attributes;
- BigWin : Coord;
- res : longbool;
- Error : dword;
- ConsoleScreenBufferInfo : Console_screen_buffer_info;
- begin
- inherited Init;
- {if GetConsoleOutputCP<>437 then
- res:=SetConsoleOutputCP(437);}
- SecurityAttr.nLength:=SizeOf(Security_attributes);
- SecurityAttr.lpSecurityDescriptor:=nil;
- SecurityAttr.bInheritHandle:=true;
- NewScreenBufferHandle:=CreateConsoleScreenBuffer(
- GENERIC_READ or GENERIC_WRITE,
- FILE_SHARE_READ or FILE_SHARE_WRITE,SecurityAttr,
- CONSOLE_TEXTMODE_BUFFER,nil);
- DummyScreenBufferHandle:=CreateConsoleScreenBuffer(
- GENERIC_READ or GENERIC_WRITE,
- FILE_SHARE_READ or FILE_SHARE_WRITE,SecurityAttr,
- CONSOLE_TEXTMODE_BUFFER,nil);
- StartScreenBufferHandle:=GetStdHandle(cardinal(STD_OUTPUT_HANDLE));
- GetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), @ConsoleMode);
- IdeMode:=ConsoleMode;
- {$ifdef debug}
- Complain('Starting ConsoleMode is $'+hexstr(ConsoleMode,8));
- {define Windowsbigwin}
- {$endif debug}
- {$ifdef Windowsbigwin}
- GetConsoleScreenBufferInfo(StartScreenBufferHandle,
- @ConsoleScreenBufferInfo);
- BigWin.X:=ConsoleScreenBufferInfo.dwSize.X;
- BigWin.Y:=ConsoleScreenBufferInfo.srwindow.bottom-ConsoleScreenBufferInfo.srwindow.top; // mants 15779 was 200
- { Try to allow to store more info }
- res:=SetConsoleScreenBufferSize(NewScreenBufferHandle,BigWin);
- if not res then
- error:=GetLastError;
- res:=SetConsoleScreenBufferSize(StartScreenBufferHandle,BigWin);
- if not res then
- error:=GetLastError;
- {$endif Windowsbigwin}
- GetConsoleScreenBufferInfo(StartScreenBufferHandle,
- @ConsoleScreenBufferInfo);
- { make sure that the IDE Screen Handle has the maximum display size
- this removes the scroll bars if it is maximized }
- BigWin.X:=ConsoleScreenBufferInfo.dwSize.X;
- BigWin.Y:=ConsoleScreenBufferInfo.srwindow.bottom-ConsoleScreenBufferInfo.srwindow.top;
- res:=SetConsoleScreenBufferSize(NewScreenBufferHandle,
- BigWin);
- // mants 15779 : was
- // res:=SetConsoleScreenBufferSize(NewScreenBufferHandle,
- // ConsoleScreenBufferInfo.dwMaximumWindowSize);
- if not res then
- error:=GetLastError;
- IDEScreenBufferHandle:=NewScreenBufferHandle;
- DosScreenBufferHandle:=StartScreenBufferHandle;
- Capture;
- IdeScreenMode.row:=0;
- SwitchBackToIDEScreen;
- end;
- destructor TWindowsScreen.Done;
- begin
- { copy the Dos buffer content into the original ScreenBuffer
- which remains the startup std_output_handle PM }
- {if StartScreenBufferHandle=IDEScreenBufferHandle then}
- BufferCopy(DosScreenBufferHandle,IDEScreenBufferHandle);
- SetConsoleActiveScreenBuffer(StartScreenBufferHandle);
- SetStdHandle(cardinal(Std_Output_Handle),StartScreenBufferHandle);
- UpdateFileHandles;
- CloseHandle(NewScreenBufferHandle);
- CloseHandle(DummyScreenBufferHandle);
- inherited Done;
- end;
- function TWindowsScreen.GetWidth: integer;
- var
- ConsoleScreenBufferInfo : Console_screen_buffer_info;
- begin
- GetConsoleScreenBufferInfo(DosScreenBufferHandle,
- @ConsoleScreenBufferInfo);
- GetWidth:=ConsoleScreenBufferInfo.dwSize.X;
- end;
- function TWindowsScreen.GetHeight: integer;
- var
- ConsoleScreenBufferInfo : Console_screen_buffer_info;
- begin
- GetConsoleScreenBufferInfo(DosScreenBufferHandle,
- @ConsoleScreenBufferInfo);
- GetHeight:=ConsoleScreenBufferInfo.dwSize.Y;
- end;
- function TWindowsScreen.CanScroll : boolean;
- var
- ConsoleScreenBufferInfo : Console_screen_buffer_info;
- BufferLines : longint;
- WindowLines : longint;
- begin
- GetConsoleScreenBufferInfo(DosScreenBufferHandle,
- @ConsoleScreenBufferInfo);
- WindowLines:=ConsoleScreenBufferInfo.srWindow.Bottom-
- ConsoleScreenBufferInfo.srWindow.Top;
- BufferLines:= ConsoleScreenBufferInfo.dwSize.Y-1;
- CanScroll:=(BufferLines>WindowLines);
- end;
- function TWindowsScreen.Scroll(i : integer) : integer;
- var
- ConsoleScreenBufferInfo : Console_screen_buffer_info;
- ConsoleWindow : Small_rect;
- begin
- GetConsoleScreenBufferInfo(DosScreenBufferHandle,
- @ConsoleScreenBufferInfo);
- if (ConsoleScreenBufferInfo.srWindow.Top + i < 0) then
- i:= -ConsoleScreenBufferInfo.srWindow.Top;
- if (ConsoleScreenBufferInfo.srWindow.Bottom + i > ConsoleScreenBufferInfo.dwSize.Y) then
- i:= ConsoleScreenBufferInfo.dwSize.Y - ConsoleScreenBufferInfo.srWindow.Bottom;
- if i<>0 then
- begin
- ConsoleWindow.Left:=ConsoleScreenBufferInfo.srWindow.Left;
- ConsoleWindow.Right:=ConsoleScreenBufferInfo.srWindow.Right;
- ConsoleWindow.Top:=ConsoleScreenBufferInfo.srWindow.Top+i;
- ConsoleWindow.Bottom:=ConsoleScreenBufferInfo.srWindow.Bottom+i;
- SetConsoleWindowInfo(DosScreenBufferHandle,true,ConsoleWindow);
- Scroll:=i;
- end
- else
- Scroll:=0;
- end;
- procedure TWindowsScreen.GetLine(Line: integer; var Text, Attr: string);
- type
- CharInfoArray = Array [0..255] of Char_Info;
- var
- LineBuf : ^CharInfoArray;
- BufSize,BufCoord : Coord;
- i,LineSize : longint;
- WriteRegion : SMALL_RECT;
- begin
- GetMem(LineBuf,SizeOf(CharInfoArray));
- LineSize:=ScreenWidth;
- If LineSize>256 then
- LineSize:=256;
- BufSize.X:=LineSize;
- BufSize.Y:=1;
- BufCoord.X:=0;
- BufCoord.Y:=0;
- with WriteRegion do
- begin
- Top :=Line;
- Left :=0;
- Bottom := Line+1;
- Right := LineSize-1;
- end;
- ReadConsoleOutput(DosScreenBufferHandle, PChar_info(LineBuf),
- BufSize, BufCoord, @WriteRegion);
- for i:=1 to LineSize do
- begin
- Text[i]:=LineBuf^[i-1].AsciiChar;
- Attr[i]:=char(byte(LineBuf^[i-1].Attributes));
- end;
- FreeMem(LineBuf,SizeOf(CharInfoArray));
- Text[0]:=char(byte(LineSize));
- Attr[0]:=char(byte(LineSize));
- end;
- procedure TWindowsScreen.GetCursorPos(var P: TPoint);
- var
- ConsoleScreenBufferInfo : Console_screen_buffer_info;
- begin
- GetConsoleScreenBufferInfo(DosScreenBufferHandle,
- @ConsoleScreenBufferInfo);
- P.X:=ConsoleScreenBufferInfo.dwCursorPosition.X;
- P.Y:=ConsoleScreenBufferInfo.dwCursorPosition.Y;
- end;
- procedure TWindowsScreen.BufferCopy(Src, Dest : THandle);
- type
- CharInfoArray = Array [0..256*255-1] of Char_Info;
- var
- LineBuf : ^CharInfoArray;
- BufSize,BufCoord : Coord;
- Error, LineSize,
- Part, OnePartY: longint;
- res : boolean;
- WriteRegion : SMALL_RECT;
- ConsoleScreenBufferInfo : Console_screen_buffer_info;
- DestConsoleScreenBufferInfo : Console_screen_buffer_info;
- begin
- GetConsoleScreenBufferInfo(Src,
- @ConsoleScreenBufferInfo);
- GetConsoleScreenBufferInfo(Dest,
- @DestConsoleScreenBufferInfo);
- GetMem(LineBuf,SizeOf(CharInfoArray));
- FillChar(LineBuf^,SizeOf(CharInfoArray),#0);
- LineSize:=ConsoleScreenBufferInfo.dwSize.X;
- If LineSize>256 then
- LineSize:=256;
- BufSize.X:=LineSize;
- BufSize.Y:=ConsoleScreenBufferInfo.dwSize.Y;
- BufCoord.X:=0;
- BufCoord.Y:=0;
- with WriteRegion do
- begin
- Top :=0;
- Left :=0;
- Bottom := ConsoleScreenBufferInfo.dwSize.Y-1;
- Right := LineSize-1;
- end;
- if BufSize.X*BufSize.Y*Sizeof(CHAR_INFO) >= $8000 then
- begin
- OnePartY := ($8000 -1) div (BufSize.X * SizeOf(Char_Info) );
- BufSize.Y:=OnePartY;
- Part:=0;
- while ((Part+1)*OnePartY < ConsoleScreenBufferInfo.dwSize.Y) do
- begin
- WriteRegion.Top := Part*OnePartY;
- WriteRegion.Bottom := (Part+1)*OnePartY-1;
- res:=ReadConsoleOutput(Src, PChar_info(LineBuf),
- BufSize, BufCoord, @WriteRegion);
- if not res then
- Error:=GetLastError;
- res:=WriteConsoleOutput(Dest, PChar_info(LineBuf),
- BufSize, BufCoord, @WriteRegion);
- if not res then
- Error:=GetLastError;
- Inc(Part);
- end;
- BufSize.Y:=ConsoleScreenBufferInfo.dwSize.Y - Part*OnePartY;
- WriteRegion.Top := Part*OnePartY;
- WriteRegion.Bottom := ConsoleScreenBufferInfo.dwSize.Y-1;
- res:=ReadConsoleOutput(Src, PChar_info(LineBuf),
- BufSize, BufCoord, @WriteRegion);
- if not res then
- Error:=GetLastError;
- res:=WriteConsoleOutput(Dest, PChar_info(LineBuf),
- BufSize, BufCoord, @WriteRegion);
- if not res then
- Error:=GetLastError;
- end
- else
- begin
- res:=ReadConsoleOutput(Src, PChar_info(LineBuf),
- BufSize, BufCoord, @WriteRegion);
- if not res then
- Error:=GetLastError;
- res:=WriteConsoleOutput(Dest, PChar_info(LineBuf),
- BufSize, BufCoord, @WriteRegion);
- if not res then
- Error:=GetLastError;
- end;
- FreeMem(LineBuf,SizeOf(CharInfoArray));
- SetConsoleCursorPosition(Dest, ConsoleScreenBufferInfo.dwCursorPosition);
- end;
- procedure TWindowsScreen.Capture;
- begin
- {if StartScreenBufferHandle=IdeScreenBufferHandle then
- BufferCopy(IDEScreenBufferHandle,DosScreenBufferHandle)
- else
- BufferCopy(DosScreenBufferHandle,IDEScreenBufferHandle);}
- SaveConsoleScreen;
- end;
- procedure TWindowsScreen.Restore;
- begin
- SwitchToConsoleScreen;
- end;
- { dummy for Windows as the Buffer screen
- do hold all the info }
- procedure TWindowsScreen.SaveIDEScreen;
- var
- NowIdeMode : Dword;
- begin
- IdeScreenMode:=ScreenMode;
- GetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), @NowIdeMode);
- {$ifdef debug}
- Complain('IDE ConsoleMode is $'+hexstr(NowIdeMode,8));
- if NowIdeMode<>IdeMode then
- Complain('is not equal to IDEMode $'+hexstr(IdeMode,8));
- {$endif debug}
- IdeMode:=NowIdeMode;
- { set the dummy buffer as active already now PM }
- SetStdHandle(cardinal(Std_Output_Handle),DummyScreenBufferHandle);
- UpdateFileHandles;
- end;
- { dummy for Windows as the Buffer screen
- do hold all the info }
- procedure TWindowsScreen.SaveConsoleScreen;
- begin
- GetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), @ConsoleMode);
- {$ifdef debug}
- Complain('ConsoleMode now is $'+hexstr(ConsoleMode,8));
- {$endif debug}
- { set the dummy buffer as active already now PM }
- SetStdHandle(cardinal(Std_Output_Handle),DummyScreenBufferHandle);
- UpdateFileHandles;
- end;
- procedure TWindowsScreen.SwitchToConsoleScreen;
- begin
- SetConsoleActiveScreenBuffer(DosScreenBufferHandle);
- SetStdHandle(cardinal(Std_Output_Handle),DosScreenBufferHandle);
- SetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), ConsoleMode);
- UpdateFileHandles;
- IDEActive:=false;
- end;
- procedure TWindowsScreen.SwitchBackToIDEScreen;
- var
- ConsoleScreenBufferInfo : Console_screen_buffer_info;
- WindowPos : Small_rect;
- res : boolean;
- error : longint;
- begin
- SetStdHandle(cardinal(Std_Output_Handle),IDEScreenBufferHandle);
- UpdateFileHandles;
- GetConsoleScreenBufferInfo(IDEScreenBufferHandle,
- @ConsoleScreenBufferInfo);
- SetConsoleActiveScreenBuffer(IDEScreenBufferHandle);
- { Needed to force InitSystemMsg to use the right console handle }
- DoneEvents;
- InitEvents;
- IdeMode:=({IdeMode or }ENABLE_MOUSE_INPUT or
- ENABLE_WINDOW_INPUT or
- ENABLE_EXTENDED_FLAGS)
- and not (ENABLE_PROCESSED_INPUT or
- ENABLE_LINE_INPUT or
- ENABLE_ECHO_INPUT or
- ENABLE_INSERT_MODE or
- ENABLE_QUICK_EDIT_MODE);
- SetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)), IdeMode);
- WindowPos.left:=0;
- WindowPos.right:=ConsoleScreenBufferInfo.srWindow.right
- -ConsoleScreenBufferInfo.srWindow.left;
- WindowPos.top:=0;
- WindowPos.bottom:=ConsoleScreenBufferInfo.srWindow.bottom
- -ConsoleScreenBufferInfo.srWindow.top;
- with ConsoleScreenBufferInfo.dwMaximumWindowSize do
- begin
- if WindowPos.Right<X-1 then
- WindowPos.right:=X-1;
- if WindowPos.Bottom<Y-1 then
- WindowPos.Bottom:=Y-1;
- end;
- res:=SetConsoleWindowInfo(IDEScreenBufferHandle,true,WindowPos);
- if not res then
- error:=GetLastError;
- {$ifdef DEBUG}
- IdeScreenMode.row:=WindowPos.bottom+1;
- IdeScreenMode.col:=WindowPos.right+1;
- {$endif DEBUG}
- { needed to force the correct size for videobuf }
- if Assigned(Application) and (IdeScreenMode.row<>0)then
- Application^.SetScreenVideoMode(IdeScreenMode);
- IDEActive:=true;
- end;
- {$ifdef debug}
- procedure TWindowsScreen.Complain(St : string);
- begin
- if IDEActive then
- DebugMessage('',St,0,0)
- else
- Writeln(stderr,St);
- end;
- procedure TWindowsScreen.SetConsoleMode(FH : Handle;Mode: DWord);
- var
- Test: DWord;
- begin
- If not Windows.SetConsoleMode(FH,Mode) then
- begin
- Complain('SetConsoleMode call failed GetLastError='+IntToStr(GetLastError));
- end
- else
- begin
- if not GetConsoleMode(FH,Test) then
- begin
- Complain('GetConsoleMode call failed GetLastError='+IntToStr(GetLastError));
- end
- else if (Test<>Mode) then
- begin
- Complain('GetConsoleMode result '+IntToStr(Test)+' <> '+
- IntToStr(Mode));
- end;
- end;
- end;
- {$endif DEBUG}
- {$endif}
- {****************************************************************************
- TOS2Screen
- ****************************************************************************}
- {$ifdef OS2}
- function TOS2Screen.GetWidth: integer;
- begin
- GetWidth:=80;
- end;
- function TOS2Screen.GetHeight: integer;
- begin
- GetHeight:=25;
- end;
- procedure TOS2Screen.GetLine(Line: integer; var Text, Attr: string);
- begin
- Text:=' ';
- Attr:=' ';
- end;
- procedure TOS2Screen.GetCursorPos(var P: TPoint);
- begin
- P.X:=1;
- P.Y:=1;
- end;
- { remember the initial video screen }
- procedure TOS2Screen.Capture;
- begin
- end;
- { restore the initial video mode }
- procedure TOS2Screen.Restore;
- begin
- end;
- { move up or down if supported by OS }
- function TOS2Screen.Scroll(i : integer) : integer;
- begin
- end;
- { saves the current IDE screen }
- procedure TOS2Screen.SaveIDEScreen;
- begin
- end;
- { saves the current console screen }
- procedure TOS2Screen.SaveConsoleScreen;
- begin
- end;
- { restores the saved console screen }
- procedure TOS2Screen.SwitchToConsoleScreen;
- begin
- end;
- { restores the saved IDE screen }
- procedure TOS2Screen.SwitchBackToIDEScreen;
- begin
- end;
- constructor TOS2Screen.Init;
- begin
- end;
- destructor TOS2Screen.Done;
- begin
- end;
- {$ENDIF}
- {****************************************************************************
- TNWLScreen
- ****************************************************************************}
- {$ifdef netwlibc}
- function TNWLScreen.GetWidth: integer;
- begin
- GetWidth:=80;
- end;
- function TNWLScreen.GetHeight: integer;
- begin
- GetHeight:=25;
- end;
- procedure TNWLScreen.GetLine(Line: integer; var Text, Attr: string);
- begin
- Text:=' ';
- Attr:=' ';
- end;
- procedure TNWLScreen.GetCursorPos(var P: TPoint);
- begin
- P.X:=1;
- P.Y:=1;
- end;
- { remember the initial video screen }
- procedure TNWLScreen.Capture;
- begin
- end;
- { restore the initial video mode }
- procedure TNWLScreen.Restore;
- begin
- end;
- { saves the current IDE screen }
- procedure TNWLScreen.SaveIDEScreen;
- begin
- end;
- { saves the current console screen }
- procedure TNWLScreen.SaveConsoleScreen;
- begin
- end;
- { restores the saved console screen }
- procedure TNWLScreen.SwitchToConsoleScreen;
- begin
- end;
- { restores the saved IDE screen }
- procedure TNWLScreen.SwitchBackToIDEScreen;
- begin
- end;
- {$ENDIF}
- {****************************************************************************
- TAmigaScreen
- ****************************************************************************}
- {$IFDEF AMIGASCREEN}
- function TAmigaScreen.GetWidth: integer;
- begin
- GetWidth:=80;
- end;
- function TAmigaScreen.GetHeight: integer;
- begin
- GetHeight:=25;
- end;
- procedure TAmigaScreen.GetLine(Line: integer; var Text, Attr: string);
- begin
- Text:=' ';
- Attr:=' ';
- end;
- procedure TAmigaScreen.GetCursorPos(var P: TPoint);
- begin
- P.X:=1;
- P.Y:=1;
- end;
- { remember the initial video screen }
- procedure TAmigaScreen.Capture;
- begin
- end;
- { restore the initial video mode }
- procedure TAmigaScreen.Restore;
- begin
- end;
- { saves the current IDE screen }
- procedure TAmigaScreen.SaveIDEScreen;
- begin
- end;
- { saves the current console screen }
- procedure TAmigaScreen.SaveConsoleScreen;
- begin
- end;
- { restores the saved console screen }
- procedure TAmigaScreen.SwitchToConsoleScreen;
- begin
- end;
- { restores the saved IDE screen }
- procedure TAmigaScreen.SwitchBackToIDEScreen;
- begin
- end;
- {$ENDIF}
- {****************************************************************************
- Initialize
- ****************************************************************************}
- procedure InitUserScreen;
- begin
- {$ifdef DOS}
- UserScreen:=New(PDOSScreen, Init);
- {$else}
- {$ifdef Unix}
- UserScreen:=New(PLinuxScreen, Init);
- {$else}
- {$ifdef Windows}
- UserScreen:=New(PWindowsScreen, Init);
- {$else}
- {$ifdef OS2}
- UserScreen:=New(POS2Screen, Init);
- {$else}
- {$ifdef netwlibc}
- UserScreen:=New(PNWLScreen, Init);
- {$else}
- {$ifdef AMIGASCREEN}
- UserScreen:=New(PAmigaScreen, Init);
- {$else}
- UserScreen:=New(PScreen, Init);
- {$endif AMIGASCREEN}
- {$endif netwlibc}
- {$endif OS2}
- {$endif Windows}
- {$endif Unix}
- {$endif Dos}
- end;
- procedure DoneUserScreen;
- begin
- if UserScreen<>nil then
- begin
- UserScreen^.Restore;
- Dispose(UserScreen, Done);
- UserScreen:=nil;
- end;
- end;
- end.
|