* API 2 RTL commit

rtl/freebsd/Makefile

@@ -1,5 +1,5 @@
 #
-# Makefile generated by fpcmake v1.00 [2000/12/19]
+# Makefile generated by fpcmake v1.00 [2000/12/22]
 #
 
 defaultrule: all
@@ -50,6 +50,25 @@ else
 SRCEXEEXT=.exe
 endif
 
+# The extension of batch files / scripts
+ifdef inUnix
+BATCHEXT=.sh
+else
+ifdef inOS2
+BATCHEXT=.cmd
+else
+BATCHEXT=.bat
+endif
+endif
+
+# Path Separator, the subst trick is necessary for the \ that can't exists
+# at the end of a line
+ifdef inUnix
+PATHSEP=/
+else
+PATHSEP=$(subst /,\,/)
+endif
+
 # The path which is searched separated by spaces
 ifdef inUnix
 SEARCHPATH=$(subst :, ,$(PATH))
@@ -202,7 +221,7 @@ endif
 # Targets
 
 override LOADEROBJECTS+=prt0 cprt0
-override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings linux initc dos crt objects printer sysutils typinfo math cpu mmx getopts heaptrc lineinfo errors sockets gpm ipc
+override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings linux initc dos crt objects printer sysutils typinfo math cpu mmx getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard
 override RSTOBJECTS+=math
 
 # Clean
@@ -346,15 +365,7 @@ LD=ld
 endif
 
 # ppas.bat / ppas.sh
-ifdef inUnix
-PPAS=ppas.sh
-else
-ifdef inOS2
-PPAS=ppas.cmd
-else
-PPAS=ppas.bat
-endif
-endif
+PPAS=ppas$(BATCHEXT)
 
 # ldconfig to rebuild .so cache
 ifdef inUnix
@@ -1117,18 +1128,48 @@ USETAR=1
 endif
 endif
 
+# Use a wrapper script by default for OS/2
+ifdef inOS2
+USEZIPWRAPPER=1
+endif
+
+# Create commands to create the zip/tar file
+ZIPWRAPPER=$(DESTZIPDIR)/fpczip$(BATCHEXT)
+ZIPCMD_CDPACK:=cd $(subst /,$(PATHSEP),$(PACKDIR))
+ZIPCMD_CDBASE:=cd $(subst /,$(PATHSEP),$(BASEDIR))
+ifdef USETAR
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
+ZIPCMD_ZIP:=$(TARPROG) cf$(TAROPT) $(ZIPDESTFILE) *
+else
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
+ZIPCMD_ZIP:=$(subst /,$(PATHSEP),$(ZIPPROG)) -Dr $(ZIPOPT) $(ZIPDESTFILE) *
+endif
+
 fpc_zipinstall:
 ifndef ZIPNAME
 	@$(ECHO) "Please specify ZIPNAME!"
 	@exit 1
 else
 	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
-ifdef USETAR
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
-	cd $(PACKDIR) ; $(TARPROG) cf$(TAROPT) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR)
+	$(DEL) $(ZIPDESTFILE)
+ifdef USEZIPWRAPPER
+ifneq ($(ECHO),echo)
+	$(ECHO) "$(ZIPCMD_CDPACK)" > $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_ZIP)" >> $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_CDBASE)" >> $(ZIPWRAPPER)
+else
+	$(ECHO) $(ZIPCMD_CDPACK) > $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_ZIP) >> $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_CDBASE) >> $(ZIPWRAPPER)
+endif
+ifdef inUnix
+	/bin/sh $(ZIPWRAPPER)
 else
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
-	cd $(PACKDIR) ; $(ZIPPROG) -Dr $(ZIPOPT) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) * ; cd $(BASEDIR)
+	$(ZIPWRAPPER)
+endif
+	$(DEL) $(ZIPWRAPPER)
+else
+	$(ZIPCMD_CDPACK) ; $(ZIPCMD_ZIP) ; $(ZIPCMD_CDBASE)
 endif
 	$(DELTREE) $(PACKDIR)
 endif
@@ -1373,3 +1414,5 @@ sockets$(PPUEXT) : $(UNIXINC)/sockets.pp $(INC)/textrec.inc $(INC)/filerec.inc \
 errors$(PPUEXT) : $(UNIXINC)/errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 
 ipc$(PPUEXT) : $(UNIXINC)/ipc.pp linux$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
+
+terminfo$(PPUEXT) : terminfo.pp linux$(PPUEXT)

rtl/freebsd/Makefile.fpc

@@ -3,13 +3,15 @@
 #
 
 [targets]
-loaders=prt0 cprt0 
+loaders=prt0 cprt0
 units=$(SYSTEMUNIT) objpas strings \
       linux initc \
       dos crt objects printer \
       sysutils typinfo math \
       cpu mmx getopts heaptrc lineinfo \
-      errors sockets gpm ipc 
+      errors sockets gpm ipc terminfo \
+      video mouse keyboard
+
 rst=math
 
 [require]
@@ -180,3 +182,5 @@ sockets$(PPUEXT) : $(UNIXINC)/sockets.pp $(INC)/textrec.inc $(INC)/filerec.inc \
 errors$(PPUEXT) : $(UNIXINC)/errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 
 ipc$(PPUEXT) : $(UNIXINC)/ipc.pp linux$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
+
+terminfo$(PPUEXT) : terminfo.pp linux$(PPUEXT)

rtl/go32v2/Makefile

@@ -1,5 +1,5 @@
 #
-# Makefile generated by fpcmake v1.00 [2000/12/19]
+# Makefile generated by fpcmake v1.00 [2000/12/22]
 #
 
 defaultrule: all
@@ -50,6 +50,25 @@ else
 SRCEXEEXT=.exe
 endif
 
+# The extension of batch files / scripts
+ifdef inUnix
+BATCHEXT=.sh
+else
+ifdef inOS2
+BATCHEXT=.cmd
+else
+BATCHEXT=.bat
+endif
+endif
+
+# Path Separator, the subst trick is necessary for the \ that can't exists
+# at the end of a line
+ifdef inUnix
+PATHSEP=/
+else
+PATHSEP=$(subst /,\,/)
+endif
+
 # The path which is searched separated by spaces
 ifdef inUnix
 SEARCHPATH=$(subst :, ,$(PATH))
@@ -194,7 +213,7 @@ endif
 # Targets
 
 override LOADEROBJECTS+=prt0 exceptn fpu
-override UNITOBJECTS+=system objpas strings go32 dpmiexcp initc ports profile dxeload emu387 dos crt objects printer graph sysutils math typinfo cpu mmx getopts heaptrc lineinfo msmouse charset varutils
+override UNITOBJECTS+=system objpas strings go32 dpmiexcp initc ports profile dxeload emu387 dos crt objects printer graph sysutils math typinfo cpu mmx getopts heaptrc lineinfo msmouse charset varutils video mouse keyboard vesamode
 override RSTOBJECTS+=math varutils
 
 # Clean
@@ -335,15 +354,7 @@ LD=ld
 endif
 
 # ppas.bat / ppas.sh
-ifdef inUnix
-PPAS=ppas.sh
-else
-ifdef inOS2
-PPAS=ppas.cmd
-else
-PPAS=ppas.bat
-endif
-endif
+PPAS=ppas$(BATCHEXT)
 
 # ldconfig to rebuild .so cache
 ifdef inUnix
@@ -1106,18 +1117,48 @@ USETAR=1
 endif
 endif
 
+# Use a wrapper script by default for OS/2
+ifdef inOS2
+USEZIPWRAPPER=1
+endif
+
+# Create commands to create the zip/tar file
+ZIPWRAPPER=$(DESTZIPDIR)/fpczip$(BATCHEXT)
+ZIPCMD_CDPACK:=cd $(subst /,$(PATHSEP),$(PACKDIR))
+ZIPCMD_CDBASE:=cd $(subst /,$(PATHSEP),$(BASEDIR))
+ifdef USETAR
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
+ZIPCMD_ZIP:=$(TARPROG) cf$(TAROPT) $(ZIPDESTFILE) *
+else
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
+ZIPCMD_ZIP:=$(subst /,$(PATHSEP),$(ZIPPROG)) -Dr $(ZIPOPT) $(ZIPDESTFILE) *
+endif
+
 fpc_zipinstall:
 ifndef ZIPNAME
 	@$(ECHO) "Please specify ZIPNAME!"
 	@exit 1
 else
 	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
-ifdef USETAR
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
-	cd $(PACKDIR) ; $(TARPROG) cf$(TAROPT) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR)
+	$(DEL) $(ZIPDESTFILE)
+ifdef USEZIPWRAPPER
+ifneq ($(ECHO),echo)
+	$(ECHO) "$(ZIPCMD_CDPACK)" > $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_ZIP)" >> $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_CDBASE)" >> $(ZIPWRAPPER)
+else
+	$(ECHO) $(ZIPCMD_CDPACK) > $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_ZIP) >> $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_CDBASE) >> $(ZIPWRAPPER)
+endif
+ifdef inUnix
+	/bin/sh $(ZIPWRAPPER)
+else
+	$(ZIPWRAPPER)
+endif
+	$(DEL) $(ZIPWRAPPER)
 else
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
-	cd $(PACKDIR) ; $(ZIPPROG) -Dr $(ZIPOPT) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) * ; cd $(BASEDIR)
+	$(ZIPCMD_CDPACK) ; $(ZIPCMD_ZIP) ; $(ZIPCMD_CDBASE)
 endif
 	$(DELTREE) $(PACKDIR)
 endif

rtl/go32v2/Makefile.fpc

@@ -9,7 +9,9 @@ units=system objpas strings \
       dos crt objects printer graph \
       sysutils math typinfo \
       cpu mmx getopts heaptrc lineinfo \
-      msmouse charset varutils
+      msmouse charset varutils \
+      video mouse keyboard vesamode
+      
 rst=math varutils
 
 [require]

rtl/go32v2/keyboard.pp

@@ -0,0 +1,143 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Keyboard unit for go32v2
+
+    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.
+
+ **********************************************************************}
+unit Keyboard;
+interface
+
+{$i keybrdh.inc}
+
+implementation
+
+uses
+  go32;
+
+{$i keyboard.inc}
+
+procedure InitKeyboard;
+begin
+end;
+
+procedure DoneKeyboard;
+begin
+end;
+
+function GetKeyEvent: TKeyEvent;
+var
+  regs : trealregs;
+begin
+  if PendingKeyEvent<>0 then
+   begin
+     GetKeyEvent:=PendingKeyEvent;
+     PendingKeyEvent:=0;
+     exit;
+   end;
+  regs.ah:=$10;
+  realintr($16,regs);
+  if (regs.al=$e0) and (regs.ah<>0) then
+   regs.al:=0;
+  GetKeyEvent:=regs.ax or ((mem[$40:$17] and $f) shl 16);
+end;
+
+
+function PollKeyEvent: TKeyEvent;
+var
+  regs : trealregs;
+begin
+  if PendingKeyEvent<>0 then
+   exit(PendingKeyEvent);
+  regs.ah:=$11;
+  realintr($16,regs);
+  if (regs.realflags and zeroflag<>0) then
+   exit(0);
+  if (regs.al=$e0) and (regs.ah<>0) then
+   regs.al:=0;
+  PollKeyEvent:=regs.ax or ((mem[$40:$17] and $f) shl 16);
+end;
+
+
+function PollShiftStateEvent: TKeyEvent;
+begin
+  PollShiftStateEvent:=((mem[$40:$17] and $f) shl 16);
+end;
+
+
+{ Function key translation }
+type
+  TTranslationEntry = packed record
+    Min, Max: Byte;
+    Offset: Word;
+  end;
+const
+  TranslationTableEntries = 12;
+  TranslationTable: array [1..TranslationTableEntries] of TTranslationEntry =
+    ((Min: $3B; Max: $44; Offset: kbdF1),   { function keys F1-F10 }
+     (Min: $54; Max: $5D; Offset: kbdF1),   { Shift fn keys F1-F10 }
+     (Min: $5E; Max: $67; Offset: kbdF1),   { Ctrl fn keys F1-F10 }
+     (Min: $68; Max: $71; Offset: kbdF1),   { Alt fn keys F1-F10 }
+     (Min: $85; Max: $86; Offset: kbdF11),  { function keys F11-F12 }
+     (Min: $87; Max: $88; Offset: kbdF11),  { Shift+function keys F11-F12 }
+     (Min: $89; Max: $8A; Offset: kbdF11),  { Ctrl+function keys F11-F12 }
+     (Min: $8B; Max: $8C; Offset: kbdF11),  { Alt+function keys F11-F12 }
+     (Min:  71; Max:  73; Offset: kbdHome), { Keypad keys kbdHome-kbdPgUp }
+     (Min:  75; Max:  77; Offset: kbdLeft), { Keypad keys kbdLeft-kbdRight }
+     (Min:  79; Max:  81; Offset: kbdEnd),  { Keypad keys kbdEnd-kbdPgDn }
+     (Min: $52; Max: $53; Offset: kbdInsert));
+
+
+function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
+var
+  I: Integer;
+  ScanCode: Byte;
+begin
+  if KeyEvent and $03000000 = $03000000 then
+   begin
+     if KeyEvent and $000000FF <> 0 then
+      begin
+        TranslateKeyEvent := KeyEvent and $00FFFFFF;
+        exit;
+      end
+     else
+      begin
+        { This is a function key }
+        ScanCode := (KeyEvent and $0000FF00) shr 8;
+        for I := 1 to TranslationTableEntries do
+         begin
+           if (TranslationTable[I].Min <= ScanCode) and (ScanCode <= TranslationTable[I].Max) then
+            begin
+              TranslateKeyEvent := $02000000 + (KeyEvent and $00FF0000) +
+                (ScanCode - TranslationTable[I].Min) + TranslationTable[I].Offset;
+              exit;
+            end;
+         end;
+      end;
+   end;
+  TranslateKeyEvent := KeyEvent;
+end;
+
+
+function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+  TranslateKeyEventUniCode := KeyEvent;
+  ErrorCode:=errKbdNotImplemented;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:57  peter
+    * API 2 RTL commit
+
+}

rtl/go32v2/mouse.pp

@@ -0,0 +1,755 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Mouse unit for Go32v2
+
+    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.
+
+ **********************************************************************}
+unit Mouse;
+interface
+
+const
+  MouseEventBufSize = 16;
+
+{$i mouseh.inc}
+
+{ tells the mouse unit to draw the mouse cursor itself }
+procedure DoCustomMouse(b : boolean);
+
+
+implementation
+
+uses
+  video,go32;
+
+var
+  RealSeg : Word;                                    { Real mode segment }
+  RealOfs : Word;                                    { Real mode offset }
+  CurrentMask : word;
+  MouseCallback : Pointer;                           { Mouse call back ptr }
+  UnderNT: boolean;
+{$ifdef DEBUG}
+  EntryEDI,EntryESI : longint;
+  EntryDS,EntryES : word;
+{$endif DEBUG}
+  { Real mode registers in text segment below $ffff limit
+    for Windows NT
+    NOTE this might cause problem if someone want to
+    protect text section against writing (would be possible
+    with CWSDPMI under raw dos, not implemented yet !) }
+  ActionRegs    : TRealRegs;external name '___v2prt0_rmcb_regs';
+  v2prt0_ds_alias : word;external name '___v2prt0_ds_alias';
+const
+  MousePresent : boolean = false;
+{$ifdef DEBUG}
+  MouseError   : longint = 0;
+  CallCounter  : longint = 0;
+{$endif DEBUG}
+  drawmousecursor : boolean = false;
+  mouseisvisible : boolean = false;
+  { position where the mouse was drawn the last time }
+  oldmousex : longint = -1;
+  oldmousey : longint = -1;
+  mouselock : boolean = false;
+
+{ if the cursor is drawn by this the unit, we must be careful }
+{ when drawing while the interrupt handler is called          }
+procedure lockmouse;assembler;
+
+  asm
+  .Ltrylockagain:
+     movb    $1,%al
+     xchgb   mouselock,%al
+     orb     %al,%al
+     jne     .Ltrylockagain
+  end;
+
+procedure unlockmouse;
+
+  begin
+     mouselock:=false;
+  end;
+
+
+{$ASMMODE ATT}
+procedure MouseInt;assembler;
+asm
+        movb    %bl,mousebuttons
+        movw    %cx,mousewherex
+        movw    %dx,mousewherey
+        shrw    $3,%cx
+        shrw    $3,%dx
+        { should we draw the mouse cursor? }
+        cmpb    $0,drawmousecursor
+        je      .Lmouse_nocursor
+        cmpb    $0,mouseisvisible
+        je      .Lmouse_nocursor
+        pushw   %fs
+        pushl   %eax
+        pushl   %edi
+        { check lock }
+        movb    $1,%al
+        xchgb   mouselock,%al
+        orb     %al,%al
+        { don't update the cursor yet, because hide/showcursor is called }
+        jne    .Ldont_draw
+
+        { load start of video buffer }
+        movzwl  videoseg,%edi
+        shll    $4,%edi
+        movw    dosmemselector,%fs
+
+        { calculate address of old mouse cursor }
+        movl    oldmousey,%eax
+        imulw   screenwidth,%ax
+        addl    oldmousex,%eax
+        leal    1(%edi,%eax,2),%eax
+        { remove old cursor }
+        xorb    $0x7f,%fs:(%eax)
+
+        { store position of old cursor }
+        movzwl  %cx,%ecx
+        movl    %ecx,oldmousex
+        movzwl  %dx,%edx
+        movl    %edx,oldmousey
+
+        { calculate address of new cursor }
+        movl    %edx,%eax
+        imulw   screenwidth,%ax
+        addl    %ecx,%eax
+        leal    1(%edi,%eax,2),%eax
+        { draw new cursor }
+        xorb    $0x7f,%fs:(%eax)
+
+        { unlock mouse }
+        movb    $0,mouselock
+
+.Ldont_draw:
+        popl    %edi
+        popl    %eax
+        popw    %fs
+.Lmouse_nocursor:
+        cmpb    MouseEventBufSize,PendingMouseEvents
+        je      .Lmouse_exit
+        movl    PendingMouseTail,%edi
+        movw    %bx,(%edi)
+        movw    %cx,2(%edi)
+        movw    %dx,4(%edi)
+        movw    $0,6(%edi)
+        addl    $8,%edi
+        leal    PendingMouseEvent,%eax
+        addl    MouseEventBufSize*8,%eax
+        cmpl    %eax,%edi
+        jne     .Lmouse_nowrap
+        leal    PendingMouseEvent,%edi
+.Lmouse_nowrap:
+        movl    %edi,PendingMouseTail
+        incb    PendingMouseEvents
+.Lmouse_exit:
+end;
+
+
+
+PROCEDURE Mouse_Trap; ASSEMBLER;
+ASM
+   PUSH %ES;                                          { Save ES register }
+   PUSH %DS;                                          { Save DS register }
+   PUSHL %EDI;                                        { Save register }
+   PUSHL %ESI;                                        { Save register }
+   { ; caution : ds is not the selector for our data !! }
+{$ifdef DEBUG}
+   MOVL  %EDI,%ES:EntryEDI
+   MOVL  %ESI,%ES:EntryESI
+   MOVW  %DS,%AX
+   MOVW  %AX,%ES:EntryDS
+   MOVW  %ES,%AX
+   MOVW  %AX,%ES:EntryES
+{$endif DEBUG}
+ {  movw  %cs:v2prt0_ds_alias,%ax v2prt0 is not locked !!
+   movw  %ax,%ds
+   movw  %ax,%es }
+   PUSH %ES;                                          { Push data seg }
+   POP %DS;                                           { Load data seg }
+{$ifdef DEBUG}
+   incl callcounter
+   CMPL $ACTIONREGS,%edi
+   JE  .L_ActionRegsOK
+   INCL MouseError
+   JMP  .L_NoCallBack
+.L_ActionRegsOK:
+{$endif DEBUG}
+   MOVL MOUSECALLBACK, %EAX;                          { Fetch callback addr }
+   CMPL $0, %EAX;                                     { Check for nil ptr }
+   JZ .L_NoCallBack;                                  { Ignore if nil }
+   MOVL %EDI,%EAX;                                    { %EAX = @actionregs }
+   MOVL (%EAX), %EDI;                                 { EDI from actionregs }
+   MOVL 4(%EAX), %ESI;                                { ESI from actionregs }
+   MOVL 16(%EAX), %EBX;                               { EBX from actionregs }
+   MOVL 20(%EAX), %EDX;                               { EDX from actionregs }
+   MOVL 24(%EAX), %ECX;                               { ECX from actionregs }
+   MOVL 28(%EAX), %EAX;                               { EAX from actionregs }
+   CALL *MOUSECALLBACK;                               { Call callback proc }
+.L_NoCallBack:
+   POPL %ESI;                                         { Recover register }
+   POPL %EDI;                                         { Recover register }
+   POP %DS;                                           { Restore DS register }
+   POP %ES;                                           { Restore ES register }
+   {  This works for WinNT
+   movzwl %si,%eax
+   but CWSDPMI need this }
+   movl %esi,%eax
+   MOVL %ds:(%Eax), %EAX;
+   MOVL %EAX, %ES:42(%EDI);                           { Set as return addr }
+   ADDW $4, %ES:46(%EDI);                             { adjust stack }
+   IRET;                                              { Interrupt return }
+END;
+
+PROCEDURE Mouse_Trap_NT; ASSEMBLER;
+ASM
+   PUSH %ES;                                          { Save ES register }
+   PUSH %DS;                                          { Save DS register }
+   PUSHL %EDI;                                        { Save register }
+   PUSHL %ESI;                                        { Save register }
+   { ; caution : ds is not the selector for our data !! }
+{$ifdef DEBUG}
+   MOVL  %EDI,%ES:EntryEDI
+   MOVL  %ESI,%ES:EntryESI
+   MOVW  %DS,%AX
+   MOVW  %AX,%ES:EntryDS
+   MOVW  %ES,%AX
+   MOVW  %AX,%ES:EntryES
+{$endif DEBUG}
+ {  movw  %cs:v2prt0_ds_alias,%ax v2prt0 is not locked !!
+   movw  %ax,%ds
+   movw  %ax,%es }
+   PUSH %ES;                                          { Push data seg }
+   POP %DS;                                           { Load data seg }
+{$ifdef DEBUG}
+   incl callcounter
+   CMPL $ACTIONREGS,%edi
+   JE  .L_ActionRegsOK
+   INCL MouseError
+   JMP  .L_NoCallBack
+.L_ActionRegsOK:
+{$endif DEBUG}
+   MOVL MOUSECALLBACK, %EAX;                          { Fetch callback addr }
+   CMPL $0, %EAX;                                     { Check for nil ptr }
+   JZ .L_NoCallBack;                                  { Ignore if nil }
+   MOVL %EDI,%EAX;                                    { %EAX = @actionregs }
+   MOVL (%EAX), %EDI;                                 { EDI from actionregs }
+   MOVL 4(%EAX), %ESI;                                { ESI from actionregs }
+   MOVL 16(%EAX), %EBX;                               { EBX from actionregs }
+   MOVL 20(%EAX), %EDX;                               { EDX from actionregs }
+   MOVL 24(%EAX), %ECX;                               { ECX from actionregs }
+   MOVL 28(%EAX), %EAX;                               { EAX from actionregs }
+   CALL *MOUSECALLBACK;                               { Call callback proc }
+.L_NoCallBack:
+   POPL %ESI;                                         { Recover register }
+   POPL %EDI;                                         { Recover register }
+   POP %DS;                                           { Restore DS register }
+   POP %ES;                                           { Restore ES register }
+   movzwl %si,%eax
+   MOVL %ds:(%Eax), %EAX;
+   MOVL %EAX, %ES:42(%EDI);                           { Set as return addr }
+   ADDW $4, %ES:46(%EDI);                             { adjust stack }
+   IRET;                                              { Interrupt return }
+END;
+
+Function Allocate_mouse_bridge : boolean;
+var
+  error : word;
+begin
+  ASM
+    LEAL ACTIONREGS, %EDI;                       { Addr of actionregs }
+    LEAL MOUSE_TRAP, %ESI;                       { Procedure address }
+    CMPB $0, UnderNT
+    JZ  .LGo32
+    LEAL MOUSE_TRAP_NT, %ESI;                       { Procedure address }
+  .LGo32:
+    PUSH %DS;                                    { Save DS segment }
+    PUSH %ES;                                    { Save ES segment }
+    MOVW v2prt0_ds_alias,%ES;                    { ES now has dataseg  alias that is never invalid }
+    PUSH %CS;
+    POP  %DS;                                    { DS now has codeseg }
+    MOVW $0x303, %AX;                            { Function id }
+    INT  $0x31;                                  { Call DPMI bridge }
+    JNC .L_call_ok;                              { Branch if ok }
+    POP  %ES;                                    { Restore ES segment }
+    POP  %DS;                                    { Restore DS segment }
+    MOVW $0,REALSEG;
+    MOVW $0,REALOFS;
+    JMP  .L_exit
+  .L_call_ok:
+    POP  %ES;                                    { Restore ES segment }
+    POP  %DS;                                    { Restore DS segment }
+    MOVW %CX,REALSEG;                            { Transfer real seg }
+    MOVW %DX,REALOFS;                            { Transfer real ofs }
+    MOVW $0, %AX;                                { Force error to zero }
+  .L_exit:
+    MOVW %AX, ERROR;                             { Return error state }
+  END;
+  Allocate_mouse_bridge:=error=0;
+end;
+
+Procedure Release_mouse_bridge;
+begin
+  ASM
+     MOVW $0x304, %AX;                            { Set function id }
+     MOVW REALSEG, %CX;                           { Bridged real seg }
+     MOVW REALOFS, %DX;                           { Bridged real ofs }
+     INT $0x31;                                   { Release bridge }
+     MOVW $0,REALSEG;
+     MOVW $0,REALOFS;
+  END;
+end;
+
+PROCEDURE Mouse_Action (Mask : Word; P : Pointer);
+VAR
+  Error : Word;
+  Rg    : TRealRegs;
+BEGIN
+  Error := 0;                                         { Preset no error }
+  If (P <> MouseCallBack) or (Mask<>CurrentMask) Then                        { Check func different }
+   Begin
+   { Remove old calback }
+     If (CurrentMask <> 0) Then
+      Begin
+        Rg.AX := 12;                                   { Function id }
+        Rg.CX := 0;                                    { Zero mask register }
+        Rg.ES := 0;                                    { Zero proc seg }
+        Rg.DX := 0;                                    { Zero proc ofs }
+        RealIntr($33, Rg);                             { Stop INT 33 callback }
+      End;
+     if RealSeg=0 then
+       error:=1;
+    { test addresses for Windows NT }
+    if (longint(@actionregs)>$ffff) {or
+       (longint(@mouse_trap)>$ffff)} then
+      begin
+         error:=1;
+      end
+    else If (P = Nil) Then
+     Begin
+       Mask := 0;                                    { Zero mask register }
+     End;
+    If (Error = 0) Then
+     Begin
+       MouseCallback := P;                            { Set call back addr }
+       if Mask<>0 then
+         begin
+           Rg.AX := 12;                                   { Set function id }
+           Rg.CX := Mask;                                 { Set mask register }
+           If Mask<>0 then
+             begin
+               Rg.ES := RealSeg;                              { Real mode segment }
+               Rg.DX := RealOfs;                              { Real mode offset }
+             end
+           else
+             begin
+               Rg.ES:=0;
+               Rg.DX:=0;
+             end;
+           RealIntr($33, Rg);                             { Set interrupt 33 }
+         end;
+       CurrentMask:=Mask;
+     End;
+   End;
+  If (Error <> 0) Then
+   Begin
+     Writeln('GO32V2 mouse handler set failed !!');
+     ReadLn;                                          { Wait for user to see }
+   End;
+END;
+
+
+{ We need to remove the mouse callback before exiting !! PM }
+
+const StoredExit : Pointer = Nil;
+      FirstMouseInitDone : boolean = false;
+
+procedure MouseSafeExit;
+begin
+  ExitProc:=StoredExit;
+  if MouseCallBack<>Nil then
+    Mouse_Action(0, Nil);
+  if not FirstMouseInitDone then
+    exit;
+  FirstMouseInitDone:=false;
+  Unlock_Code(Pointer(@Mouse_Trap), 400);            { Release trap code }
+  Unlock_Code(Pointer(@Mouse_Trap_NT), 400);            { Release trap code }
+  Unlock_Code(Pointer(@MouseInt), 400);               { Lock MouseInt code  }
+  Unlock_Data(ActionRegs, SizeOf(TRealRegs));        { Release registers }
+  UnLock_Data(MouseCallBack,SizeOf(Pointer));
+  { unlock Mouse Queue and related stuff ! }
+  Unlock_Data(PendingMouseEvent,
+        MouseEventBufSize*Sizeof(TMouseEvent));
+  Unlock_Data(PendingMouseTail,SizeOf(longint));
+  Unlock_Data(PendingMouseEvents,sizeof(byte));
+  Unlock_Data(MouseButtons,SizeOf(byte));
+  Unlock_Data(MouseWhereX,SizeOf(word));
+  Unlock_Data(MouseWhereY,SizeOf(word));
+  Unlock_Data(drawmousecursor,SizeOf(boolean));
+  Unlock_Data(mouseisvisible,SizeOf(boolean));
+  Unlock_Data(mouselock,SizeOf(boolean));
+  Unlock_Data(videoseg,SizeOf(word));
+  Unlock_Data(dosmemselector,SizeOf(word));
+  Unlock_Data(screenwidth,SizeOf(word));
+  Unlock_Data(OldMouseX,SizeOf(longint));
+  Unlock_Data(OldMouseY,SizeOf(longint));
+{$ifdef DEBUG}
+  Unlock_Data(EntryEDI, SizeOf(longint));
+  Unlock_Data(EntryESI, SizeOf(longint));
+  Unlock_Data(EntryDS, SizeOf(word));
+  Unlock_Data(EntryES, SizeOf(word));
+  Unlock_Data(MouseError, SizeOf(longint));
+  Unlock_Data(callcounter, SizeOf(longint));
+{$endif DEBUG}
+  Release_mouse_bridge;
+end;
+
+function RunningUnderWINNT: boolean;
+var r: trealregs;
+begin
+  fillchar(r,sizeof(r),0);
+  r.ax:=$3306;
+  realintr($21,r);
+  RunningUnderWINNT:=(r.bx=$3205);
+end;
+
+procedure InitMouse;
+begin
+  UnderNT:=RunningUnderWINNT;
+  if not MousePresent then
+    begin
+      if DetectMouse=0 then
+        begin
+          Writeln('No mouse driver found ');
+          exit;
+        end
+      else
+        MousePresent:=true;
+    end;
+  PendingMouseHead:=@PendingMouseEvent;
+  PendingMouseTail:=@PendingMouseEvent;
+  PendingMouseEvents:=0;
+  FillChar(LastMouseEvent,sizeof(TMouseEvent),0);
+
+  { don't do this twice !! PM }
+
+  If not FirstMouseInitDone then
+    begin
+      StoredExit:=ExitProc;
+      ExitProc:=@MouseSafeExit;
+      Lock_Code(Pointer(@Mouse_Trap), 400);              { Lock trap code }
+      Lock_Code(Pointer(@Mouse_Trap_NT), 400);              { Lock trap code }
+      Lock_Code(Pointer(@MouseInt), 400);               { Lock MouseInt code  }
+      Lock_Data(ActionRegs, SizeOf(TRealRegs));          { Lock registers }
+      Lock_Data(MouseCallBack, SizeOf(pointer));
+      { lock Mouse Queue and related stuff ! }
+      Lock_Data(PendingMouseEvent,
+        MouseEventBufSize*Sizeof(TMouseEvent));
+      Lock_Data(PendingMouseTail,SizeOf(longint));
+      Lock_Data(PendingMouseEvents,sizeof(byte));
+      Lock_Data(MouseButtons,SizeOf(byte));
+      Lock_Data(MouseWhereX,SizeOf(word));
+      Lock_Data(MouseWhereY,SizeOf(word));
+      Lock_Data(drawmousecursor,SizeOf(boolean));
+      Lock_Data(mouseisvisible,SizeOf(boolean));
+      Lock_Data(mouselock,SizeOf(boolean));
+      Lock_Data(videoseg,SizeOf(word));
+      Lock_Data(dosmemselector,SizeOf(word));
+      Lock_Data(screenwidth,SizeOf(word));
+      Lock_Data(OldMouseX,SizeOf(longint));
+      Lock_Data(OldMouseY,SizeOf(longint));
+{$ifdef DEBUG}
+      Lock_Data(EntryEDI, SizeOf(longint));
+      Lock_Data(EntryESI, SizeOf(longint));
+      Lock_Data(EntryDS, SizeOf(word));
+      Lock_Data(EntryES, SizeOf(word));
+      Lock_Data(MouseError, SizeOf(longint));
+      Lock_Data(callcounter, SizeOf(longint));
+{$endif DEBUG}
+      Allocate_mouse_bridge;
+      FirstMouseInitDone:=true;
+    end;
+  If MouseCallBack=Nil then
+    Mouse_Action($ffff, @MouseInt);                    { Set masks/interrupt }
+  drawmousecursor:=false;
+  mouseisvisible:=false;
+  if (screenwidth>80) or (screenheight>50) then
+    DoCustomMouse(true);
+  ShowMouse;
+end;
+
+
+procedure DoneMouse;
+begin
+  HideMouse;
+  If (MouseCallBack <> Nil) Then
+    Mouse_Action(0, Nil);                            { Clear mask/interrupt }
+end;
+
+
+function DetectMouse:byte;assembler;
+asm
+        movl    $0x200,%eax
+        movl    $0x33,%ebx
+        int     $0x31
+        movw    %cx,%ax
+        orw     %ax,%dx
+        jz      .Lno_mouse
+        xorl    %eax,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        orw     %ax,%ax
+        jz      .Lno_mouse
+        movl    %ebx,%eax
+.Lno_mouse:
+end;
+
+
+procedure ShowMouse;
+
+begin
+   if drawmousecursor then
+     begin
+        lockmouse;
+        if not(mouseisvisible) then
+          begin
+             oldmousex:=getmousex-1;
+             oldmousey:=getmousey-1;
+             mem[videoseg:(((screenwidth*oldmousey)+oldmousex)*2)+1]:=
+               mem[videoseg:(((screenwidth*oldmousey)+oldmousex)*2)+1] xor $7f;
+             mouseisvisible:=true;
+          end;
+        unlockmouse;
+     end
+   else
+     asm
+             cmpb    $1,MousePresent
+             jne     .LShowMouseExit
+             movl    $1,%eax
+             pushl   %ebp
+             int     $0x33
+             popl    %ebp
+     .LShowMouseExit:
+     end;
+end;
+
+
+procedure HideMouse;
+
+begin
+   if drawmousecursor then
+     begin
+        lockmouse;
+        if mouseisvisible then
+          begin
+             mouseisvisible:=false;
+             mem[videoseg:(((screenwidth*oldmousey)+oldmousex)*2)+1]:=
+               mem[videoseg:(((screenwidth*oldmousey)+oldmousex)*2)+1] xor $7f;
+             oldmousex:=-1;
+             oldmousey:=-1;
+          end;
+        unlockmouse;
+     end
+   else
+     asm
+             cmpb    $1,MousePresent
+             jne     .LHideMouseExit
+             movl    $2,%eax
+             pushl   %ebp
+             int     $0x33
+             popl    %ebp
+     .LHideMouseExit:
+     end;
+end;
+
+
+function GetMouseX:word;assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LGetMouseXError
+        movl    $3,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        movzwl  %cx,%eax
+        shrl    $3,%eax
+        incl    %eax
+        ret
+.LGetMouseXError:
+        xorl    %eax,%eax
+end;
+
+
+function GetMouseY:word;assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LGetMouseYError
+        movl    $3,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        movzwl  %dx,%eax
+        shrl    $3,%eax
+        incl    %eax
+        ret
+.LGetMouseYError:
+        xorl    %eax,%eax
+end;
+
+
+function GetMouseButtons:word;assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LGetMouseButtonsError
+        movl    $3,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        movw    %bx,%ax
+        ret
+.LGetMouseButtonsError:
+        xorl    %eax,%eax
+end;
+
+
+procedure SetMouseXY(x,y:word);assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LSetMouseXYExit
+        movw    x,%cx
+        movw    y,%dx
+        movl    $4,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+.LSetMouseXYExit:
+end;
+
+Procedure SetMouseXRange (Min,Max:Longint);
+begin
+  If Not(MousePresent) Then Exit;
+  asm
+        movl    $7,%eax
+        movl    min,%ecx
+        movl    max,%edx
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  end;
+end;
+
+Procedure SetMouseYRange (min,max:Longint);
+begin
+  If Not(MousePresent) Then Exit;
+  asm
+        movl    $8,%eax
+        movl    min,%ecx
+        movl    max,%edx
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  end;
+end;
+
+procedure DoCustomMouse(b : boolean);
+
+  begin
+     HideMouse;
+     lockmouse;
+     oldmousex:=-1;
+     oldmousey:=-1;
+     SetMouseXRange(0,(screenwidth-1)*8);
+     SetMouseYRange(0,(screenheight-1)*8);
+     if b then
+       begin
+          mouseisvisible:=false;
+          drawmousecursor:=true;
+       end
+     else
+       drawmousecursor:=false;
+     unlockmouse;
+  end;
+
+const
+  LastCallcounter : longint = 0;
+
+procedure GetMouseEvent(var MouseEvent: TMouseEvent);
+begin
+  if not MousePresent then
+    begin
+      Fillchar(MouseEvent,SizeOf(TMouseEvent),#0);
+    end;
+{$ifdef DEBUG}
+  if mouseError>0 then
+    Writeln('Errors in mouse Handler ',MouseError);
+{$ifdef EXTMOUSEDEBUG}
+  if callcounter>LastCallcounter then
+    Writeln('Number of calls in mouse Handler ',Callcounter);
+{$endif EXTMOUSEDEBUG}
+  LastCallcounter:=Callcounter;
+{$endif DEBUG}
+  repeat until PendingMouseEvents>0;
+  MouseEvent:=PendingMouseHead^;
+  inc(PendingMouseHead);
+  if longint(PendingMouseHead)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+   PendingMouseHead:=@PendingMouseEvent;
+  dec(PendingMouseEvents);
+  if (LastMouseEvent.x<>MouseEvent.x) or (LastMouseEvent.y<>MouseEvent.y) then
+   MouseEvent.Action:=MouseActionMove;
+  if (LastMouseEvent.Buttons<>MouseEvent.Buttons) then
+   begin
+     if (LastMouseEvent.Buttons=0) then
+      MouseEvent.Action:=MouseActionDown
+     else
+      MouseEvent.Action:=MouseActionUp;
+   end;
+  LastMouseEvent:=MouseEvent;
+end;
+
+
+function PollMouseEvent(var MouseEvent: TMouseEvent):boolean;
+begin
+  if PendingMouseEvents>0 then
+   begin
+     MouseEvent:=PendingMouseHead^;
+     PollMouseEvent:=true;
+   end
+  else
+   PollMouseEvent:=false;
+end;
+
+procedure PutMouseEvent(const MouseEvent: TMouseEvent);
+begin
+  if PendingMouseEvents<MouseEventBufSize then
+   begin
+     PendingMouseTail^:=MouseEvent;
+     inc(PendingMouseTail);
+     if longint(PendingMouseTail)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+      PendingMouseTail:=@PendingMouseEvent;
+      { why isn't this done here ?
+        so the win32 version do this by hand:}
+       inc(PendingMouseEvents);
+   end
+  else
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:58  peter
+    * API 2 RTL commit
+
+}

rtl/go32v2/vesamode.pp

@@ -0,0 +1,127 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Video unit extension for VESA Modes for go32v2
+
+    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.
+
+ **********************************************************************}
+unit vesamode;
+
+  interface
+
+  implementation
+
+    uses
+       dos,go32,dpmiexcp,video,mouse;
+
+    type
+       twordarray = array[0..0] of word;
+
+       pwordarray = ^twordarray;
+       TVESAInfoBlock = record
+         VESASignature   : ARRAY[0..3] OF CHAR;
+         VESAVersion     : WORD;
+         OEMStringPtr    : PChar;
+         Capabilities    : LONGINT;
+         VideoModePtr    : pwordarray;
+         TotalMemory     : WORD;
+         Reserved        : ARRAY[1..242] OF BYTE;
+       end;
+
+    function ReturnSuperVGAInfo(var ib : TVESAInfoBLock) : Word;
+
+      var
+         regs : registers;
+
+      begin
+         regs.ah:=$4f;
+         regs.al:=0;
+         regs.es:=tb_segment;
+         regs.di:=tb_offset;
+         intr($10,regs);
+         dosmemget(tb_segment,tb_offset,ib,sizeof(ib));
+         ReturnSuperVGAInfo:=regs.ax;
+      end;
+
+    function SetSuperVGAMode(m : word) : word;
+
+      var
+         regs : registers;
+
+      begin
+         regs.ah:=$4f;
+         regs.al:=2;
+         regs.bx:=m;
+         intr($10,regs);
+         SetSuperVGAMode:=regs.ax;
+      end;
+
+    function SetVESAMode(const VideoMode: TVideoMode; Params: Longint): Boolean;
+
+      var
+         w : word;
+
+      begin
+         w:=SetSuperVGAMode(Params);
+         if w<>$4f then
+           SetVESAMode:=false
+         else
+           begin
+              SetVESAMode:=true;
+              ScreenWidth:=VideoMode.Col;
+              ScreenHeight:=VideoMode.Row;
+              ScreenColor:=true;
+              // cheat to get a correct mouse
+              {
+              mem[$40:$84]:=ScreenHeight-1;
+              mem[$40:$4a]:=ScreenWidth;
+              memw[$40:$4c]:=ScreenHeight*((ScreenWidth shl 1)-1);
+              }
+              DoCustomMouse(true);
+           end;
+      end;
+
+var
+   infoblock : TVESAInfoBLock;
+   i : longint;
+   m : word;
+
+begin
+   ReturnSuperVGAInfo(infoblock);
+   if not((infoblock.VESASignature[0]<>'V') or
+      (infoblock.VESASignature[1]<>'E') or
+      (infoblock.VESASignature[2]<>'S') or
+      (infoblock.VESASignature[3]<>'A')) then
+     begin
+{$R-}
+   i:=0;
+   while true do
+     begin
+        dosmemget(hi(dword(infoblock.VideoModePtr)),lo(dword(infoblock.VideoModePtr))+i*2,m,2);
+        case m of
+           264:
+             RegisterVideoMode(80,60,true,@SetVESAMode,264);
+           265:
+             RegisterVideoMode(132,25,true,@SetVESAMode,265);
+           266:
+             RegisterVideoMode(132,43,true,@SetVESAMode,266);
+           267:
+             RegisterVideoMode(132,50,true,@SetVESAMode,267);
+           268:
+             RegisterVideoMode(132,60,true,@SetVESAMode,268);
+           $ffff:
+             break;
+        end;
+        inc(i);
+     end;
+   end;
+end.

rtl/go32v2/video.pp

@@ -0,0 +1,328 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Video unit for linux
+
+    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.
+
+ **********************************************************************}
+unit Video;
+
+interface
+
+{$i videoh.inc}
+
+var
+  VideoSeg : word;
+
+
+implementation
+
+uses
+  mouse,
+  go32;
+
+{$i video.inc}
+
+{$ASMMODE ATT}
+
+var
+  OldVideoBuf : PVideoBuf;
+
+  { used to know if LastCursorType is valid }
+const
+  InitVideoCalled : boolean = false;
+  LastCursorType : word = crUnderline;
+
+{ allways set blink state again }
+
+procedure SetHighBitBlink;
+var
+  regs : trealregs;
+begin
+  regs.ax:=$1003;
+  regs.bx:=$0001;
+  realintr($10,regs);
+end;
+
+function BIOSGetScreenMode(var Cols,Rows: word; var Color: boolean): boolean;
+var r: trealregs;
+    L: longint;
+    LSel,LSeg: word;
+    B: array[0..63] of byte;
+type TWord = word; PWord = ^TWord;
+var Size: word;
+    OK: boolean;
+begin
+  L:=global_dos_alloc(64);
+  LSeg:=(L shr 16);
+  LSel:=(L and $ffff);
+
+  r.ah:=$1b; r.bx:=0;
+  r.es:=LSeg; r.di:=0;
+  realintr($10,r);
+  OK:=(r.al=$1b);
+  if OK then
+  begin
+    dpmi_dosmemget(LSeg,0,B,64);
+    Cols:=PWord(@B[5])^; Rows:=B[$22];
+    Color:=PWord(@B[$27])^<>0;
+  end;
+  global_dos_free(LSel);
+  BIOSGetScreenMode:=OK;
+end;
+
+procedure InitVideo;
+var
+  regs : trealregs;
+begin
+  VideoSeg:=$b800;
+  if (ScreenWidth=$ffff) or (ScreenHeight=$ffff) or
+    (ScreenWidth=0) or (ScreenHeight=0) then
+    begin
+       ScreenColor:=true;
+       regs.ah:=$0f;
+       realintr($10,regs);
+       if (regs.al and 1)=0 then
+         ScreenColor:=false;
+       if regs.al=7 then
+         begin
+            ScreenColor:=false;
+            VideoSeg:=$b000;
+         end
+       else
+         VideoSeg:=$b800;
+       ScreenWidth:=regs.ah;
+       regs.ax:=$1130;
+       regs.bx:=0;
+       realintr($10,regs);
+       ScreenHeight:=regs.dl+1;
+       BIOSGetScreenMode(ScreenWidth,ScreenHeight,ScreenColor);
+    end;
+  regs.ah:=$03;
+  regs.bh:=0;
+  realintr($10,regs);
+  CursorLines:=regs.cl;
+  CursorX:=regs.dl;
+  CursorY:=regs.dh;
+  If InitVideoCalled then
+    Begin
+      FreeMem(VideoBuf,VideoBufSize);
+      FreeMem(OldVideoBuf,VideoBufSize);
+    End;
+{ allocate pmode memory buffer }
+  VideoBufSize:=ScreenWidth*ScreenHeight*2;
+  GetMem(VideoBuf,VideoBufSize);
+  GetMem(OldVideoBuf,VideoBufSize);
+  InitVideoCalled:=true;
+  SetHighBitBlink;
+  SetCursorType(LastCursorType);
+  { ClearScreen; removed here
+    to be able to catch the content of the monitor }
+end;
+
+
+procedure DoneVideo;
+begin
+  If InitVideoCalled then
+    Begin
+      LastCursorType:=GetCursorType;
+      ClearScreen;
+      SetCursorType(crUnderLine);
+      SetCursorPos(0,0);
+      FreeMem(VideoBuf,VideoBufSize);
+      VideoBuf:=nil;
+      FreeMem(OldVideoBuf,VideoBufSize);
+      OldVideoBuf:=nil;
+      InitVideoCalled:=false;
+      VideoBufSize:=0;
+    End;
+end;
+
+
+function GetCapabilities: Word;
+begin
+  GetCapabilities := $3F;
+end;
+
+
+procedure SetCursorPos(NewCursorX, NewCursorY: Word);
+var
+  regs : trealregs;
+begin
+  regs.ah:=$02;
+  regs.bh:=0;
+  regs.dh:=NewCursorY;
+  regs.dl:=NewCursorX;
+  realintr($10,regs);
+  CursorY:=regs.dh;
+  CursorX:=regs.dl;
+end;
+
+{ I don't know the maximum value for the scan line
+  probably 7 or 15 depending on resolution !!
+  }
+function GetCursorType: Word;
+var
+  regs : trealregs;
+begin
+  regs.ah:=$03;
+  regs.bh:=0;
+  realintr($10,regs);
+  GetCursorType:=crHidden;
+  if (regs.ch and $60)=0 then
+   begin
+     GetCursorType:=crBlock;
+     if (regs.ch and $1f)<>0 then
+      begin
+        GetCursorType:=crHalfBlock;
+        if regs.cl+1=(regs.ch and $1F) then
+         GetCursorType:=crUnderline;
+      end;
+   end;
+end;
+
+
+procedure SetCursorType(NewType: Word);
+var
+  regs : trealregs;
+const
+  MaxCursorLines = 7;
+begin
+  regs.ah:=$01;
+  regs.bx:=NewType;
+  case NewType of
+   crHidden    : regs.cx:=$2000;
+   crHalfBlock : begin
+                   regs.ch:=MaxCursorLines shr 1;
+                   regs.cl:=MaxCursorLines;
+                 end;
+   crBlock     : begin
+                   regs.ch:=0;
+                   regs.cl:=MaxCursorLines;
+                 end;
+   else          begin
+                   regs.ch:=MaxCursorLines-1;
+                   regs.cl:=MaxCursorLines;
+                 end;
+  end;
+  realintr($10,regs);
+end;
+
+
+function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean;
+type
+  wordrec=packed record
+    lo,hi : word;
+  end;
+var
+  regs : trealregs;
+begin
+  regs.ax:=wordrec(Params).lo;
+  regs.bx:=wordrec(Params).hi;
+  realintr($10,regs);
+  defaultvideomodeselector:=true;
+  DoCustomMouse(false);
+end;
+
+function VideoModeSelector8x8(const VideoMode: TVideoMode; Params: Longint): Boolean;
+type
+  wordrec=packed record
+    lo,hi : word;
+  end;
+var
+  regs : trealregs;
+begin
+  regs.ax:=3;
+  regs.bx:=0;
+  realintr($10,regs);
+  regs.ax:=$1112;
+  regs.bx:=$0;
+  realintr($10,regs);
+  videomodeselector8x8:=true;
+  ScreenColor:=true;
+  ScreenWidth:=80;
+  ScreenHeight:=50;
+  DoCustomMouse(false);
+end;
+
+procedure ClearScreen;
+begin
+  FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
+  UpdateScreen(true);
+end;
+
+
+procedure UpdateScreen(Force: Boolean);
+begin
+  if LockUpdateScreen<>0 then
+   exit;
+  if not force then
+   begin
+     asm
+        movl    VideoBuf,%esi
+        movl    OldVideoBuf,%edi
+        movl    VideoBufSize,%ecx
+        shrl    $2,%ecx
+        repe
+        cmpsl
+        setne   force
+     end;
+   end;
+  if Force then
+   begin
+{     dosmemput(videoseg,0,videobuf^,VideoBufSize);}
+      asm
+        pushw %es
+        pushl %edi
+        pushl %esi
+
+        xor  %edi, %edi
+        movw videoseg, %di
+        shll $0x4, %edi
+        movl videobuf, %esi
+        movl videobufsize, %ecx
+        movw %fs, %ax
+        movw %ax, %es
+        rep movsb
+
+        popl  %esi
+        popl  %edi
+        popw  %es
+      end ['EAX','ECX'];
+     move(videobuf^,oldvideobuf^,VideoBufSize);
+   end;
+end;
+
+
+procedure RegisterVideoModes;
+begin
+  RegisterVideoMode(40, 25, False,@DefaultVideoModeSelector, $00000000);
+  RegisterVideoMode(40, 25, True, @DefaultVideoModeSelector, $00000001);
+  RegisterVideoMode(80, 25, False,@DefaultVideoModeSelector, $00000002);
+  RegisterVideoMode(80, 25, True, @DefaultVideoModeSelector, $00000003);
+  RegisterVideoMode(80, 50, True, @VideoModeSelector8x8, 0);
+end;
+
+
+initialization
+  RegisterVideoModes;
+
+finalization
+  UnRegisterVideoModes;
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:58  peter
+    * API 2 RTL commit
+
+}
+

rtl/linux/Makefile

@@ -1,5 +1,5 @@
 #
-# Makefile generated by fpcmake v1.00 [2000/12/19]
+# Makefile generated by fpcmake v1.00 [2000/12/22]
 #
 
 defaultrule: all
@@ -50,6 +50,25 @@ else
 SRCEXEEXT=.exe
 endif
 
+# The extension of batch files / scripts
+ifdef inUnix
+BATCHEXT=.sh
+else
+ifdef inOS2
+BATCHEXT=.cmd
+else
+BATCHEXT=.bat
+endif
+endif
+
+# Path Separator, the subst trick is necessary for the \ that can't exists
+# at the end of a line
+ifdef inUnix
+PATHSEP=/
+else
+PATHSEP=$(subst /,\,/)
+endif
+
 # The path which is searched separated by spaces
 ifdef inUnix
 SEARCHPATH=$(subst :, ,$(PATH))
@@ -203,7 +222,7 @@ endif
 # Targets
 
 override LOADEROBJECTS+=prt0 cprt0 gprt0 cprt21 gprt21
-override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings linux ports initc dos crt objects printer graph ggigraph sysutils typinfo math varutils cpu mmx getopts heaptrc lineinfo errors sockets gpm ipc serial dl dynlibs
+override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings linux ports initc dos crt objects printer graph ggigraph sysutils typinfo math varutils cpu mmx getopts heaptrc lineinfo errors sockets gpm ipc serial terminfo dl dynlibs video mouse keyboard
 override RSTOBJECTS+=math varutils
 
 # Clean
@@ -348,15 +367,7 @@ LD=ld
 endif
 
 # ppas.bat / ppas.sh
-ifdef inUnix
-PPAS=ppas.sh
-else
-ifdef inOS2
-PPAS=ppas.cmd
-else
-PPAS=ppas.bat
-endif
-endif
+PPAS=ppas$(BATCHEXT)
 
 # ldconfig to rebuild .so cache
 ifdef inUnix
@@ -1119,18 +1130,48 @@ USETAR=1
 endif
 endif
 
+# Use a wrapper script by default for OS/2
+ifdef inOS2
+USEZIPWRAPPER=1
+endif
+
+# Create commands to create the zip/tar file
+ZIPWRAPPER=$(DESTZIPDIR)/fpczip$(BATCHEXT)
+ZIPCMD_CDPACK:=cd $(subst /,$(PATHSEP),$(PACKDIR))
+ZIPCMD_CDBASE:=cd $(subst /,$(PATHSEP),$(BASEDIR))
+ifdef USETAR
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
+ZIPCMD_ZIP:=$(TARPROG) cf$(TAROPT) $(ZIPDESTFILE) *
+else
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
+ZIPCMD_ZIP:=$(subst /,$(PATHSEP),$(ZIPPROG)) -Dr $(ZIPOPT) $(ZIPDESTFILE) *
+endif
+
 fpc_zipinstall:
 ifndef ZIPNAME
 	@$(ECHO) "Please specify ZIPNAME!"
 	@exit 1
 else
 	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
-ifdef USETAR
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
-	cd $(PACKDIR) ; $(TARPROG) cf$(TAROPT) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR)
+	$(DEL) $(ZIPDESTFILE)
+ifdef USEZIPWRAPPER
+ifneq ($(ECHO),echo)
+	$(ECHO) "$(ZIPCMD_CDPACK)" > $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_ZIP)" >> $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_CDBASE)" >> $(ZIPWRAPPER)
+else
+	$(ECHO) $(ZIPCMD_CDPACK) > $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_ZIP) >> $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_CDBASE) >> $(ZIPWRAPPER)
+endif
+ifdef inUnix
+	/bin/sh $(ZIPWRAPPER)
 else
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
-	cd $(PACKDIR) ; $(ZIPPROG) -Dr $(ZIPOPT) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) * ; cd $(BASEDIR)
+	$(ZIPWRAPPER)
+endif
+	$(DEL) $(ZIPWRAPPER)
+else
+	$(ZIPCMD_CDPACK) ; $(ZIPCMD_ZIP) ; $(ZIPCMD_CDBASE)
 endif
 	$(DELTREE) $(PACKDIR)
 endif
@@ -1396,6 +1437,7 @@ heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT)
 
 lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT)
 
+
 #
 # Other $(SYSTEMUNIT)-dependent RTL Units
 #
@@ -1406,3 +1448,5 @@ sockets$(PPUEXT) : sockets.pp $(INC)/textrec.inc $(INC)/filerec.inc \
 errors$(PPUEXT) : errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 
 ipc$(PPUEXT) : ipc.pp linux$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
+
+terminfo$(PPUEXT) : terminfo.pp linux$(PPUEXT)

rtl/linux/Makefile.fpc

@@ -9,7 +9,9 @@ units=$(SYSTEMUNIT) objpas strings \
       dos crt objects printer graph ggigraph \
       sysutils typinfo math varutils \
       cpu mmx getopts heaptrc lineinfo \
-      errors sockets gpm ipc serial dl dynlibs
+      errors sockets gpm ipc serial terminfo dl dynlibs \
+      video mouse keyboard
+
 rst=math varutils
 
 [clean]
@@ -203,6 +205,7 @@ heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT)
 
 lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT)
 
+
 #
 # Other $(SYSTEMUNIT)-dependent RTL Units
 #
@@ -213,3 +216,6 @@ sockets$(PPUEXT) : sockets.pp $(INC)/textrec.inc $(INC)/filerec.inc \
 errors$(PPUEXT) : errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 
 ipc$(PPUEXT) : ipc.pp linux$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
+
+terminfo$(PPUEXT) : terminfo.pp linux$(PPUEXT)
+

rtl/os2/Makefile

@@ -1,5 +1,5 @@
 #
-# Makefile generated by fpcmake v1.00 [2000/12/19]
+# Makefile generated by fpcmake v1.00 [2000/12/22]
 #
 
 defaultrule: all
@@ -50,6 +50,25 @@ else
 SRCEXEEXT=.exe
 endif
 
+# The extension of batch files / scripts
+ifdef inUnix
+BATCHEXT=.sh
+else
+ifdef inOS2
+BATCHEXT=.cmd
+else
+BATCHEXT=.bat
+endif
+endif
+
+# Path Separator, the subst trick is necessary for the \ that can't exists
+# at the end of a line
+ifdef inUnix
+PATHSEP=/
+else
+PATHSEP=$(subst /,\,/)
+endif
+
 # The path which is searched separated by spaces
 ifdef inUnix
 SEARCHPATH=$(subst :, ,$(PATH))
@@ -190,7 +209,7 @@ endif
 # Targets
 
 override LOADEROBJECTS+=prt0 prt1 code2 code3
-override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings ports os2def doscalls moncalls kbdcalls moucalls viocalls pmbitmap pmwin pmgpi dive dos crt objects printer sysutils math typinfo varutils ucomplex cpu mmx getopts heaptrc lineinfo dynlibs
+override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings ports os2def doscalls moncalls kbdcalls moucalls viocalls pmbitmap pmwin pmgpi dive dos crt objects printer sysutils math typinfo varutils ucomplex cpu mmx getopts heaptrc lineinfo dynlibs video mouse keyboard
 override RSTOBJECTS+=math
 
 # Clean
@@ -331,15 +350,7 @@ LD=ld
 endif
 
 # ppas.bat / ppas.sh
-ifdef inUnix
-PPAS=ppas.sh
-else
-ifdef inOS2
-PPAS=ppas.cmd
-else
-PPAS=ppas.bat
-endif
-endif
+PPAS=ppas$(BATCHEXT)
 
 # ldconfig to rebuild .so cache
 ifdef inUnix
@@ -1102,18 +1113,48 @@ USETAR=1
 endif
 endif
 
+# Use a wrapper script by default for OS/2
+ifdef inOS2
+USEZIPWRAPPER=1
+endif
+
+# Create commands to create the zip/tar file
+ZIPWRAPPER=$(DESTZIPDIR)/fpczip$(BATCHEXT)
+ZIPCMD_CDPACK:=cd $(subst /,$(PATHSEP),$(PACKDIR))
+ZIPCMD_CDBASE:=cd $(subst /,$(PATHSEP),$(BASEDIR))
+ifdef USETAR
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
+ZIPCMD_ZIP:=$(TARPROG) cf$(TAROPT) $(ZIPDESTFILE) *
+else
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
+ZIPCMD_ZIP:=$(subst /,$(PATHSEP),$(ZIPPROG)) -Dr $(ZIPOPT) $(ZIPDESTFILE) *
+endif
+
 fpc_zipinstall:
 ifndef ZIPNAME
 	@$(ECHO) "Please specify ZIPNAME!"
 	@exit 1
 else
 	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
-ifdef USETAR
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
-	cd $(PACKDIR) ; $(TARPROG) cf$(TAROPT) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR)
+	$(DEL) $(ZIPDESTFILE)
+ifdef USEZIPWRAPPER
+ifneq ($(ECHO),echo)
+	$(ECHO) "$(ZIPCMD_CDPACK)" > $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_ZIP)" >> $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_CDBASE)" >> $(ZIPWRAPPER)
+else
+	$(ECHO) $(ZIPCMD_CDPACK) > $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_ZIP) >> $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_CDBASE) >> $(ZIPWRAPPER)
+endif
+ifdef inUnix
+	/bin/sh $(ZIPWRAPPER)
+else
+	$(ZIPWRAPPER)
+endif
+	$(DEL) $(ZIPWRAPPER)
 else
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
-	cd $(PACKDIR) ; $(ZIPPROG) -Dr $(ZIPOPT) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) * ; cd $(BASEDIR)
+	$(ZIPCMD_CDPACK) ; $(ZIPCMD_ZIP) ; $(ZIPCMD_CDBASE)
 endif
 	$(DELTREE) $(PACKDIR)
 endif

rtl/os2/Makefile.fpc

@@ -9,7 +9,8 @@ units=$(SYSTEMUNIT) objpas strings \
       pmbitmap pmwin pmgpi dive \
       dos crt objects printer \
       sysutils math typinfo varutils \
-      ucomplex cpu mmx getopts heaptrc lineinfo dynlibs
+      ucomplex cpu mmx getopts heaptrc lineinfo dynlibs \
+      video mouse keyboard
 rst=math
 
 [require]

rtl/os2/keyboard.pp

@@ -0,0 +1,170 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Keyboard unit for linux
+
+    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.
+
+ **********************************************************************}
+unit Keyboard;
+interface
+
+{$i keybrdh.inc}
+
+implementation
+
+uses
+ KbdCalls, DosCalls;
+
+{$i keyboard.inc}
+
+const
+ DefaultKeyboard = 0;
+ Handle: word = DefaultKeyboard;
+
+procedure InitKeyboard;
+var
+ K: TKbdInfo;
+begin
+ if KbdGetFocus (IO_Wait, DefaultKeyboard) = No_Error then
+ begin
+  if KbdOpen (Handle) <> No_Error then Handle := DefaultKeyboard;
+  KbdFlushBuffer (Handle);
+  KbdFreeFocus (DefaultKeyboard);
+  KbdGetFocus (IO_Wait, Handle);
+  K.cb := 10;
+  KbdGetStatus (K, Handle);
+  K.fsMask := $14;
+  KbdSetStatus (K, Handle);
+ end;
+end;
+
+procedure DoneKeyboard;
+begin
+ KbdFreeFocus (Handle);
+ if KbdGetFocus (IO_Wait, DefaultKeyboard) = No_Error then
+ begin
+  KbdClose (Handle);
+  Handle := DefaultKeyboard;
+  KbdFreeFocus (DefaultKeyboard);
+ end;
+end;
+
+function GetKeyEvent: TKeyEvent;
+var
+ K: TKbdKeyInfo;
+begin
+ if PendingKeyEvent <> 0 then
+ begin
+  GetKeyEvent := PendingKeyEvent;
+  PendingKeyEvent := 0;
+ end else
+ begin
+  KbdGetFocus (IO_Wait, Handle);
+  while (KbdCharIn (K, IO_Wait, Handle) <> No_Error)
+                                   or (K.fbStatus and $40 = 0) do DosSleep (5);
+  with K do
+  begin
+   if (byte (chChar) = $E0) and (fbStatus and 2 <> 0) then chChar := #0;
+   GetKeyEvent := cardinal ($0300 or fsState and $F) shl 16 or
+                               cardinal (byte (chScan)) shl 8 or byte (chChar);
+  end;
+ end;
+end;
+
+function PollKeyEvent: TKeyEvent;
+var
+ K: TKbdKeyInfo;
+begin
+ if PendingKeyEvent = 0 then
+ begin
+  KbdGetFocus (IO_NoWait, Handle);
+  if (KbdCharIn (K, IO_NoWait, Handle) <> No_Error) or
+                 (K.fbStatus and $40 = 0) then FillChar (K, SizeOf (K), 0) else
+  with K do
+  begin
+   if (byte (chChar) = $E0) and (fbStatus and 2 <> 0) then chChar := #0;
+   PendingKeyEvent := cardinal ($0300 or fsState and $F) shl 16 or
+                               cardinal (byte (chScan)) shl 8 or byte (chChar);
+  end;
+ end;
+ PollKeyEvent := PendingKeyEvent;
+ if PendingKeyEvent and $FFFF = 0 then PendingKeyEvent := 0;
+end;
+
+function PollShiftStateEvent: TKeyEvent;
+var
+ K: TKbdInfo;
+begin
+ KbdGetFocus (IO_NoWait, Handle);
+ KbdGetStatus (K, Handle);
+ PollShiftStateEvent := cardinal (K.fsState and $F) shl 16;
+end;
+
+type
+ TTranslationEntry = packed record
+  Min, Max: byte;
+  Offset: word;
+ end;
+
+const
+ TranslationTableEntries = 12;
+ TranslationTable: array [1..TranslationTableEntries] of TTranslationEntry =
+    ((Min: $3B; Max: $44; Offset: kbdF1),   { function keys F1-F10 }
+     (Min: $54; Max: $5D; Offset: kbdF1),   { Shift fn keys F1-F10 }
+     (Min: $5E; Max: $67; Offset: kbdF1),   { Ctrl fn keys F1-F10 }
+     (Min: $68; Max: $71; Offset: kbdF1),   { Alt fn keys F1-F10 }
+     (Min: $85; Max: $86; Offset: kbdF11),  { function keys F11-F12 }
+     (Min: $87; Max: $88; Offset: kbdF11),  { Shift+function keys F11-F12 }
+     (Min: $89; Max: $8A; Offset: kbdF11),  { Ctrl+function keys F11-F12 }
+     (Min: $8B; Max: $8C; Offset: kbdF11),  { Alt+function keys F11-F12 }
+     (Min:  71; Max:  73; Offset: kbdHome), { Keypad keys kbdHome-kbdPgUp }
+     (Min:  75; Max:  77; Offset: kbdLeft), { Keypad keys kbdLeft-kbdRight }
+     (Min:  79; Max:  81; Offset: kbdEnd),  { Keypad keys kbdEnd-kbdPgDn }
+     (Min: $52; Max: $53; Offset: kbdInsert));
+
+
+function TranslateKeyEvent (KeyEvent: TKeyEvent): TKeyEvent;
+var
+ I: integer;
+ ScanCode: byte;
+begin
+ if KeyEvent and $03000000 = $03000000 then
+ begin
+  if (KeyEvent and $000000FF <> 0) and (KeyEvent and $000000FF <> $E0) then
+                               TranslateKeyEvent := KeyEvent and $00FFFFFF else
+  begin
+{ This is a function key }
+   ScanCode := (KeyEvent and $0000FF00) shr 8;
+   I := 1;
+   while (I <= TranslationTableEntries) and
+       ((TranslationTable [I].Min > ScanCode) or
+                             (ScanCode > TranslationTable [I].Max)) do Inc (I);
+   if I > TranslationTableEntries then TranslateKeyEvent := KeyEvent else
+           TranslateKeyEvent := $02000000 + (KeyEvent and $00FF0000) +
+             (ScanCode - TranslationTable[I].Min) + TranslationTable[I].Offset;
+  end;
+ end else TranslateKeyEvent := KeyEvent;
+end;
+
+function TranslateKeyEventUniCode (KeyEvent: TKeyEvent): TKeyEvent;
+begin
+ TranslateKeyEventUniCode := KeyEvent;
+ ErrorHandler (errKbdNotImplemented, nil);
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:58  peter
+    * API 2 RTL commit
+
+}

rtl/os2/mouse.pp

@@ -0,0 +1,397 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Mouse unit for linux
+
+    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.
+
+ **********************************************************************}
+unit Mouse;
+interface
+
+const
+  MouseEventBufSize = 16;
+
+{$i mouseh.inc}
+
+implementation
+
+uses
+ Video,
+ MouCalls, DosCalls;
+
+
+var
+ PendingMouseEventOrder: array [0..MouseEventBufSize-1] of cardinal;
+ MouseEventOrderHead, MouseEventOrderTail: cardinal;
+
+const
+ NoMouse = $FFFF;
+ DefaultMouse = 0;
+ Handle: word = DefaultMouse;
+ HideCounter: cardinal = 0;
+ OldEventMask: longint = -1;
+
+procedure InitMouse;
+var
+ Loc: TPtrLoc;
+ SetPrev: boolean;
+ SysEvent: TMouEventInfo;
+ QI: TMouQueInfo;
+ W: word;
+begin
+ SetPrev := MouGetPtrPos (Loc, DefaultMouse) = 0;
+ if MouGetEventMask (W, DefaultMouse) = 0 then OldEventMask := W;
+ PendingMouseHead := @PendingMouseEvent;
+ PendingMouseTail := @PendingMouseEvent;
+ PendingMouseEvents := 0;
+ FillChar (LastMouseEvent, SizeOf (TMouseEvent), 0);
+ MouseEventOrderTail := 0;
+ MouseEventOrderHead := 0;
+ HideCounter := 0;
+ if MouOpen (nil, Handle) = Error_Mouse_No_Device then Handle := NoMouse else
+ begin
+  W := Mou_NoWait;
+  repeat
+   MouGetNumQueEl (QI, Handle);
+   if QI.cEvents <> 0 then MouReadEventQue (SysEvent, W, Handle);
+  until QI.cEvents = 0;
+  W := $FFFF;
+  MouSetEventMask (W, Handle);
+  if SetPrev then MouSetPtrPos (Loc, Handle);
+
+(*
+ It would be possible to issue a MouRegister call here to hook our own mouse
+ handler, but such handler would have to be in a DLL and it is questionable,
+ whether there would be so many advantages in doing so.
+*)
+
+  MouDrawPtr (Handle);
+ end;
+end;
+
+procedure DoneMouse;
+var
+ W: word;
+begin
+ if (Handle <> NoMouse) and (Handle <> DefaultMouse) then
+ begin
+
+(*
+ If our own mouse handler would be installed in InitMouse, MouDeregister would
+ have appeared here.
+*)
+
+  HideCounter := 0;
+  HideMouse;
+  MouClose (Handle);
+ end;
+ if OldEventMask <> -1 then
+ begin
+  W := OldEventMask;
+  MouSetEventMask (W, 0);
+ end;
+end;
+
+function DetectMouse:byte;
+var
+ Buttons: word;
+ RC: longint;
+ TempHandle: word;
+begin
+ MouOpen (nil, TempHandle);
+ if MouGetNumButtons (Buttons, TempHandle) = 0 then DetectMouse := Buttons
+                                                         else DetectMouse := 0;
+ MouClose (TempHandle);
+end;
+
+procedure ShowMouse;
+begin
+ if Handle <> NoMouse then
+ begin
+  if HideCounter <> 0 then
+  begin
+   Dec (HideCounter);
+   if HideCounter = 0 then MouDrawPtr (Handle);
+  end;
+ end;
+end;
+
+procedure HideMouse;
+var
+ PtrRect: TNoPtrRect;
+begin
+ if Handle <> NoMouse then
+ begin
+  Inc (HideCounter);
+  case HideCounter of
+   0: Dec (HideCounter); (* HideCounter overflowed - stay at the maximum *)
+   1: begin
+       PtrRect.Row := 0;
+       PtrRect.Col := 0;
+       PtrRect.cRow := Pred (ScreenHeight);
+       PtrRect.cCol := Pred (ScreenWidth);
+       MouRemovePtr (PtrRect, Handle);
+      end;
+  end;
+ end;
+end;
+
+function GetMouseX: word;
+var
+ Event: TMouseEvent;
+begin
+ if Handle = NoMouse then GetMouseX := 0 else
+ begin
+  PollMouseEvent (Event);
+  GetMouseX := Event.X;
+ end;
+end;
+
+function GetMouseY: word;
+var
+ Event: TMouseEvent;
+begin
+ if Handle = NoMouse then GetMouseY := 0 else
+ begin
+  PollMouseEvent (Event);
+  GetMouseY := Event.Y;
+ end;
+end;
+
+procedure GetMouseXY (var X: word; var Y: word);
+var
+ Loc: TPtrLoc;
+begin
+ if Handle = NoMouse then
+ begin
+  X := 0;
+  Y := 0;
+ end else if MouGetPtrPos (Loc, Handle) <> 0 then
+ begin
+  X := $FFFF;
+  Y := $FFFF;
+ end else
+ begin
+  X := Loc.Col;
+  Y := Loc.Row;
+ end;
+end;
+
+procedure SetMouseXY (X, Y: word);
+var
+ Loc: TPtrLoc;
+begin
+ if Handle <> NoMouse then
+ begin
+  Loc.Row := Y;
+  Loc.Col := X;
+  MouSetPtrPos (Loc, Handle);
+ end;
+end;
+
+procedure TranslateEvents (const SysEvent: TMouEventInfo;
+                                                       var Event: TMouseEvent);
+begin
+ Event.Buttons := 0;
+ Event.Action := 0;
+ if SysEvent.fs and (Mouse_Motion_With_BN1_Down or Mouse_BN1_Down) <> 0 then
+                             Event.Buttons := Event.Buttons or MouseLeftButton;
+ if SysEvent.fs and (Mouse_Motion_With_BN2_Down or Mouse_BN2_Down) <> 0 then
+                            Event.Buttons := Event.Buttons or MouseRightButton;
+ if SysEvent.fs and (Mouse_Motion_With_BN3_Down or Mouse_BN3_Down) <> 0 then
+                           Event.Buttons := Event.Buttons or MouseMiddleButton;
+ Event.X := SysEvent.Col;
+ Event.Y := SysEvent.Row;
+ if Event.Buttons <> LastMouseEvent.Buttons then
+  if (Event.Buttons and MouseLeftButton = 0) and
+      (LastMouseEvent.Buttons and MouseLeftButton = MouseLeftButton)
+                                   then Event.Action := MouseActionUp else
+  if (Event.Buttons and MouseRightButton = 0) and
+      (LastMouseEvent.Buttons and MouseRightButton = MouseRightButton)
+                                   then Event.Action := MouseActionUp else
+  if (Event.Buttons and MouseMiddleButton = 0) and
+   (LastMouseEvent.Buttons and MouseMiddleButton = MouseMiddleButton)
+    then Event.Action := MouseActionUp
+     else Event.Action := MouseActionDown
+      else if (Event.X <> LastMouseEvent.X) or (Event.Y <> LastMouseEvent.Y)
+                                          then Event.Action := MouseActionMove;
+ LastMouseEvent := Event;
+end;
+
+procedure NullOrder;
+var
+ I: cardinal;
+begin
+ if PendingMouseEvents > 0 then
+ begin
+  I := MouseEventOrderHead;
+  repeat
+   PendingMouseEventOrder [I] := 0;
+   if I = Pred (MouseEventBufSize) then I := 0 else Inc (I);
+  until (I <> MouseEventOrderTail);
+ end;
+end;
+
+procedure LowerOrder;
+var
+ I: cardinal;
+begin
+ if PendingMouseEvents > 0 then
+ begin
+  I := MouseEventOrderHead;
+  repeat
+   if PendingMouseEventOrder [I] <> 0 then
+   begin
+    Dec (PendingMouseEventOrder [I]);
+    if I = Pred (MouseEventBufSize) then I := 0 else Inc (I);
+   end;
+  until (I <> MouseEventOrderTail) or (PendingMouseEventOrder [I] = 0);
+ end;
+end;
+
+function PollMouseEvent (var MouseEvent: TMouseEvent) :boolean;
+var
+ SysEvent: TMouEventInfo;
+ P, Q: PMouseEvent;
+ Event: TMouseEvent;
+ WF: word;
+ QI: TMouQueInfo;
+begin
+ if (PendingMouseEvents = 0) or
+         (PendingMouseEventOrder [MouseEventOrderHead] <> 0) and
+                                  (PendingMouseEvents < MouseEventBufSize) then
+ begin
+  MouGetNumQueEl (QI, Handle);
+  if QI.cEvents = 0 then NullOrder else
+  begin
+   LowerOrder;
+   WF := Mou_NoWait;
+   if (MouReadEventQue (SysEvent, WF, Handle) = 0) then
+   begin
+    if PendingMouseHead = @PendingMouseEvent then
+                           P := @PendingMouseEvent [MouseEventBufSize - 1] else
+    begin
+     P := PendingMouseHead;
+     Dec (P);
+    end;
+    TranslateEvents (SysEvent, P^);
+    if P^.Action <> 0 then
+    begin
+     if PendingMouseEvents < MouseEventBufSize then
+     begin
+      Q := P;
+      WF := Mou_NoWait;
+      while (P^.Action = MouseActionMove) and
+       (PendingMouseEventOrder [MouseEventOrderHead] <> 0) and
+         (MouReadEventQue (SysEvent, WF, Handle) = 0) and
+                       ((SysEvent.fs <> 0) or (LastMouseEvent.Buttons <> 0)) do
+      begin
+       LowerOrder;
+       TranslateEvents (SysEvent, Event);
+       if Event.Action <> MouseActionMove then
+       begin
+        if Q = @PendingMouseEvent then
+                  Q := @PendingMouseEvent [MouseEventBufSize - 1] else Dec (Q);
+        if MouseEventOrderHead = 0 then
+                  MouseEventOrderHead := MouseEventBufSize - 1 else
+                                                     Dec (MouseEventOrderHead);
+        PendingMouseEventOrder [MouseEventOrderHead] := 0;
+        Q^ := P^;
+        Inc (PendingMouseEvents);
+        if MouseEventOrderHead = 0 then
+               MouseEventOrderHead := MouseEventBufSize - 1 else
+                                                     Dec (MouseEventOrderHead);
+        PendingMouseEventOrder [MouseEventOrderHead] := 0;
+       end else WF := Mou_NoWait;
+       P^ := Event;
+      end;
+      P := Q;
+     end;
+     Inc (PendingMouseEvents);
+     if MouseEventOrderHead = 0 then
+               MouseEventOrderHead := MouseEventBufSize - 1 else
+                                                     Dec (MouseEventOrderHead);
+     PendingMouseEventOrder [MouseEventOrderHead] := 0;
+     PendingMouseHead := P;
+    end;
+   end else NullOrder;
+  end;
+ end;
+ if PendingMouseEvents <> 0 then
+ begin
+  MouseEvent := PendingMouseHead^;
+  LastMouseEvent := MouseEvent;
+  PollMouseEvent := true;
+ end else
+ begin
+  PollMouseEvent := false;
+  MouseEvent := LastMouseEvent;
+  MouseEvent.Action := 0;
+ end;
+end;
+
+function GetMouseButtons: word;
+var
+ Event: TMouseEvent;
+begin
+ PollMouseEvent (Event);
+ GetMouseButtons := Event.Buttons;
+end;
+
+procedure GetMouseEvent (var MouseEvent: TMouseEvent);
+var
+ Event: TMouEventInfo;
+begin
+ if (PendingMouseEvents = 0) or
+                       (PendingMouseEventOrder [MouseEventOrderHead] <> 0) then
+ repeat
+  DosSleep (1);
+  PollMouseEvent (MouseEvent);
+ until (PendingMouseEvents <> 0) and
+                        (PendingMouseEventOrder [MouseEventOrderHead] = 0) else
+ begin
+  MouseEvent := PendingMouseHead^;
+  LastMouseEvent := MouseEvent;
+ end;
+ Inc (PendingMouseHead);
+ if longint (PendingMouseHead) = longint (@PendingMouseEvent)
+      + SizeOf (PendingMouseEvent) then PendingMouseHead := @PendingMouseEvent;
+ Inc (MouseEventOrderHead);
+ if MouseEventOrderHead = MouseEventBufSize then MouseEventOrderHead := 0;
+ Dec (PendingMouseEvents);
+end;
+
+procedure PutMouseEvent (const MouseEvent: TMouseEvent);
+var
+ QI: TMouQueInfo;
+begin
+ if PendingMouseEvents < MouseEventBufSize then
+ begin
+  PendingMouseTail^ := MouseEvent;
+  Inc (PendingMouseTail);
+  if longint (PendingMouseTail) = longint (@PendingMouseEvent) +
+        SizeOf (PendingMouseEvent) then PendingMouseTail := @PendingMouseEvent;
+  MouGetNumQueEl (QI, Handle);
+  PendingMouseEventOrder [MouseEventOrderTail] := QI.cEvents;
+  Inc (MouseEventOrderTail);
+  if MouseEventOrderTail = MouseEventBufSize then MouseEventOrderTail := 0;
+  Inc (PendingMouseEvents);
+ end;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:58  peter
+    * API 2 RTL commit
+
+}

rtl/os2/video.pp

@@ -0,0 +1,435 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Video unit for OS/2
+
+    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.
+
+ **********************************************************************}
+unit Video;
+
+interface
+
+{$i videoh.inc}
+
+implementation
+
+uses
+  DosCalls, VioCalls;
+
+{$i video.inc}
+
+
+const
+    InitVideoCalled: boolean = false;
+    LastCursorType: word = crUnderline;
+    EmptyCell: cardinal = $0720;
+    OrigScreen: PVideoBuf = nil;
+    OrigScreenSize: cardinal = 0;
+
+var OrigCurType: TVioCursorInfo;
+    OrigVioMode: TVioModeInfo;
+    OrigHighBit: TVioIntensity;
+    OrigCurRow: word;
+    OrigCurCol: word;
+    CellHeight: byte;
+    OldVideoBuf: PVideoBuf;
+
+procedure TargetEntry;
+
+var P: PVideoModeList;
+    PScr: pointer;
+
+begin
+{Remember original video mode, cursor type and high bit behaviour setting}
+    OrigVioMode.cb := SizeOf (OrigVioMode);
+    VioGetMode (OrigVioMode, 0);
+    VioGetCurType (OrigCurType, 0);
+    VioGetCurPos (OrigCurRow, OrigCurCol, 0);
+    with OrigHighBit do
+        begin
+            cb := 6;
+            rType := 2;
+        end;
+    VioGetState (OrigHighBit, 0);
+{Register the curent video mode in Modes if not there yet}
+    with OrigVioMode do
+        begin
+            P := Modes;
+            while (P <> nil) and ((P^.Row <> Row) or (P^.Col <> Col)
+                                      or (P^.Color <> (Color >= Colors_16))) do
+                P := P^.Next;
+            if P = nil then
+{Assume we have at least 16 colours available in "colour" modes}
+                RegisterVideoMode (Col, Row, Color >= Colors_16,
+                                                @DefaultVideoModeSelector, 0);
+        end;
+{Get the address of the original videobuffer and size.}
+    if VioGetBuf (PScr, PWord (@OrigScreenSize)^, 0) = 0 then
+        begin
+            PScr := SelToFlat (TFarPtr (PScr));
+            GetMem (OrigScreen, OrigScreenSize);
+            Move (PScr^, OrigScreen^, OrigScreenSize);
+        end;
+end;
+
+procedure CheckCellHeight;
+
+var OldCD, CD: TVioCursorInfo;
+
+begin
+    VioGetCurType (OldCD, 0);
+    Move (OldCD, CD, SizeOf (CD));
+    with CD do
+        begin
+            Attr := 0;
+            yStart := word (-90);
+            cEnd := word (-100);
+        end;
+    VioSetCurType (CD, 0);
+    VioGetCurType (CD, 0);
+    CellHeight := CD.cEnd;
+    VioSetCurType (OldCD, 0);
+end;
+
+
+procedure RegisterVideoModes;
+begin
+{ BW modes are rejected on my (colour) configuration. I can't imagine
+  OS/2 running on MCGA anyway... ;-)
+
+    RegisterVideoMode (40, 25, False, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 25, False, @DefaultVideoModeSelector, 0);
+}
+    RegisterVideoMode (40, 25, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 25, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 30, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 43, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (80, 50, True, @DefaultVideoModeSelector, 0);
+
+{ The following modes wouldn't work on plain VGA; is it useful to check
+  for their availability on the program startup?
+
+    RegisterVideoMode (132, 25, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (132, 30, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (132, 43, True, @DefaultVideoModeSelector, 0);
+    RegisterVideoMode (132, 50, True, @DefaultVideoModeSelector, 0);
+}
+end;
+
+
+procedure SetHighBitBlink (Blink: boolean);
+
+var VI: TVioIntensity;
+
+begin
+    with VI do
+        begin
+            cb := 6;
+            rType := 2;
+            fs := byte (not (Blink));
+        end;
+    VioSetState (VI, 0);
+end;
+
+
+procedure InitVideo;
+
+var MI: TVioModeInfo;
+
+begin
+    if InitVideoCalled then
+        FreeMem (OldVideoBuf, VideoBufSize);
+    OldVideoBuf := nil;
+    InitVideoCalled := true;
+    VideoBufSize := 0;
+    MI.cb := SizeOf (MI);
+    VioGetMode (MI, 0);
+    with MI do
+        begin
+            ScreenWidth := Col;
+            ScreenHeight := Row;
+            ScreenColor := Color >= Colors_16;
+        end;
+    VioGetCurPos (CursorY, CursorX, 0);
+    LowAscii := true;
+    SetCursorType (LastCursorType);
+{Get the address of the videobuffer.}
+    if VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0) = 0 then
+        begin
+            VideoBuf := SelToFlat (TFarPtr (VideoBuf));
+            SetHighBitBlink (true);
+            GetMem (OldVideoBuf, VideoBufSize);
+            Move (VideoBuf^, OldVideoBuf^, VideoBufSize);
+        end
+    else
+        ErrorHandler (errVioInit, nil);
+end;
+
+
+procedure SetCursorPos (NewCursorX, NewCursorY: word);
+
+begin
+    if VioSetCurPos (NewCursorY, NewCursorX, 0) = 0 then
+        begin
+            CursorX := NewCursorX;
+            CursorY := NewCursorY;
+        end
+    else
+        {Do not set an error code; people should fix invalid NewCursorX
+         or NewCursorY values when designing, there is no need for detecting
+         these errors at runtime.}
+        RunError (225);
+end;
+
+
+function GetCursorType: word;
+
+var CD: TVioCursorInfo;
+
+begin
+    VioGetCurType (CD, 0);    {Never fails, because handle is default handle.}
+    with CD do
+        begin
+            CursorLines := Succ (cEnd) - yStart;
+            if Attr = word (-1) then
+                GetCursorType := crHidden
+            else
+{Because the cursor's start and end lines are returned, we'll have
+ to guess heuristically what cursor type we have.}
+                if CursorLines = 0 then
+{Probably this does not occur, but you'll never know.}
+                    GetCursorType := crHidden
+                else if CursorLines <= Succ (CellHeight div 4) then
+                    GetCursorType := crUnderline
+                else if CursorLines <= Succ (CellHeight div 2) then
+                    GetCursorType := crHalfBlock
+                else
+                    GetCursorType := crBlock;
+        end;
+end;
+
+
+procedure SetCursorType (NewType: word);
+
+var CD: TVioCursorInfo;
+
+begin
+    VioGetCurType (CD, 0);
+    with CD do
+        begin
+            case NewType of
+                crHidden: Attr := word (-1);
+                crUnderline:
+                    begin
+                        Attr := 0;
+                        yStart := word (-90);
+                        cEnd := word (-100);
+                    end;
+                crHalfBlock:
+                    begin
+                        Attr := 0;
+                        yStart := word (-50);
+                        cEnd := word (-100);
+                    end;
+                crBlock:
+                    begin
+                        Attr := 0;
+                        yStart := 0;
+                        cEnd := word (-100);
+                    end;
+            end;
+            VioSetCurType (CD, 0);
+            VioGetCurType (CD, 0);
+            CursorLines := Succ (cEnd) - yStart;
+        end;
+end;
+
+
+procedure DoneVideo;
+
+var PScr: pointer;
+    ScrSize: cardinal;
+
+begin
+    if InitVideoCalled then
+        begin
+            LastCursorType := GetCursorType;
+            ClearScreen;
+{Restore original settings}
+            VioSetMode (OrigVioMode, 0);
+            CheckCellHeight;
+{Set CursorX and CursorY}
+            SetCursorPos (0, 0);
+            VioSetState (OrigHighBit, 0);
+            VioSetCurType (OrigCurType, 0);
+            VioSetCurPos (OrigCurRow, OrigCurCol, 0);
+            FreeMem (OldVideoBuf, VideoBufSize);
+            OldVideoBuf := nil;
+            VideoBufSize := 0;
+            InitVideoCalled := false;
+            if (OrigScreenSize <> 0) and (OrigScreen <> nil) then
+                begin
+                    ScrSize := 0;
+                    if (VioGetBuf (PScr, PWord (@ScrSize)^, 0) = 0)
+                                            and (ScrSize = OrigScreenSize) then
+                        begin
+                            PScr := SelToFlat (TFarPtr (PScr));
+                            Move (OrigScreen^, PScr^, OrigScreenSize);
+                            VioShowBuf (0, ScrSize, 0);
+                        end;
+                end;
+        end;
+end;
+
+
+function GetCapabilities: word;
+
+begin
+    GetCapabilities := $3F;
+end;
+
+
+function DefaultVideoModeSelector (const VideoMode: TVideoMode; Params: longint): boolean;
+
+var OldMI, MI: TVioModeInfo;
+
+begin
+    OldMI.cb := SizeOf (OldMI);
+    if VioGetMode (OldMI, 0) <> 0 then
+        DefaultVideoModeSelector := false
+    else
+        begin
+            with MI do
+                begin
+                    cb := 8;
+                    fbType := 1;
+                    if VideoMode.Color then
+                        Color := Colors_16
+                    else
+                        Color := Colors_2;
+                    Col := VideoMode.Col;
+                    Row := VideoMode.Row;
+                end;
+            if VioSetMode (MI, 0) = 0 then
+                if VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0) = 0 then
+                    begin
+                        VideoBuf := SelToFlat (TFarPtr (VideoBuf));
+                        DefaultVideoModeSelector := true;
+                        SetHighBitBlink (true);
+                        CheckCellHeight;
+                        SetCursorType (LastCursorType);
+                        ClearScreen;
+                    end
+                else
+                    begin
+                        DefaultVideoModeSelector := false;
+                        VioSetMode (OldMI, 0);
+                        VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0);
+                        VideoBuf := SelToFlat (TFarPtr (VideoBuf));
+                        SetHighBitBlink (true);
+                        CheckCellHeight;
+                        SetCursorType (LastCursorType);
+                        ClearScreen;
+                    end
+            else
+                begin
+                    DefaultVideoModeSelector := false;
+                    VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0);
+                    VideoBuf := SelToFlat (TFarPtr (VideoBuf));
+                    SetHighBitBlink (true);
+                    SetCursorType (LastCursorType);
+                end;
+        end;
+end;
+
+
+procedure ClearScreen;
+
+begin
+    VioScrollDn (0, 0, word (-1), word (-1), word (-1), PWord (@EmptyCell)^, 0);
+    Move (VideoBuf^, OldVideoBuf^, VideoBufSize);
+end;
+
+
+{$ASMMODE INTEL}
+
+procedure UpdateScreen (Force: boolean);
+
+var SOfs, CLen: cardinal;
+
+begin
+    if LockUpdateScreen = 0 then
+        begin
+            if not (Force) then
+                begin
+                    asm
+                        cld
+                        mov esi, VideoBuf
+                        mov edi, OldVideoBuf
+                        mov eax, VideoBufSize
+                        mov ecx, eax
+                        shr ecx
+                        shr ecx
+                        repe
+                        cmpsd
+                        je @no_update
+                        inc cx
+                        mov SOfs, ecx
+                        mov Force, 1
+                        std
+                        mov edi, eax
+                        mov esi, VideoBuf
+                        add eax, esi
+                        sub eax, 4
+                        mov esi, eax
+                        mov eax, OldVideoBuf
+                        add eax, edi
+                        sub eax, 4
+                        mov edi, eax
+                        repe
+                        cmpsd
+                        inc ecx
+                        shl ecx
+                        shl ecx
+                        mov CLen, ecx
+                        cld
+@no_update:
+                    end;
+                    SOfs := VideoBufSize - (SOfs shl 2);
+                end else
+                    begin
+                        SOfs := 0;
+                        CLen := VideoBufSize;
+                    end;
+            if Force then
+                begin
+                    VioShowBuf (SOfs, CLen, 0);
+                    Move (VideoBuf^ [SOfs div SizeOf (TVideoCell)],
+                            OldVideoBuf^ [SOfs div SizeOf (TVideoCell)], CLen);
+                end;
+        end;
+end;
+
+initialization
+  RegisterVideoModes;
+  TargetEntry;
+
+finalization
+  UnRegisterVideoModes;
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:58  peter
+    * API 2 RTL commit
+
+}
+

rtl/unix/keyboard.pp

@@ -0,0 +1,1686 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Keyboard unit for linux
+
+    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.
+
+ **********************************************************************}
+unit Keyboard;
+interface
+
+{$i keybrdh.inc}
+
+Const
+  AltPrefix : byte = 0;
+  ShiftPrefix : byte = 0;
+  CtrlPrefix : byte = 0;
+
+Function RawReadKey:char;
+Function RawReadString : String;
+Function KeyPressed : Boolean;
+{$ifndef NotUseTree}
+Procedure AddSequence(Const St : String; Char,Scan :byte);
+Function FindSequence(Const St : String;var AChar, Ascan : byte) : boolean;
+{$endif NotUseTree}
+
+
+implementation
+
+uses
+  Mouse,
+{$ifndef NotUseTree}
+  Strings,
+  TermInfo,
+{$endif NotUseTree}
+  Linux;
+
+{$i keyboard.inc}
+
+var
+  OldIO : TermIos;
+{$ifdef logging}
+  f : text;
+{$endif logging}
+
+{ list of all dos scancode for key giving 0 as char }
+Const
+   kbNoKey       = $00;
+   kbAltEsc      = $01;
+   kbAltSpace    = $02;
+   kbCtrlIns     = $04;
+   kbShiftIns    = $05;
+   kbCtrlDel     = $06;
+   kbShiftDel    = $07;
+   kbAltBack     = $08;
+   kbAltShiftBack= $09;
+   kbShiftTab    = $0F;
+   kbAltQ        = $10;
+   kbAltW        = $11;
+   kbAltE        = $12;
+   kbAltR        = $13;
+   kbAltT        = $14;
+   kbAltY        = $15;
+   kbAltU        = $16;
+   kbAltI        = $17;
+   kbAltO        = $18;
+   kbAltP        = $19;
+   kbAltLftBrack = $1A;
+   kbAltRgtBrack = $1B;
+   kbAltA        = $1E;
+   kbAltS        = $1F;
+   kbAltD        = $20;
+   kbAltF        = $21;
+   kbAltG        = $22;
+   kbAltH        = $23;
+   kbAltJ        = $24;
+   kbAltK        = $25;
+   kbAltL        = $26;
+   kbAltSemiCol  = $27;
+   kbAltQuote    = $28;
+   kbAltOpQuote  = $29;
+   kbAltBkSlash  = $2B;
+   kbAltZ        = $2C;
+   kbAltX        = $2D;
+   kbAltC        = $2E;
+   kbAltV        = $2F;
+   kbAltB        = $30;
+   kbAltN        = $31;
+   kbAltM        = $32;
+   kbAltComma    = $33;
+   kbAltPeriod   = $34;
+   kbAltSlash    = $35;
+   kbAltGreyAst  = $37;
+   kbF1          = $3B;
+   kbF2          = $3C;
+   kbF3          = $3D;
+   kbF4          = $3E;
+   kbF5          = $3F;
+   kbF6          = $40;
+   kbF7          = $41;
+   kbF8          = $42;
+   kbF9          = $43;
+   kbF10         = $44;
+   kbHome        = $47;
+   kbUp          = $48;
+   kbPgUp        = $49;
+   kbLeft        = $4B;
+   kbCenter      = $4C;
+   kbRight       = $4D;
+   kbAltGrayPlus = $4E;
+   kbend         = $4F;
+   kbDown        = $50;
+   kbPgDn        = $51;
+   kbIns         = $52;
+   kbDel         = $53;
+   kbShiftF1     = $54;
+   kbShiftF2     = $55;
+   kbShiftF3     = $56;
+   kbShiftF4     = $57;
+   kbShiftF5     = $58;
+   kbShiftF6     = $59;
+   kbShiftF7     = $5A;
+   kbShiftF8     = $5B;
+   kbShiftF9     = $5C;
+   kbShiftF10    = $5D;
+   kbCtrlF1      = $5E;
+   kbCtrlF2      = $5F;
+   kbCtrlF3      = $60;
+   kbCtrlF4      = $61;
+   kbCtrlF5      = $62;
+   kbCtrlF6      = $63;
+   kbCtrlF7      = $64;
+   kbCtrlF8      = $65;
+   kbCtrlF9      = $66;
+   kbCtrlF10     = $67;
+   kbAltF1       = $68;
+   kbAltF2       = $69;
+   kbAltF3       = $6A;
+   kbAltF4       = $6B;
+   kbAltF5       = $6C;
+   kbAltF6       = $6D;
+   kbAltF7       = $6E;
+   kbAltF8       = $6F;
+   kbAltF9       = $70;
+   kbAltF10      = $71;
+   kbCtrlPrtSc   = $72;
+   kbCtrlLeft    = $73;
+   kbCtrlRight   = $74;
+   kbCtrlend     = $75;
+   kbCtrlPgDn    = $76;
+   kbCtrlHome    = $77;
+   kbAlt1        = $78;
+   kbAlt2        = $79;
+   kbAlt3        = $7A;
+   kbAlt4        = $7B;
+   kbAlt5        = $7C;
+   kbAlt6        = $7D;
+   kbAlt7        = $7E;
+   kbAlt8        = $7F;
+   kbAlt9        = $80;
+   kbAlt0        = $81;
+   kbAltMinus    = $82;
+   kbAltEqual    = $83;
+   kbCtrlPgUp    = $84;
+   kbF11         = $85;
+   kbF12         = $86;
+   kbShiftF11    = $87;
+   kbShiftF12    = $88;
+   kbCtrlF11     = $89;
+   kbCtrlF12     = $8A;
+   kbAltF11      = $8B;
+   kbAltF12      = $8C;
+   kbCtrlUp      = $8D;
+   kbCtrlMinus   = $8E;
+   kbCtrlCenter  = $8F;
+   kbCtrlGreyPlus= $90;
+   kbCtrlDown    = $91;
+   kbCtrlTab     = $94;
+   kbAltHome     = $97;
+   kbAltUp       = $98;
+   kbAltPgUp     = $99;
+   kbAltLeft     = $9B;
+   kbAltRight    = $9D;
+   kbAltend      = $9F;
+   kbAltDown     = $A0;
+   kbAltPgDn     = $A1;
+   kbAltIns      = $A2;
+   kbAltDel      = $A3;
+   kbAltTab      = $A5;
+
+{$ifdef Unused}
+type
+   TKeyState = Record
+      Normal, Shift, Ctrl, Alt : word;
+     end;
+
+Const
+  KeyStates : Array[0..255] of TKeyState
+    (
+
+    );
+
+{$endif Unused}
+
+Procedure SetRawMode(b:boolean);
+Var
+  Tio : Termios;
+Begin
+  TCGetAttr(1,Tio);
+  if b then
+   begin
+     OldIO:=Tio;
+     Tio.c_iflag:=Tio.c_iflag and (not (IGNBRK or BRKINT or PARMRK or ISTRIP or
+                                INLCR or IGNCR or ICRNL or IXON));
+     Tio.c_lflag:=Tio.c_lflag and (not (ECHO or ECHONL or ICANON or ISIG or IEXTEN));
+   end
+  else
+    Tio := OldIO;
+  TCSetAttr(1,TCSANOW,Tio);
+End;
+
+type
+  chgentry=packed record
+    tab,
+    idx,
+    oldtab,
+    oldidx : byte;
+    oldval,
+    newval : word;
+  end;
+  kbentry=packed record
+    kb_table,
+    kb_index : byte;
+    kb_value : word;
+  end;
+
+const
+  kbdchanges=10;
+  kbdchange:array[1..kbdchanges] of chgentry=(
+    (tab:8; idx:$3b; oldtab:0; oldidx:$3b; oldval:0; newval:0),
+    (tab:8; idx:$3c; oldtab:0; oldidx:$3c; oldval:0; newval:0),
+    (tab:8; idx:$3d; oldtab:0; oldidx:$3d; oldval:0; newval:0),
+    (tab:8; idx:$3e; oldtab:0; oldidx:$3e; oldval:0; newval:0),
+    (tab:8; idx:$3f; oldtab:0; oldidx:$3f; oldval:0; newval:0),
+    (tab:8; idx:$40; oldtab:0; oldidx:$40; oldval:0; newval:0),
+    (tab:8; idx:$41; oldtab:0; oldidx:$41; oldval:0; newval:0),
+    (tab:8; idx:$42; oldtab:0; oldidx:$42; oldval:0; newval:0),
+    (tab:8; idx:$43; oldtab:0; oldidx:$43; oldval:0; newval:0),
+    (tab:8; idx:$44; oldtab:0; oldidx:$44; oldval:0; newval:0)
+  );
+ KDGKBENT=$4B46;
+ KDSKBENT=$4B47;
+
+procedure PatchKeyboard;
+var
+  e : ^chgentry;
+  entry : kbentry;
+  i : longint;
+begin
+  for i:=1 to kbdchanges do
+   begin
+     e:=@kbdchange[i];
+     entry.kb_table:=e^.tab;
+     entry.kb_index:=e^.idx;
+     Ioctl(stdinputhandle,KDGKBENT,@entry);
+     e^.oldval:=entry.kb_value;
+     entry.kb_table:=e^.oldtab;
+     entry.kb_index:=e^.oldidx;
+     ioctl(stdinputhandle,KDGKBENT,@entry);
+     e^.newval:=entry.kb_value;
+   end;
+  for i:=1to kbdchanges do
+   begin
+     e:=@kbdchange[i];
+     entry.kb_table:=e^.tab;
+     entry.kb_index:=e^.idx;
+     entry.kb_value:=e^.newval;
+     Ioctl(stdinputhandle,KDSKBENT,@entry);
+   end;
+end;
+
+
+procedure UnpatchKeyboard;
+var
+  e : ^chgentry;
+  entry : kbentry;
+  i : longint;
+begin
+  for i:=1 to kbdchanges do
+   begin
+     e:=@kbdchange[i];
+     entry.kb_table:=e^.tab;
+     entry.kb_index:=e^.idx;
+     entry.kb_value:=e^.oldval;
+     Ioctl(stdinputhandle,KDSKBENT,@entry);
+   end;
+end;
+
+
+
+{ Buffered Input routines }
+const
+  InSize=256;
+var
+  InBuf  : array [0..InSize-1] of char;
+  InCnt,
+  InHead,
+  InTail : longint;
+
+function ttyRecvChar:char;
+var
+  Readed,i : longint;
+begin
+{Buffer Empty? Yes, Input from StdIn}
+  if (InHead=InTail) then
+   begin
+   {Calc Amount of Chars to Read}
+     i:=InSize-InHead;
+     if InTail>InHead then
+      i:=InTail-InHead;
+   {Read}
+     Readed:=fdRead(StdInputHandle,InBuf[InHead],i);
+   {Increase Counters}
+     inc(InCnt,Readed);
+     inc(InHead,Readed);
+   {Wrap if End has Reached}
+     if InHead>=InSize then
+      InHead:=0;
+   end;
+{Check Buffer}
+  if (InCnt=0) then
+   ttyRecvChar:=#0
+  else
+   begin
+     ttyRecvChar:=InBuf[InTail];
+     dec(InCnt);
+     inc(InTail);
+     if InTail>=InSize then
+      InTail:=0;
+   end;
+end;
+
+
+Const
+  KeyBufferSize = 20;
+var
+  KeyBuffer : Array[0..KeyBufferSize-1] of Char;
+  KeyPut,
+  KeySend   : longint;
+
+Procedure PushKey(Ch:char);
+Var
+  Tmp : Longint;
+Begin
+  Tmp:=KeyPut;
+  Inc(KeyPut);
+  If KeyPut>=KeyBufferSize Then
+   KeyPut:=0;
+  If KeyPut<>KeySend Then
+   KeyBuffer[Tmp]:=Ch
+  Else
+   KeyPut:=Tmp;
+End;
+
+
+Function PopKey:char;
+Begin
+  If KeyPut<>KeySend Then
+   Begin
+     PopKey:=KeyBuffer[KeySend];
+     Inc(KeySend);
+     If KeySend>=KeyBufferSize Then
+      KeySend:=0;
+   End
+  Else
+   PopKey:=#0;
+End;
+
+
+Procedure PushExt(b:byte);
+begin
+  PushKey(#0);
+  PushKey(chr(b));
+end;
+
+
+const
+  AltKeyStr  : string[38]='qwertyuiopasdfghjklzxcvbnm1234567890-=';
+  AltCodeStr : string[38]=#016#017#018#019#020#021#022#023#024#025#030#031#032#033#034#035#036#037#038+
+                          #044#045#046#047#048#049#050#120#121#122#123#124#125#126#127#128#129#130#131;
+Function FAltKey(ch:char):byte;
+var
+  Idx : longint;
+Begin
+  Idx:=Pos(ch,AltKeyStr);
+  if Idx>0 then
+   FAltKey:=byte(AltCodeStr[Idx])
+  else
+   FAltKey:=0;
+End;
+
+
+{ This one doesn't care about keypresses already processed by readkey  }
+{ and waiting in the KeyBuffer, only about waiting keypresses at the   }
+{ TTYLevel (including ones that are waiting in the TTYRecvChar buffer) }
+function sysKeyPressed: boolean;
+var
+  fdsin : fdSet;
+begin
+  if (InCnt>0) then
+   sysKeyPressed:=true
+  else
+   begin
+     FD_Zero(fdsin);
+     fd_Set(StdInputHandle,fdsin);
+     sysKeypressed:=(Select(StdInputHandle+1,@fdsin,nil,nil,0)>0);
+   end;
+end;
+
+Function KeyPressed:Boolean;
+Begin
+  Keypressed := (KeySend<>KeyPut) or sysKeyPressed;
+End;
+
+
+Function IsConsole : Boolean;
+var
+  ThisTTY: String[30];
+  FName : String;
+  TTYfd: longint;
+begin
+  IsConsole:=false;
+  { check for tty }
+  ThisTTY:=TTYName(stdinputhandle);
+  if IsATTY(stdinputhandle) then
+   begin
+     { running on a tty, find out whether locally or remotely }
+     if (Copy(ThisTTY, 1, 8) = '/dev/tty') and
+        (ThisTTY[9] >= '0') and (ThisTTY[9] <= '9') then
+      begin
+        { running on the console }
+        FName:='/dev/vcsa' + ThisTTY[9];
+        { check with read only as it might already be
+          open in ReadWrite by video unit }
+        TTYFd:=fdOpen(FName, 0, Open_RdOnly); { open console }
+      end
+     else
+      TTYFd:=-1;
+     if TTYFd<>-1 then
+      begin
+        IsConsole:=true;
+        fdClose(TTYFd);
+      end;
+   end;
+end;
+
+Const
+  LastMouseEvent : TMouseEvent =
+  (
+    Buttons : 0;
+    X : 0;
+    Y : 0;
+    Action : 0;
+  );
+
+{$ifndef NotUseTree}
+
+  procedure GenMouseEvent;
+  var MouseEvent: TMouseEvent;
+      ch : char;
+      fdsin : fdSet;
+  begin
+    FD_Zero(fdsin);
+    fd_Set(StdInputHandle,fdsin);
+    Fillchar(MouseEvent,SizeOf(TMouseEvent),#0);
+     if InCnt=0 then
+       Select(StdInputHandle+1,@fdsin,nil,nil,10);
+     ch:=ttyRecvChar;
+    { Other bits are used for Shift, Meta and Ctrl modifiers PM }
+    case (ord(ch)-ord(' ')) and 3  of
+      0 : {left button press}
+        MouseEvent.buttons:=1;
+      1 : {middle button pressed }
+        MouseEvent.buttons:=2;
+      2 : { right button pressed }
+        MouseEvent.buttons:=4;
+      3 : { no button pressed };
+      end;
+     if InCnt=0 then
+       Select(StdInputHandle+1,@fdsin,nil,nil,10);
+     ch:=ttyRecvChar;
+     MouseEvent.x:=Ord(ch)-ord(' ')-1;
+     if InCnt=0 then
+      Select(StdInputHandle+1,@fdsin,nil,nil,10);
+     ch:=ttyRecvChar;
+     MouseEvent.y:=Ord(ch)-ord(' ')-1;
+     if (MouseEvent.buttons<>0) then
+       MouseEvent.action:=MouseActionDown
+     else
+       begin
+         if (LastMouseEvent.Buttons<>0) and
+            ((LastMouseEvent.X<>MouseEvent.X) or (LastMouseEvent.Y<>MouseEvent.Y)) then
+           begin
+             MouseEvent.Action:=MouseActionMove;
+             MouseEvent.Buttons:=LastMouseEvent.Buttons;
+{$ifdef DebugMouse}
+             Writeln(system.stderr,' Mouse Move (',MouseEvent.X,',',MouseEvent.Y,')');
+{$endif DebugMouse}
+             PutMouseEvent(MouseEvent);
+             MouseEvent.Buttons:=0;
+           end;
+         MouseEvent.Action:=MouseActionUp;
+       end;
+     PutMouseEvent(MouseEvent);
+{$ifdef DebugMouse}
+     if MouseEvent.Action=MouseActionDown then
+       Write(system.stderr,'Button down : ')
+     else
+       Write(system.stderr,'Button up : ');
+     Writeln(system.stderr,'buttons = ',MouseEvent.Buttons,' (',MouseEvent.X,',',MouseEvent.Y,')');
+{$endif DebugMouse}
+     LastMouseEvent:=MouseEvent;
+  end;
+
+type
+  TProcedure = procedure;
+
+  PTreeElement = ^TTreeElement;
+  TTreeElement = record
+    Next,Parent,Child :  PTreeElement;
+    CanBeTerminal : boolean;
+    char : byte;
+    ScanValue : byte;
+    CharValue : byte;
+    SpecialHandler : TProcedure;
+  end;
+
+var
+  RootTree : Array[0..255] of PTreeElement;
+
+function NewPTree(ch : byte;Pa : PTreeElement) : PTreeElement;
+var PT : PTreeElement;
+begin
+  New(PT);
+  FillChar(PT^,SizeOf(TTreeElement),#0);
+  PT^.char:=ch;
+  PT^.Parent:=Pa;
+  if Assigned(Pa) and (Pa^.Child=nil) then
+    Pa^.Child:=PT;
+  NewPTree:=PT;
+end;
+
+function DoAddSequence(Const St : String; AChar,AScan :byte) : PTreeElement;
+var
+  CurPTree,NPT : PTreeElement;
+  c : byte;
+  i : longint;
+begin
+  if St='' then
+    begin
+      DoAddSequence:=nil;
+      exit;
+    end;
+  CurPTree:=RootTree[ord(st[1])];
+  if CurPTree=nil then
+    begin
+      CurPTree:=NewPTree(ord(st[1]),nil);
+      RootTree[ord(st[1])]:=CurPTree;
+    end;
+  for i:=2 to Length(St) do
+    begin
+      NPT:=CurPTree^.Child;
+      c:=ord(St[i]);
+      if NPT=nil then
+        NPT:=NewPTree(c,CurPTree);
+      CurPTree:=nil;
+      while assigned(NPT) and (NPT^.char<c) do
+        begin
+          CurPTree:=NPT;
+          NPT:=NPT^.Next;
+        end;
+
+      if assigned(NPT) and (NPT^.char=c) then
+        CurPTree:=NPT
+      else
+        begin
+          if CurPTree=nil then
+            begin
+              NPT^.Parent^.child:=NewPTree(c,NPT^.Parent);
+              CurPTree:=NPT^.Parent^.Child;
+              CurPTree^.Next:=NPT;
+            end
+          else
+            begin
+              CurPTree^.Next:=NewPTree(c,CurPTree^.Parent);
+              CurPTree:=CurPTree^.Next;
+              CurPTree^.Next:=NPT;
+            end;
+        end;
+    end;
+  if CurPTree^.CanBeTerminal then
+    begin
+      { here we have a conflict !! }
+      { maybe we should claim }
+      with CurPTree^ do
+        begin
+{$ifdef DEBUG}
+          if (ScanValue<>AScan) or (CharValue<>AChar) then
+            Writeln(system.stderr,'key "',st,'" changed value');
+          if (ScanValue<>AScan) then
+            Writeln(system.stderr,'Scan was ',ScanValue,' now ',AScan);
+          if (CharValue<>AChar) then
+            Writeln(system.stderr,'Char was ',chr(CharValue),' now ',chr(AChar));
+{$endif DEBUG}
+          ScanValue:=AScan;
+          CharValue:=AChar;
+        end;
+    end
+  else with CurPTree^ do
+    begin
+      CanBeTerminal:=True;
+      ScanValue:=AScan;
+      CharValue:=AChar;
+    end;
+  DoAddSequence:=CurPTree;
+end;
+
+
+procedure AddSequence(Const St : String; AChar,AScan :byte);
+begin
+  DoAddSequence(St,AChar,AScan);
+end;
+
+{ Returns the Child that as c as char if it exists }
+Function FindChild(c : byte;Root : PTreeElement) : PTreeElement;
+var
+  NPT : PTreeElement;
+begin
+  if not assigned(Root) then
+    begin
+      FindChild:=nil;
+      exit;
+    end;
+  NPT:=Root^.Child;
+  while assigned(NPT) and (NPT^.char<c) do
+    NPT:=NPT^.Next;
+  if assigned(NPT) and (NPT^.char=c) then
+    FindChild:=NPT
+  else
+    FindChild:=nil;
+end;
+
+Function AddSpecialSequence(Const St : string;Proc : TProcedure) : PTreeElement;
+var
+  NPT : PTreeElement;
+begin
+  NPT:=DoAddSequence(St,0,0);
+  NPT^.SpecialHandler:=Proc;
+  AddSpecialSequence:=NPT;
+end;
+
+function FindSequence(Const St : String;var AChar,AScan :byte) : boolean;
+var
+  NPT : PTreeElement;
+  I : longint;
+begin
+  FindSequence:=false;
+  AChar:=0;
+  AScan:=0;
+  if St='' then
+    exit;
+  NPT:=RootTree[ord(St[1])];
+  if not assigned(NPT) then
+    exit;
+  for i:=2 to Length(St) do
+    begin
+      NPT:=FindChild(ord(St[i]),NPT);
+      if not assigned(NPT) then
+        exit;
+    end;
+  if not NPT^.CanBeTerminal then
+    exit
+  else
+    begin
+      FindSequence:=true;
+      AScan:=NPT^.ScanValue;
+      AChar:=NPT^.CharValue;
+    end;
+end;
+
+Procedure LoadDefaultSequences;
+begin
+  AddSpecialSequence(#27'[M',@GenMouseEvent);
+  { linux default values }
+  if IsConsole then
+    begin
+      DoAddSequence(#127,8,0);
+    end
+  else
+    begin
+      DoAddSequence(#127,0,kbDel);
+    end;
+  { all Esc letter }
+  DoAddSequence(#27'A',0,kbAltA);
+  DoAddSequence(#27'a',0,kbAltA);
+  DoAddSequence(#27'B',0,kbAltB);
+  DoAddSequence(#27'b',0,kbAltB);
+  DoAddSequence(#27'C',0,kbAltC);
+  DoAddSequence(#27'c',0,kbAltC);
+  DoAddSequence(#27'D',0,kbAltD);
+  DoAddSequence(#27'd',0,kbAltD);
+  DoAddSequence(#27'E',0,kbAltE);
+  DoAddSequence(#27'e',0,kbAltE);
+  DoAddSequence(#27'F',0,kbAltF);
+  DoAddSequence(#27'f',0,kbAltF);
+  DoAddSequence(#27'G',0,kbAltG);
+  DoAddSequence(#27'g',0,kbAltG);
+  DoAddSequence(#27'H',0,kbAltH);
+  DoAddSequence(#27'h',0,kbAltH);
+  DoAddSequence(#27'I',0,kbAltI);
+  DoAddSequence(#27'i',0,kbAltI);
+  DoAddSequence(#27'J',0,kbAltJ);
+  DoAddSequence(#27'j',0,kbAltJ);
+  DoAddSequence(#27'K',0,kbAltK);
+  DoAddSequence(#27'k',0,kbAltK);
+  DoAddSequence(#27'L',0,kbAltL);
+  DoAddSequence(#27'l',0,kbAltL);
+  DoAddSequence(#27'M',0,kbAltM);
+  DoAddSequence(#27'm',0,kbAltM);
+  DoAddSequence(#27'N',0,kbAltN);
+  DoAddSequence(#27'n',0,kbAltN);
+  DoAddSequence(#27'O',0,kbAltO);
+  DoAddSequence(#27'o',0,kbAltO);
+  DoAddSequence(#27'P',0,kbAltP);
+  DoAddSequence(#27'p',0,kbAltP);
+  DoAddSequence(#27'Q',0,kbAltQ);
+  DoAddSequence(#27'q',0,kbAltQ);
+  DoAddSequence(#27'R',0,kbAltR);
+  DoAddSequence(#27'r',0,kbAltR);
+  DoAddSequence(#27'S',0,kbAltS);
+  DoAddSequence(#27's',0,kbAltS);
+  DoAddSequence(#27'T',0,kbAltT);
+  DoAddSequence(#27't',0,kbAltT);
+  DoAddSequence(#27'U',0,kbAltU);
+  DoAddSequence(#27'u',0,kbAltU);
+  DoAddSequence(#27'V',0,kbAltV);
+  DoAddSequence(#27'v',0,kbAltV);
+  DoAddSequence(#27'W',0,kbAltW);
+  DoAddSequence(#27'w',0,kbAltW);
+  DoAddSequence(#27'X',0,kbAltX);
+  DoAddSequence(#27'x',0,kbAltX);
+  DoAddSequence(#27'Y',0,kbAltY);
+  DoAddSequence(#27'y',0,kbAltY);
+  DoAddSequence(#27'Z',0,kbAltZ);
+  DoAddSequence(#27'z',0,kbAltZ);
+  DoAddSequence(#27'-',0,kbAltMinus);
+  DoAddSequence(#27'=',0,kbAltEqual);
+  DoAddSequence(#27'0',0,kbAlt0);
+  DoAddSequence(#27'1',0,kbAlt1);
+  DoAddSequence(#27'2',0,kbAlt2);
+  DoAddSequence(#27'3',0,kbAlt3);
+  DoAddSequence(#27'4',0,kbAlt4);
+  DoAddSequence(#27'5',0,kbAlt5);
+  DoAddSequence(#27'6',0,kbAlt6);
+  DoAddSequence(#27'7',0,kbAlt7);
+  DoAddSequence(#27'8',0,kbAlt8);
+  DoAddSequence(#27'9',0,kbAlt9);
+  { vt100 default values }
+  DoAddSequence(#27'[[A',0,kbF1);
+  DoAddSequence(#27'[[B',0,kbF2);
+  DoAddSequence(#27'[[C',0,kbF3);
+  DoAddSequence(#27'[[D',0,kbF4);
+  DoAddSequence(#27'[[E',0,kbF5);
+  DoAddSequence(#27'[17~',0,kbF6);
+  DoAddSequence(#27'[18~',0,kbF7);
+  DoAddSequence(#27'[19~',0,kbF8);
+  DoAddSequence(#27'[20~',0,kbF9);
+  DoAddSequence(#27'[21~',0,kbF10);
+  DoAddSequence(#27'[23~',0,kbF11);
+  DoAddSequence(#27'[24~',0,kbF12);
+  DoAddSequence(#27'[25~',0,kbShiftF3);
+  DoAddSequence(#27'[26~',0,kbShiftF4);
+  DoAddSequence(#27'[28~',0,kbShiftF5);
+  DoAddSequence(#27'[29~',0,kbShiftF6);
+  DoAddSequence(#27'[31~',0,kbShiftF7);
+  DoAddSequence(#27'[32~',0,kbShiftF8);
+  DoAddSequence(#27'[33~',0,kbShiftF9);
+  DoAddSequence(#27'[34~',0,kbShiftF10);
+  DoAddSequence(#27#27'[[A',0,kbAltF1);
+  DoAddSequence(#27#27'[[B',0,kbAltF2);
+  DoAddSequence(#27#27'[[C',0,kbAltF3);
+  DoAddSequence(#27#27'[[D',0,kbAltF4);
+  DoAddSequence(#27#27'[[E',0,kbAltF5);
+  DoAddSequence(#27#27'[17~',0,kbAltF6);
+  DoAddSequence(#27#27'[18~',0,kbAltF7);
+  DoAddSequence(#27#27'[19~',0,kbAltF8);
+  DoAddSequence(#27#27'[20~',0,kbAltF9);
+  DoAddSequence(#27#27'[21~',0,kbAltF10);
+  DoAddSequence(#27#27'[23~',0,kbAltF11);
+  DoAddSequence(#27#27'[24~',0,kbAltF12);
+  DoAddSequence(#27'[A',0,kbUp);
+  DoAddSequence(#27'[B',0,kbDown);
+  DoAddSequence(#27'[C',0,kbRight);
+  DoAddSequence(#27'[D',0,kbLeft);
+  DoAddSequence(#27'[F',0,kbEnd);
+  DoAddSequence(#27'[H',0,kbHome);
+  DoAddSequence(#27'[Z',0,kbShiftTab);
+  DoAddSequence(#27'[5~',0,kbPgUp);
+  DoAddSequence(#27'[6~',0,kbPgDn);
+  DoAddSequence(#27'[4~',0,kbEnd);
+  DoAddSequence(#27'[1~',0,kbHome);
+  DoAddSequence(#27'[2~',0,kbIns);
+  DoAddSequence(#27'[3~',0,kbDel);
+  DoAddSequence(#27#27'[A',0,kbAltUp);
+  DoAddSequence(#27#27'[B',0,kbAltDown);
+  DoAddSequence(#27#27'[D',0,kbAltLeft);
+  DoAddSequence(#27#27'[C',0,kbAltRight);
+  DoAddSequence(#27#27'[5~',0,kbAltPgUp);
+  DoAddSequence(#27#27'[6~',0,kbAltPgDn);
+  DoAddSequence(#27#27'[4~',0,kbAltEnd);
+  DoAddSequence(#27#27'[1~',0,kbAltHome);
+  DoAddSequence(#27#27'[2~',0,kbAltIns);
+  DoAddSequence(#27#27'[3~',0,kbAltDel);
+  DoAddSequence(#27'OP',0,kbF1);
+  DoAddSequence(#27'OQ',0,kbF2);
+  DoAddSequence(#27'OR',0,kbF3);
+  DoAddSequence(#27'OS',0,kbF4);
+  DoAddSequence(#27'Ot',0,kbF5);
+  DoAddSequence(#27'Ou',0,kbF6);
+  DoAddSequence(#27'Ov',0,kbF7);
+  DoAddSequence(#27'Ol',0,kbF8);
+  DoAddSequence(#27'Ow',0,kbF9);
+  DoAddSequence(#27'Ox',0,kbF10);
+  DoAddSequence(#27'Oy',0,kbF11);
+  DoAddSequence(#27'Oz',0,kbF12);
+  DoAddSequence(#27#27'OP',0,kbAltF1);
+  DoAddSequence(#27#27'OQ',0,kbAltF2);
+  DoAddSequence(#27#27'OR',0,kbAltF3);
+  DoAddSequence(#27#27'OS',0,kbAltF4);
+  DoAddSequence(#27#27'Ot',0,kbAltF5);
+  DoAddSequence(#27#27'Ou',0,kbAltF6);
+  DoAddSequence(#27#27'Ov',0,kbAltF7);
+  DoAddSequence(#27#27'Ol',0,kbAltF8);
+  DoAddSequence(#27#27'Ow',0,kbAltF9);
+  DoAddSequence(#27#27'Ox',0,kbAltF10);
+  DoAddSequence(#27#27'Oy',0,kbAltF11);
+  DoAddSequence(#27#27'Oz',0,kbAltF12);
+  DoAddSequence(#27'OA',0,kbUp);
+  DoAddSequence(#27'OB',0,kbDown);
+  DoAddSequence(#27'OC',0,kbRight);
+  DoAddSequence(#27'OD',0,kbLeft);
+  DoAddSequence(#27#27'OA',0,kbAltUp);
+  DoAddSequence(#27#27'OB',0,kbAltDown);
+  DoAddSequence(#27#27'OC',0,kbAltRight);
+  DoAddSequence(#27#27'OD',0,kbAltLeft);
+  { xterm default values }
+  { xterm alternate default values }
+  { ignored sequences }
+  DoAddSequence(#27'[?1;0c',0,0);
+  DoAddSequence(#27'[?1l',0,0);
+  DoAddSequence(#27'[?1h',0,0);
+  DoAddSequence(#27'[?1;2c',0,0);
+  DoAddSequence(#27'[?7l',0,0);
+  DoAddSequence(#27'[?7h',0,0);
+end;
+
+function EnterEscapeSeqNdx(Ndx: Word;Char,Scan : byte) : PTreeElement;
+var
+  P,pdelay: PChar;
+  St : string;
+begin
+  EnterEscapeSeqNdx:=nil;
+  P:=cur_term_Strings^[Ndx];
+  if assigned(p) then
+   begin { Do not record the delays }
+     pdelay:=strpos(p,'$<');
+     if assigned(pdelay) then
+       pdelay^:=#0;
+     St:=StrPas(p);
+     EnterEscapeSeqNdx:=DoAddSequence(St,Char,Scan);
+     if assigned(pdelay) then
+       pdelay^:='$';
+   end;
+end;
+
+
+Procedure LoadTermInfoSequences;
+var
+  err : longint;
+begin
+  if not assigned(cur_term) then
+    setupterm(nil, stdoutputhandle, err);
+  if not assigned(cur_term_Strings) then
+    exit;
+  EnterEscapeSeqNdx(key_f1,0,kbF1);
+  EnterEscapeSeqNdx(key_f2,0,kbF2);
+  EnterEscapeSeqNdx(key_f3,0,kbF3);
+  EnterEscapeSeqNdx(key_f4,0,kbF4);
+  EnterEscapeSeqNdx(key_f5,0,kbF5);
+  EnterEscapeSeqNdx(key_f6,0,kbF6);
+  EnterEscapeSeqNdx(key_f7,0,kbF7);
+  EnterEscapeSeqNdx(key_f8,0,kbF8);
+  EnterEscapeSeqNdx(key_f9,0,kbF9);
+  EnterEscapeSeqNdx(key_f10,0,kbF10);
+  EnterEscapeSeqNdx(key_f11,0,kbF11);
+  EnterEscapeSeqNdx(key_f12,0,kbF12);
+  EnterEscapeSeqNdx(key_up,0,kbUp);
+  EnterEscapeSeqNdx(key_down,0,kbDown);
+  EnterEscapeSeqNdx(key_left,0,kbLeft);
+  EnterEscapeSeqNdx(key_right,0,kbRight);
+  EnterEscapeSeqNdx(key_ppage,0,kbPgUp);
+  EnterEscapeSeqNdx(key_npage,0,kbPgDn);
+  EnterEscapeSeqNdx(key_end,0,kbEnd);
+  EnterEscapeSeqNdx(key_home,0,kbHome);
+  EnterEscapeSeqNdx(key_ic,0,kbIns);
+  EnterEscapeSeqNdx(key_dc,0,kbDel);
+  EnterEscapeSeqNdx(key_stab,0,kbShiftTab);
+  { EnterEscapeSeqNdx(key_,0,kb);
+  EnterEscapeSeqNdx(key_,0,kb); }
+end;
+
+{$endif not NotUseTree}
+
+Function RawReadKey:char;
+Var
+  fdsin    : fdSet;
+Begin
+{Check Buffer first}
+  if KeySend<>KeyPut then
+   begin
+     RawReadKey:=PopKey;
+     exit;
+   end;
+{Wait for Key}
+  if not sysKeyPressed then
+   begin
+     FD_Zero (fdsin);
+     FD_Set (StdInputHandle,fdsin);
+     Select (StdInputHandle+1,@fdsin,nil,nil,nil);
+   end;
+  RawReadKey:=ttyRecvChar;
+end;
+
+
+Function RawReadString : String;
+Var
+  ch : char;
+  fdsin : fdSet;
+  St : String;
+Begin
+  St:=RawReadKey;
+  FD_Zero (fdsin);
+  FD_Set (StdInputHandle,fdsin);
+  Repeat
+     if InCnt=0 then
+       Select(StdInputHandle+1,@fdsin,nil,nil,10);
+     if SysKeyPressed then
+       ch:=ttyRecvChar
+     else
+       ch:=#0;
+     if ch<>#0 then
+       St:=St+ch;
+  Until ch=#0;
+  RawReadString:=St;
+end;
+
+
+Function ReadKey(var IsAlt : boolean):char;
+Var
+  ch       : char;
+{$ifdef NotUseTree}
+  OldState : longint;
+  State    : longint;
+{$endif NotUseTree}
+  is_delay : boolean;
+  fdsin    : fdSet;
+  store    : array [0..8] of char;
+  arrayind : byte;
+{$ifndef NotUseTree}
+  NPT,NNPT : PTreeElement;
+{$else NotUseTree}
+  procedure GenMouseEvent;
+  var MouseEvent: TMouseEvent;
+  begin
+    Fillchar(MouseEvent,SizeOf(TMouseEvent),#0);
+    case ch of
+      #32 : {left button pressed }
+        MouseEvent.buttons:=1;
+      #33 : {middle button pressed }
+        MouseEvent.buttons:=2;
+      #34 : { right button pressed }
+        MouseEvent.buttons:=4;
+      #35 : { no button pressed };
+      end;
+     if InCnt=0 then
+       Select(StdInputHandle+1,@fdsin,nil,nil,10);
+     ch:=ttyRecvChar;
+     MouseEvent.x:=Ord(ch)-ord(' ')-1;
+     if InCnt=0 then
+      Select(StdInputHandle+1,@fdsin,nil,nil,10);
+     ch:=ttyRecvChar;
+     MouseEvent.y:=Ord(ch)-ord(' ')-1;
+     if (MouseEvent.buttons<>0) then
+       MouseEvent.action:=MouseActionDown
+     else
+       begin
+         if (LastMouseEvent.Buttons<>0) and
+            ((LastMouseEvent.X<>MouseEvent.X) or (LastMouseEvent.Y<>MouseEvent.Y)) then
+           begin
+             MouseEvent.Action:=MouseActionMove;
+             MouseEvent.Buttons:=LastMouseEvent.Buttons;
+             PutMouseEvent(MouseEvent);
+             MouseEvent.Buttons:=0;
+           end;
+         MouseEvent.Action:=MouseActionUp;
+       end;
+     PutMouseEvent(MouseEvent);
+     LastMouseEvent:=MouseEvent;
+  end;
+{$endif NotUseTree}
+
+    procedure RestoreArray;
+      var
+        i : byte;
+      begin
+        for i:=0 to arrayind-1 do
+          PushKey(store[i]);
+      end;
+
+Begin
+  IsAlt:=false;
+{Check Buffer first}
+  if KeySend<>KeyPut then
+   begin
+     ReadKey:=PopKey;
+     exit;
+   end;
+{Wait for Key}
+  if not sysKeyPressed then
+   begin
+     FD_Zero (fdsin);
+     FD_Set (StdInputHandle,fdsin);
+     Select (StdInputHandle+1,@fdsin,nil,nil,nil);
+   end;
+  ch:=ttyRecvChar;
+{$ifndef NotUseTree}
+  NPT:=RootTree[ord(ch)];
+  if not assigned(NPT) then
+    PushKey(ch)
+  else
+    begin
+     FD_Zero(fdsin);
+     fd_Set(StdInputHandle,fdsin);
+     store[0]:=ch;
+     arrayind:=1;
+      while assigned(NPT) and syskeypressed do
+        begin
+          if (InCnt=0) then
+            Select(StdInputHandle+1,@fdsin,nil,nil,10);
+          ch:=ttyRecvChar;
+          NNPT:=FindChild(ord(ch),NPT);
+          if assigned(NNPT) then
+            Begin
+              NPT:=NNPT;
+              if NPT^.CanBeTerminal and
+                 assigned(NPT^.SpecialHandler) then
+                break;
+            End;
+          if ch<>#0 then
+            begin
+              store[arrayind]:=ch;
+              inc(arrayind);
+            end;
+        end;
+      if assigned(NPT) and NPT^.CanBeTerminal then
+        begin
+          if assigned(NPT^.SpecialHandler) then
+            begin
+              NPT^.SpecialHandler;
+              ch:=#0;
+            end
+          else if NPT^.CharValue<>0 then
+            PushKey(chr(NPT^.CharValue))
+          else if NPT^.ScanValue<>0 then
+            PushExt(NPT^.ScanValue);
+        end
+      else
+        RestoreArray;
+{$else NotUseTree}
+{Esc Found ?}
+  If (ch=#27) then
+   begin
+     FD_Zero(fdsin);
+     fd_Set(StdInputHandle,fdsin);
+     State:=1;
+     store[0]:=#27;
+     arrayind:=1;
+{$ifdef logging}
+     write(f,'Esc');
+{$endif logging}
+     if InCnt=0 then
+      Select(StdInputHandle+1,@fdsin,nil,nil,10);
+     while (State<>0) and (sysKeyPressed) do
+      begin
+        ch:=ttyRecvChar;
+        store[arrayind]:=ch;
+        inc(arrayind);
+{$ifdef logging}
+        if ord(ch)>31 then
+          write(f,ch)
+        else
+          write(f,'#',ord(ch):2);
+{$endif logging}
+        OldState:=State;
+        State:=0;
+        case OldState of
+        1 : begin {Esc}
+              case ch of
+          'a'..'z',
+          '0'..'9',
+           '-','=' : PushExt(FAltKey(ch));
+          'A'..'N',
+          'P'..'Z' : PushExt(FAltKey(chr(ord(ch)+ord('a')-ord('A'))));
+               #10 : PushKey(#10);
+               #13 : PushKey(#10);
+               #27 : begin
+                       IsAlt:=True;
+                       State:=1;
+                     end;
+              #127 : PushExt(kbAltDel);
+               '[' : State:=2;
+               'O' : State:=6;
+               else
+                 RestoreArray;
+               end;
+            end;
+        2 : begin {Esc[}
+              case ch of
+               '[' : State:=3;
+               'A' : PushExt(kbUp);
+               'B' : PushExt(kbDown);
+               'C' : PushExt(kbRight);
+               'D' : PushExt(kbLeft);
+               'F' : PushExt(kbEnd);
+               'G' : PushKey('5');
+               'H' : PushExt(kbHome);
+               'K' : PushExt(kbEnd);
+               'M' : State:=13;
+               '1' : State:=4;
+               '2' : State:=5;
+               '3' : State:=12;{PushExt(kbDel)}
+               '4' : PushExt(kbEnd);
+               '5' : PushExt(73);
+               '6' : PushExt(kbPgDn);
+               '?' : State:=7;
+              else
+                RestoreArray;
+              end;
+              if ch in ['4'..'6'] then
+               State:=255;
+            end;
+        3 : begin {Esc[[}
+              case ch of
+               'A' : PushExt(kbF1);
+               'B' : PushExt(kbF2);
+               'C' : PushExt(kbF3);
+               'D' : PushExt(kbF4);
+               'E' : PushExt(kbF5);
+              else
+                RestoreArray;
+              end;
+            end;
+        4 : begin {Esc[1}
+              case ch of
+               '~' : PushExt(kbHome);
+               '7' : PushExt(kbF6);
+               '8' : PushExt(kbF7);
+               '9' : PushExt(kbF8);
+              else
+                RestoreArray;
+              end;
+              if (Ch<>'~') then
+               State:=255;
+            end;
+        5 : begin {Esc[2}
+              case ch of
+               '~' : PushExt(kbIns);
+               '0' : pushExt(kbF9);
+               '1' : PushExt(kbF10);
+               '3' : PushExt($85){F11, but ShiftF1 also !!};
+               '4' : PushExt($86){F12, but Shift F2 also !!};
+               '5' : PushExt($56){ShiftF3};
+               '6' : PushExt($57){ShiftF4};
+               '8' : PushExt($58){ShiftF5};
+               '9' : PushExt($59){ShiftF6};
+              else
+                RestoreArray;
+              end;
+              if (Ch<>'~') then
+               State:=255;
+            end;
+        12 : begin {Esc[3}
+              case ch of
+               '~' : PushExt(kbDel);
+               '1' : PushExt($5A){ShiftF7};
+               '2' : PushExt($5B){ShiftF8};
+               '3' : PushExt($5C){ShiftF9};
+               '4' : PushExt($5D){ShiftF10};
+              else
+                RestoreArray;
+              end;
+              if (Ch<>'~') then
+               State:=255;
+            end;
+        6 : begin {EscO Function keys in vt100 mode PM }
+              case ch of
+               'P' : {F1}PushExt(kbF1);
+               'Q' : {F2}PushExt(kbF2);
+               'R' : {F3}PushExt(kbF3);
+               'S' : {F4}PushExt(kbF4);
+               't' : {F5}PushExt(kbF5);
+               'u' : {F6}PushExt(kbF6);
+               'v' : {F7}PushExt(kbF7);
+               'l' : {F8}PushExt(kbF8);
+               'w' : {F9}PushExt(kbF9);
+               'x' : {F10}PushExt(kbF10);
+               'D' : {keyLeft}PushExt($4B);
+               'C' : {keyRight}PushExt($4D);
+               'A' : {keyUp}PushExt($48);
+               'B' : {keyDown}PushExt($50);
+              else
+                RestoreArray;
+              end;
+            end;
+        7 : begin {Esc[? keys in vt100 mode PM }
+              case ch of
+               '0' : State:=11;
+               '1' : State:=8;
+               '7' : State:=9;
+              else
+                RestoreArray;
+              end;
+            end;
+        8 : begin {Esc[?1 keys in vt100 mode PM }
+              case ch of
+               'l' : {local mode};
+               'h' : {transmit mode};
+               ';' : { 'Esc[1;0c seems to be sent by M$ telnet app
+                       for no hangup purposes }
+                     state:=10;
+              else
+                RestoreArray;
+              end;
+            end;
+        9 : begin {Esc[?7 keys in vt100 mode PM }
+              case ch of
+               'l' : {exit_am_mode};
+               'h' : {enter_am_mode};
+              else
+                RestoreArray;
+              end;
+            end;
+        10 : begin {Esc[?1; keys in vt100 mode PM }
+              case ch of
+               '0' : state:=11;
+              else
+                RestoreArray;
+              end;
+             end;
+        11 : begin {Esc[?1;0 keys in vt100 mode PM }
+              case ch of
+               'c' : ;
+              else
+                RestoreArray;
+              end;
+             end;
+        13 : begin {Esc[M mouse prefix for xterm }
+               GenMouseEvent;
+             end;
+      255 : { just forget this trailing char };
+        end;
+        if (State<>0) and (InCnt=0) then
+         Select(StdInputHandle+1,@fdsin,nil,nil,10);
+      end;
+     if State=1 then
+      PushKey(ch);
+{$endif NotUseTree}
+     if ch='$' then
+       begin { '$<XX>' means a delay of XX millisecs }
+         is_delay :=false;
+         Select(StdInputHandle+1,@fdsin,nil,nil,10);
+         if (sysKeyPressed) then
+           begin
+             ch:=ttyRecvChar;
+             is_delay:=(ch='<');
+             if not is_delay then
+               begin
+                 PushKey('$');
+                 PushKey(ch);
+               end
+             else
+               begin
+{$ifdef logging}
+                 write(f,'$<');
+{$endif logging}
+                 Select(StdInputHandle+1,@fdsin,nil,nil,10);
+                 while (sysKeyPressed) and (ch<>'>') do
+                   begin
+                     { Should we really repect this delay ?? }
+                     ch:=ttyRecvChar;
+{$ifdef logging}
+                     write(f,ch);
+{$endif logging}
+                     Select(StdInputHandle+1,@fdsin,nil,nil,10);
+                   end;
+               end;
+           end
+         else
+           PushKey('$');
+       end;
+   end
+{$ifdef logging}
+       writeln(f);
+{$endif logging}
+{$ifndef NotUseTree}
+    ;
+  ReadKey:=PopKey;
+{$else  NotUseTree}
+  else
+   Begin
+     case ch of
+     #127 : PushKey(#8);
+     else
+      PushKey(ch);
+     end;
+   End;
+  ReadKey:=PopKey;
+{$endif NotUseTree}
+End;
+
+
+function ShiftState:byte;
+var
+  arg,shift : longint;
+begin
+  arg:=6;
+  shift:=0;
+  {$Ifndef BSD}
+  if IOCtl(StdInputHandle,TIOCLINUX,@arg) then
+   begin
+     if (arg and (2 or 8))<>0 then
+      inc(shift,8);
+     if (arg and 4)<>0 then
+      inc(shift,4);
+     if (arg and 1)<>0 then
+      inc(shift,3);
+   end;
+ {$endif}
+  ShiftState:=shift;
+end;
+
+
+{ Exported functions }
+
+procedure InitKeyboard;
+begin
+  SetRawMode(true);
+  patchkeyboard;
+{$ifdef logging}
+     assign(f,'keyboard.log');
+     rewrite(f);
+{$endif logging}
+  if not IsConsole then
+    begin
+      { default for Shift prefix is ^ A}
+      if ShiftPrefix = 0 then
+        ShiftPrefix:=1;
+      {default for Alt prefix is ^Z }
+      if AltPrefix=0 then
+        AltPrefix:=26;
+      { default for Ctrl Prefix is ^W }
+      if CtrlPrefix=0 then
+        CtrlPrefix:=23;
+    end;
+{$ifndef NotUseTree}
+  LoadDefaultSequences;
+  LoadTerminfoSequences;
+{$endif not NotUseTree}
+end;
+
+
+procedure DoneKeyboard;
+begin
+  unpatchkeyboard;
+  SetRawMode(false);
+{$ifdef logging}
+  close(f);
+{$endif logging}
+end;
+
+
+function GetKeyEvent: TKeyEvent;
+
+  function EvalScan(b:byte):byte;
+  const
+    DScan:array[0..31] of byte = (
+      $39, $02, $28, $04, $05, $06, $08, $28,
+      $0A, $0B, $09, $0D, $33, $0C, $34, $35,
+      $0B, $02, $03, $04, $05, $06, $07, $08,
+      $09, $0A, $27, $27, $33, $0D, $34, $35);
+   LScan:array[0..31] of byte = (
+      $29, $1E, $30, $2E, $20, $12, $21, $22,
+      $23, $17, $24, $25, $26, $32, $31, $18,
+      $19, $10, $13, $1F, $14, $16, $2F, $11,
+      $2D, $15, $2C, $1A, $2B, $1B, $29, $0C);
+  begin
+    if (b and $E0)=$20  { digits / leters } then
+     EvalScan:=DScan[b and $1F]
+    else
+     case b of
+      $08:EvalScan:=$0E; { backspace }
+      $09:EvalScan:=$0F; { TAB }
+      $0D:EvalScan:=$1C; { CR }
+      $1B:EvalScan:=$01; { esc }
+      $40:EvalScan:=$03; { @ }
+      $5E:EvalScan:=$07; { ^ }
+      $60:EvalScan:=$29; { ` }
+     else
+      EvalScan:=LScan[b and $1F];
+     end;
+  end;
+
+  function EvalScanZ(b:byte):byte;
+  begin
+    EvalScanZ:=b;
+    if b in [$3B..$44] { F1..F10 -> Alt-F1..Alt-F10} then
+     EvalScanZ:=b+$2D;
+  end;
+const
+   {kbHome, kbUp, kbPgUp,Missing, kbLeft,
+    kbCenter, kbRight, kbAltGrayPlus, kbend,
+    kbDown, kbPgDn, kbIns, kbDel }
+  CtrlArrow : array [kbHome..kbDel] of byte =
+   {($77,$8d,$84,$8e,$73,$8f,$74,$90,$75,$91,$76);}
+   (kbCtrlHome,kbCtrlUp,kbCtrlPgUp,kbNoKey,kbCtrlLeft,
+    kbCtrlCenter,kbCtrlRight,kbAltGrayPlus,kbCtrlEnd,
+    kbCtrlDown,kbCtrlPgDn,kbCtrlIns,kbCtrlDel);
+  AltArrow : array [kbHome..kbDel] of byte =
+   (kbAltHome,kbAltUp,kbAltPgUp,kbNoKey,kbAltLeft,
+    kbCenter,kbAltRight,kbAltGrayPlus,kbAltEnd,
+    kbAltDown,kbAltPgDn,kbAltIns,kbAltDel);
+var
+  MyScan,
+  SState : byte;
+  MyChar : char;
+  EscUsed,AltPrefixUsed,CtrlPrefixUsed,ShiftPrefixUsed,IsAlt,Again : boolean;
+begin {main}
+  if PendingKeyEvent<>0 then
+   begin
+     GetKeyEvent:=PendingKeyEvent;
+     PendingKeyEvent:=0;
+     exit;
+   end;
+
+  MyChar:=Readkey(IsAlt);
+  MyScan:=ord(MyChar);
+  SState:=ShiftState;
+  CtrlPrefixUsed:=false;
+  AltPrefixUsed:=false;
+  ShiftPrefixUsed:=false;
+  EscUsed:=false;
+  if IsAlt then
+    SState:=SState or kbAlt;
+  repeat
+    again:=false;
+    if Mychar=#0 then
+      begin
+        MyScan:=ord(ReadKey(IsAlt));
+        { Handle Ctrl-<x> }
+        if (SState and kbCtrl)<>0 then
+         begin
+           case MyScan of
+             kbHome..kbDel : { cArrow }
+               MyScan:=CtrlArrow[MyScan];
+             kbF1..KbF10 : { cF1-cF10 }
+               MyScan:=MyScan+kbCtrlF1-kbF1;
+             kbF11..KbF12 : { cF11-cF12 }
+               MyScan:=MyScan+kbCtrlF11-kbF11;
+           end;
+         end
+        { Handle Alt-<x> }
+        else if (SState and kbAlt)<>0 then
+         begin
+           case MyScan of
+             kbHome..kbDel : { AltArrow }
+               MyScan:=AltArrow[MyScan];
+             kbF1..KbF10 : { aF1-aF10 }
+               MyScan:=MyScan+kbAltF1-kbF1;
+             kbF11..KbF12 : { aF11-aF12 }
+               MyScan:=MyScan+kbAltF11-kbF11;
+             end;
+         end
+        else if (SState and kbShift)<>0 then
+         begin
+           case MyScan of
+             kbIns: MyScan:=kbShiftIns;
+             kbDel: MyScan:=kbShiftDel;
+             kbF1..KbF10 : { sF1-sF10 }
+               MyScan:=MyScan+kbShiftF1-kbF1;
+             kbF11..KbF12 : { sF11-sF12 }
+               MyScan:=MyScan+kbShiftF11-kbF11;
+             end;
+         end;
+        GetKeyEvent:=$3000000 or ord(MyChar) or (MyScan shl 8) or (SState shl 16);
+        exit;
+      end
+    else if MyChar=#27 then
+      begin
+        if EscUsed then
+          SState:=SState and not kbAlt
+        else
+          begin
+            SState:=SState or kbAlt;
+            Again:=true;
+            EscUsed:=true;
+          end;
+      end
+    else if (AltPrefix<>0) and (MyChar=chr(AltPrefix)) then
+      begin { ^Z - replace Alt for Linux OS }
+        if AltPrefixUsed then
+          begin
+            SState:=SState and not kbAlt;
+          end
+        else
+          begin
+            AltPrefixUsed:=true;
+            SState:=SState or kbAlt;
+            Again:=true;
+          end;
+      end
+    else if (CtrlPrefix<>0) and (MyChar=chr(CtrlPrefix)) then
+      begin
+        if CtrlPrefixUsed then
+          SState:=SState and not kbCtrl
+        else
+          begin
+            CtrlPrefixUsed:=true;
+            SState:=SState or kbCtrl;
+            Again:=true;
+          end;
+      end
+    else if (ShiftPrefix<>0) and (MyChar=chr(ShiftPrefix)) then
+      begin
+        if ShiftPrefixUsed then
+          SState:=SState and not kbShift
+        else
+          begin
+            ShiftPrefixUsed:=true;
+            SState:=SState or kbShift;
+            Again:=true;
+          end;
+      end;
+    if not again then
+      begin
+        MyScan:=EvalScan(ord(MyChar));
+        if (SState and kbAlt)<>0 then
+          begin
+            if MyScan in [$02..$0D] then
+              inc(MyScan,$76);
+            MyChar:=chr(0);
+          end
+        else if (SState and kbShift)<>0 then
+          if MyChar=#9 then
+            begin
+              MyChar:=#0;
+              MyScan:=kbShiftTab;
+            end;
+      end
+    else
+      begin
+        MyChar:=Readkey(IsAlt);
+        MyScan:=ord(MyChar);
+        if IsAlt then
+          SState:=SState or kbAlt;
+      end;
+    until not Again;
+  GetKeyEvent:=$3000000 or ord(MyChar) or (MyScan shl 8) or (SState shl 16);
+end;
+
+
+function PollKeyEvent: TKeyEvent;
+begin
+  if PendingKeyEvent<>0 then
+   exit(PendingKeyEvent);
+  if keypressed then
+   begin
+     { just get the key and place it in the pendingkeyevent }
+     PendingKeyEvent:=GetKeyEvent;
+     PollKeyEvent:=PendingKeyEvent;
+   end
+  else
+   PollKeyEvent:=0;
+end;
+
+
+function PollShiftStateEvent: TKeyEvent;
+begin
+  PollShiftStateEvent:=ShiftState shl 16;
+end;
+
+
+{ Function key translation }
+type
+  TTranslationEntry = packed record
+    Min, Max: Byte;
+    Offset: Word;
+  end;
+const
+  TranslationTableEntries = 12;
+  TranslationTable: array [1..TranslationTableEntries] of TTranslationEntry =
+    ((Min: $3B; Max: $44; Offset: kbdF1),   { function keys F1-F10 }
+     (Min: $54; Max: $5D; Offset: kbdF1),   { Shift fn keys F1-F10 }
+     (Min: $5E; Max: $67; Offset: kbdF1),   { Ctrl fn keys F1-F10 }
+     (Min: $68; Max: $71; Offset: kbdF1),   { Alt fn keys F1-F10 }
+     (Min: $85; Max: $86; Offset: kbdF11),  { function keys F11-F12 }
+     (Min: $87; Max: $88; Offset: kbdF11),  { Shift+function keys F11-F12 }
+     (Min: $89; Max: $8A; Offset: kbdF11),  { Ctrl+function keys F11-F12 }
+     (Min: $8B; Max: $8C; Offset: kbdF11),  { Alt+function keys F11-F12 }
+     (Min: $47; Max: $49; Offset: kbdHome), { Keypad keys kbdHome-kbdPgUp }
+     (Min: $4B; Max: $4D; Offset: kbdLeft), { Keypad keys kbdLeft-kbdRight }
+     (Min: $4F; Max: $51; Offset: kbdEnd),  { Keypad keys kbdEnd-kbdPgDn }
+     (Min: $52; Max: $53; Offset: kbdInsert));
+
+function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
+var
+  I: Integer;
+  ScanCode: Byte;
+begin
+  if KeyEvent and $03000000 = $03000000 then
+   begin
+     if KeyEvent and $000000FF <> 0 then
+      begin
+        TranslateKeyEvent := KeyEvent and $00FFFFFF;
+        exit;
+      end
+     else
+      begin
+        { This is a function key }
+        ScanCode := (KeyEvent and $0000FF00) shr 8;
+        for I := 1 to TranslationTableEntries do
+         begin
+           if (TranslationTable[I].Min <= ScanCode) and (ScanCode <= TranslationTable[I].Max) then
+            begin
+              TranslateKeyEvent := $02000000 + (KeyEvent and $00FF0000) +
+                (ScanCode - TranslationTable[I].Min) + TranslationTable[I].Offset;
+              exit;
+            end;
+         end;
+      end;
+   end;
+  TranslateKeyEvent := KeyEvent;
+end;
+
+
+function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+  TranslateKeyEventUniCode := KeyEvent;
+  ErrorCode:=errKbdNotImplemented;
+end;
+
+
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:58  peter
+    * API 2 RTL commit
+
+}

rtl/unix/mouse.pp

@@ -0,0 +1,396 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Mouse unit for linux
+
+    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.
+
+ **********************************************************************}
+unit Mouse;
+interface
+
+{$ifdef NOMOUSE}
+{$DEFINE NOGPM}
+{$ENDIF}
+
+const
+  MouseEventBufSize = 16;
+
+{$i mouseh.inc}
+
+implementation
+
+uses
+  Linux,Video
+{$ifndef NOMOUSE}
+  ,gpm
+{$endif ndef NOMOUSE}
+  ;
+
+const
+  mousecur    : boolean = false;
+  mousecurofs : longint = -1;
+
+var
+  mousecurcell : TVideoCell;
+
+
+const
+  gpm_fs : longint = -1;
+
+
+procedure PlaceMouseCur(ofs:longint);
+{$ifndef NOMOUSE}
+var
+  upd : boolean;
+{$endif ndef NOMOUSE}
+begin
+{$ifndef NOMOUSE}
+  if VideoBuf=nil then
+   exit;
+  upd:=false;
+  if (MouseCurOfs<>-1) and (VideoBuf^[MouseCurOfs]=MouseCurCell) then
+   begin
+     VideoBuf^[MouseCurOfs]:=MouseCurCell xor $7f00;
+     upd:=true;
+   end;
+  MouseCurOfs:=ofs;
+  if (MouseCurOfs<>-1) then
+   begin
+     MouseCurCell:=VideoBuf^[MouseCurOfs] xor $7f00;
+     VideoBuf^[MouseCurOfs]:=MouseCurCell;
+     upd:=true;
+   end;
+  if upd then
+   Updatescreen(false);
+{$endif ndef NOMOUSE}
+end;
+
+
+procedure InitMouse;
+{$ifndef NOGPM}
+var
+  connect : TGPMConnect;
+{$endif ndef NOGPM}
+begin
+{$ifndef NOMOUSE}
+{$ifndef NOGPM}
+  PendingMouseHead:=@PendingMouseEvent;
+  PendingMouseTail:=@PendingMouseEvent;
+  PendingMouseEvents:=0;
+  FillChar(LastMouseEvent,sizeof(TMouseEvent),0);
+  if gpm_fs=-1 then
+    begin
+    { open gpm }
+      connect.EventMask:=GPM_MOVE or GPM_DRAG or GPM_DOWN or GPM_UP;
+      connect.DefaultMask:=0;
+      connect.MinMod:=0;
+      connect.MaxMod:=0;
+      gpm_fs:=Gpm_Open(connect,0);
+      if (gpm_fs=-2) and (getenv('TERM')<>'xterm') then
+        begin
+          gpm_fs:=-1;
+          Gpm_Close;
+        end;
+    end;
+  { show mousepointer }
+  if gpm_fs<>-1 then
+    ShowMouse;
+{$else ifdef NOGPM}
+      if (getenv('TERM')='xterm') then
+        begin
+          gpm_fs:=-2;
+          Write(#27'[?1001s'); { save old hilit tracking }
+          Write(#27'[?1000h'); { enable mouse tracking }
+        end;
+{$endif NOGPM}
+{$endif ndef NOMOUSE}
+end;
+
+
+procedure DoneMouse;
+begin
+{$ifndef NOMOUSE}
+  If gpm_fs<>-1 then
+    begin
+      HideMouse;
+{$ifndef NOGPM}
+      Gpm_Close;
+{$else ifdef NOGPM}
+      Write(#27'[?1000l'); { disable mouse tracking }
+      Write(#27'[?1001r'); { Restore old hilit tracking }
+{$endif ifdef NOGPM}
+      gpm_fs:=-1;
+    end;
+{$endif ndef NOMOUSE}
+end;
+
+
+function DetectMouse:byte;
+{$ifndef NOGPM}
+var
+  x : longint;
+  e : TGPMEvent;
+  connect : TGPMConnect;
+{$endif ndef NOGPM}
+begin
+{$ifdef NOMOUSE}
+  DetectMouse:=0;
+{$else ndef NOMOUSE}
+{$ifndef NOGPM}
+  if gpm_fs=-1 then
+    begin
+      connect.EventMask:=GPM_MOVE or GPM_DRAG or GPM_DOWN or GPM_UP;
+      connect.DefaultMask:=0;
+      connect.MinMod:=0;
+      connect.MaxMod:=0;
+      gpm_fs:=Gpm_Open(connect,0);
+      if (gpm_fs=-2) and (getenv('TERM')<>'xterm') then
+        begin
+          Gpm_Close;
+          gpm_fs:=-1;
+        end;
+    end;
+{ always a mouse deamon present }
+  if gpm_fs<>-1 then
+    begin
+      x:=Gpm_GetSnapshot(e);
+      if x<>-1 then
+        DetectMouse:=x
+      else
+        DetectMouse:=2;
+    end
+  else
+    DetectMouse:=0;
+{$else ifdef NOGPM}
+  if (getenv('TERM')='xterm') then
+    DetectMouse:=2;
+{$endif NOGPM}
+{$endif ndef NOMOUSE}
+end;
+
+
+procedure ShowMouse;
+begin
+  PlaceMouseCur(MouseCurOfs);
+  mousecur:=true;
+end;
+
+
+procedure HideMouse;
+begin
+  PlaceMouseCur(-1);
+  mousecur:=false;
+end;
+
+
+function GetMouseX:word;
+{$ifndef NOGPM}
+var
+  e : TGPMEvent;
+{$endif ndef NOGPM}
+begin
+{$ifdef NOMOUSE}
+  GetMouseX:=0;
+{$else ndef NOMOUSE}
+  if gpm_fs<0 then
+   exit(0);
+{$ifndef NOGPM}
+  Gpm_GetSnapshot(e);
+  GetMouseX:=e.x-1;
+{$endif ndef NOGPM}
+{$endif ndef NOMOUSE}
+end;
+
+
+function GetMouseY:word;
+{$ifndef NOGPM}
+var
+  e : TGPMEvent;
+{$endif ndef NOGPM}
+begin
+{$ifdef NOMOUSE}
+  GetMouseY:=0;
+{$else ndef NOMOUSE}
+  if gpm_fs<0 then
+   exit(0);
+{$ifndef NOGPM}
+  Gpm_GetSnapshot(e);
+  GetMouseY:=e.y-1;
+{$endif ndef NOGPM}
+{$endif ndef NOMOUSE}
+end;
+
+
+function GetMouseButtons:word;
+{$ifndef NOGPM}
+var
+  e : TGPMEvent;
+{$endif ndef NOGPM}
+begin
+{$ifdef NOMOUSE}
+  GetMouseButtons:=0;
+{$else ndef NOMOUSE}
+  if gpm_fs<0 then
+   exit(0);
+{$ifndef NOGPM}
+  Gpm_GetSnapshot(e);
+  GetMouseButtons:=e.buttons;
+{$endif ndef NOGPM}
+{$endif ndef NOMOUSE}
+end;
+
+
+procedure SetMouseXY(x,y:word);
+begin
+end;
+
+
+procedure GetMouseEvent(var MouseEvent: TMouseEvent);
+{$ifndef NOGPM}
+var
+  e : TGPMEvent;
+{$endif ndef NOGPM}
+begin
+{$ifdef NOMOUSE}
+  fillchar(MouseEvent,SizeOf(TMouseEvent),#0);
+{$else ndef NOMOUSE}
+  fillchar(MouseEvent,SizeOf(TMouseEvent),#0);
+  if PendingMouseEvents>0 then
+    begin
+      MouseEvent:=PendingMouseHead^;
+      inc(PendingMouseHead);
+      if longint(PendingMouseHead)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+       PendingMouseHead:=@PendingMouseEvent;
+      dec(PendingMouseEvents);
+      if (LastMouseEvent.x<>MouseEvent.x) or (LastMouseEvent.y<>MouseEvent.y) then
+       MouseEvent.Action:=MouseActionMove;
+      if (LastMouseEvent.Buttons<>MouseEvent.Buttons) then
+       begin
+         if (LastMouseEvent.Buttons=0) then
+          MouseEvent.Action:=MouseActionDown
+         else
+          MouseEvent.Action:=MouseActionUp;
+       end;
+      LastMouseEvent:=MouseEvent;
+      exit;
+    end;
+  if gpm_fs<0 then
+   exit;
+{$ifndef NOGPM}
+  Gpm_GetEvent(e);
+  MouseEvent.x:=e.x-1;
+  MouseEvent.y:=e.y-1;
+  MouseEvent.buttons:=0;
+  if e.buttons and Gpm_b_left<>0 then
+   inc(MouseEvent.buttons,1);
+  if e.buttons and Gpm_b_right<>0 then
+   inc(MouseEvent.buttons,2);
+  if e.buttons and Gpm_b_middle<>0 then
+   inc(MouseEvent.buttons,4);
+  case (e.EventType and $f) of
+    GPM_MOVE,
+    GPM_DRAG : MouseEvent.Action:=MouseActionMove;
+    GPM_DOWN : MouseEvent.Action:=MouseActionDown;
+    GPM_UP   : MouseEvent.Action:=MouseActionUp;
+  else
+   MouseEvent.Action:=0;
+  end;
+  LastMouseEvent:=MouseEvent;
+{ update mouse cursor }
+  if mousecur then
+   PlaceMouseCur(MouseEvent.y*ScreenWidth+MouseEvent.x);
+{$endif ndef NOGPM}
+{$endif ndef NOMOUSE}
+end;
+
+
+procedure PutMouseEvent(const MouseEvent: TMouseEvent);
+begin
+{$ifndef NOMOUSE}
+  if PendingMouseEvents<MouseEventBufSize then
+   begin
+     PendingMouseTail^:=MouseEvent;
+     inc(PendingMouseTail);
+     if longint(PendingMouseTail)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+      PendingMouseTail:=@PendingMouseEvent;
+      { why isn't this done here ?
+        so the win32 version do this by hand:}
+       inc(PendingMouseEvents);
+   end;
+{$endif ndef NOMOUSE}
+end;
+
+
+function PollMouseEvent(var MouseEvent: TMouseEvent):boolean;
+{$ifndef NOGPM}
+var
+  e : TGPMEvent;
+  fds : FDSet;
+{$endif ndef NOGPM}
+begin
+{$ifdef NOMOUSE}
+  fillchar(MouseEvent,SizeOf(TMouseEvent),#0);
+  exit(false);
+{$else ndef NOMOUSE}
+  fillchar(MouseEvent,SizeOf(TMouseEvent),#0);
+  if PendingMouseEvents>0 then
+   begin
+     MouseEvent:=PendingMouseHead^;
+     PollMouseEvent:=true;
+     exit;
+   end
+  else if gpm_fs<0 then
+   exit(false);
+{$ifndef NOGPM}
+  if gpm_fs>0 then
+    begin
+      FD_Zero(fds);
+      FD_Set(gpm_fd,fds);
+    end;
+  if (gpm_fs=-2) or (Select(gpm_fs+1,@fds,nil,nil,1)>0) then
+   begin
+     Gpm_GetSnapshot(e);
+     MouseEvent.x:=e.x-1;
+     MouseEvent.y:=e.y-1;
+     MouseEvent.buttons:=0;
+     if e.buttons and Gpm_b_left<>0 then
+      inc(MouseEvent.buttons,1);
+     if e.buttons and Gpm_b_right<>0 then
+      inc(MouseEvent.buttons,2);
+     if e.buttons and Gpm_b_middle<>0 then
+      inc(MouseEvent.buttons,4);
+     case (e.EventType and $f) of
+      GPM_MOVE,
+      GPM_DRAG : MouseEvent.Action:=MouseActionMove;
+      GPM_DOWN : MouseEvent.Action:=MouseActionDown;
+      GPM_UP   : MouseEvent.Action:=MouseActionUp;
+     else
+      MouseEvent.Action:=0;
+     end;
+     if (gpm_fs<>-2) or (MouseEvent.Action<>0) then
+       PollMouseEvent:=true
+     else
+       PollMouseEvent:=false;
+   end
+  else
+   PollMouseEvent:=false;
+{$endif ndef NOGPM}
+{$endif ndef NOMOUSE}
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:58  peter
+    * API 2 RTL commit
+
+}

rtl/unix/terminfo.pp

@@ -0,0 +1,747 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    TermInfo interface unit for linux
+
+    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.
+
+ **********************************************************************}
+unit TermInfo;
+
+interface
+
+{$linklib ncurses}
+{$linklib c}
+{$packrecords c}
+
+const
+  { boolean values }
+  auto_left_margin              = 0;
+  auto_right_margin             = 1;
+  no_esc_ctlc                   = 2;
+  ceol_standout_glitch          = 3;
+  eat_newline_glitch            = 4;
+  erase_overstrike              = 5;
+  generic_type                  = 6;
+  hard_copy                     = 7;
+  has_meta_key                  = 8;
+  has_status_line               = 9;
+  insert_null_glitch            = 10;
+  memory_above                  = 11;
+  memory_below                  = 12;
+  move_insert_mode              = 13;
+  move_standout_mode            = 14;
+  over_strike                   = 15;
+  status_line_esc_ok            = 16;
+  dest_tabs_magic_smso          = 17;
+  tilde_glitch                  = 18;
+  transparent_underline         = 19;
+  xon_xoff                      = 20;
+  needs_xon_xoff                = 21;
+  prtr_silent                   = 22;
+  hard_cursor                   = 23;
+  non_rev_rmcup                 = 24;
+  no_pad_char                   = 25;
+  non_dest_scroll_region        = 26;
+  can_change                    = 27;
+  back_color_erase              = 28;
+  hue_lightness_saturation      = 29;
+  col_addr_glitch               = 30;
+  cr_cancels_micro_mode         = 31;
+  has_print_wheel               = 32;
+  row_addr_glitch               = 33;
+  semi_auto_right_margin        = 34;
+  cpi_changes_res               = 35;
+  lpi_changes_res               = 36;
+
+  { numbers ... }
+  columns                       = 0;
+  init_tabs                     = 1;
+  lines                         = 2;
+  lines_of_memory               = 3;
+  magic_cookie_glitch           = 4;
+  padding_baud_rate             = 5;
+  virtual_terminal              = 6;
+  width_status_line             = 7;
+  num_labels                    = 8;
+  label_height                  = 9;
+  label_width                   = 10;
+  max_attributes                = 11;
+  maximum_windows               = 12;
+  max_colors                    = 13;
+  max_pairs                     = 14;
+  no_color_video                = 15;
+  buffer_capacity               = 16;
+  dot_vert_spacing              = 17;
+  dot_horz_spacing              = 18;
+  max_micro_address             = 19;
+  max_micro_jump                = 20;
+  micro_char_size               = 21;
+  micro_line_size               = 22;
+  number_of_pins                = 23;
+  output_res_char               = 24;
+  output_res_line               = 25;
+  output_res_horz_inch          = 26;
+  output_res_vert_inch          = 27;
+  print_rate                    = 28;
+  wide_char_size                = 29;
+  buttons                       = 30;
+  bit_image_entwining           = 31;
+  bit_image_type                = 32;
+
+  { strings }
+  back_tab                      = 0;
+  bell                          = 1;
+  carriage_return               = 2;
+  change_scroll_region          = 3;
+  clear_all_tabs                = 4;
+  clear_screen                  = 5;
+  clr_eol                       = 6;
+  clr_eos                       = 7;
+  column_address                = 8;
+  command_character             = 9;
+  cursor_address                = 10;
+  cursor_down                   = 11;
+  cursor_home                   = 12;
+  cursor_invisible              = 13;
+  cursor_left                   = 14;
+  cursor_mem_address            = 15;
+  cursor_normal                 = 16;
+  cursor_right                  = 17;
+  cursor_to_ll                  = 18;
+  cursor_up                     = 19;
+  cursor_visible                = 20;
+  delete_character              = 21;
+  delete_line                   = 22;
+  dis_status_line               = 23;
+  down_half_line                = 24;
+  enter_alt_charset_mode        = 25;
+  enter_blink_mode              = 26;
+  enter_bold_mode               = 27;
+  enter_ca_mode                 = 28;
+  enter_delete_mode             = 29;
+  enter_dim_mode                = 30;
+  enter_insert_mode             = 31;
+  enter_secure_mode             = 32;
+  enter_protected_mode          = 33;
+  enter_reverse_mode            = 34;
+  enter_standout_mode           = 35;
+  enter_underline_mode          = 36;
+  erase_chars                   = 37;
+  exit_alt_charset_mode         = 38;
+  exit_attribute_mode           = 39;
+  exit_ca_mode                  = 40;
+  exit_delete_mode              = 41;
+  exit_insert_mode              = 42;
+  exit_standout_mode            = 43;
+  exit_underline_mode           = 44;
+  flash_screen                  = 45;
+  form_feed                     = 46;
+  from_status_line              = 47;
+  init_1string                  = 48;
+  init_2string                  = 49;
+  init_3string                  = 50;
+  init_file                     = 51;
+  insert_character              = 52;
+  insert_line                   = 53;
+  insert_padding                = 54;
+  key_backspace                 = 55;
+  key_catab                     = 56;
+  key_clear                     = 57;
+  key_ctab                      = 58;
+  key_dc                        = 59;
+  key_dl                        = 60;
+  key_down                      = 61;
+  key_eic                       = 62;
+  key_eol                       = 63;
+  key_eos                       = 64;
+  key_f0                        = 65;
+  key_f1                        = 66;
+  key_f10                       = 67;
+  key_f2                        = 68;
+  key_f3                        = 69;
+  key_f4                        = 70;
+  key_f5                        = 71;
+  key_f6                        = 72;
+  key_f7                        = 73;
+  key_f8                        = 74;
+  key_f9                        = 75;
+  key_home                      = 76;
+  key_ic                        = 77;
+  key_il                        = 78;
+  key_left                      = 79;
+  key_ll                        = 80;
+  key_npage                     = 81;
+  key_ppage                     = 82;
+  key_right                     = 83;
+  key_sf                        = 84;
+  key_sr                        = 85;
+  key_stab                      = 86;
+  key_up                        = 87;
+  keypad_local                  = 88;
+  keypad_xmit                   = 89;
+  lab_f0                        = 90;
+  lab_f1                        = 91;
+  lab_f10                       = 92;
+  lab_f2                        = 93;
+  lab_f3                        = 94;
+  lab_f4                        = 95;
+  lab_f5                        = 96;
+  lab_f6                        = 97;
+  lab_f7                        = 98;
+  lab_f8                        = 99;
+  lab_f9                        = 100;
+  meta_off                      = 101;
+  meta_on                       = 102;
+  newline                       = 103;
+  pad_char                      = 104;
+  parm_dch                      = 105;
+  parm_delete_line              = 106;
+  parm_down_cursor              = 107;
+  parm_ich                      = 108;
+  parm_index                    = 109;
+  parm_insert_line              = 110;
+  parm_left_cursor              = 111;
+  parm_right_cursor             = 112;
+  parm_rindex                   = 113;
+  parm_up_cursor                = 114;
+  pkey_key                      = 115;
+  pkey_local                    = 116;
+  pkey_xmit                     = 117;
+  print_screen                  = 118;
+  prtr_off                      = 119;
+  prtr_on                       = 120;
+  repeat_char                   = 121;
+  reset_1string                 = 122;
+  reset_2string                 = 123;
+  reset_3string                 = 124;
+  reset_file                    = 125;
+  restore_cursor                = 126;
+  row_address                   = 127;
+  save_cursor                   = 128;
+  scroll_forward                = 129;
+  scroll_reverse                = 130;
+  set_attributes                = 131;
+  set_tab                       = 132;
+  set_window                    = 133;
+  tab                           = 134;
+  to_status_line                = 135;
+  underline_char                = 136;
+  up_half_line                  = 137;
+  init_prog                     = 138;
+  key_a1                        = 139;
+  key_a3                        = 140;
+  key_b2                        = 141;
+  key_c1                        = 142;
+  key_c3                        = 143;
+  prtr_non                      = 144;
+  char_padding                  = 145;
+  acs_chars                     = 146;
+  plab_norm                     = 147;
+  key_btab                      = 148;
+  enter_xon_mode                = 149;
+  exit_xon_mode                 = 150;
+  enter_am_mode                 = 151;
+  exit_am_mode                  = 152;
+  xon_character                 = 153;
+  xoff_character                = 154;
+  ena_acs                       = 155;
+  label_on                      = 156;
+  label_off                     = 157;
+  key_beg                       = 158;
+  key_cancel                    = 159;
+  key_close                     = 160;
+  key_command                   = 161;
+  key_copy                      = 162;
+  key_create                    = 163;
+  key_end                       = 164;
+  key_enter                     = 165;
+  key_exit                      = 166;
+  key_find                      = 167;
+  key_help                      = 168;
+  key_mark                      = 169;
+  key_message                   = 170;
+  key_move                      = 171;
+  key_next                      = 172;
+  key_open                      = 173;
+  key_options                   = 174;
+  key_previous                  = 175;
+  key_print                     = 176;
+  key_redo                      = 177;
+  key_reference                 = 178;
+  key_refresh                   = 179;
+  key_replace                   = 180;
+  key_restart                   = 181;
+  key_resume                    = 182;
+  key_save                      = 183;
+  key_suspend                   = 184;
+  key_undo                      = 185;
+  key_sbeg                      = 186;
+  key_scancel                   = 187;
+  key_scommand                  = 188;
+  key_scopy                     = 189;
+  key_screate                   = 190;
+  key_sdc                       = 191;
+  key_sdl                       = 192;
+  key_select                    = 193;
+  key_send                      = 194;
+  key_seol                      = 195;
+  key_sexit                     = 196;
+  key_sfind                     = 197;
+  key_shelp                     = 198;
+  key_shome                     = 199;
+  key_sic                       = 200;
+  key_sleft                     = 201;
+  key_smessage                  = 202;
+  key_smove                     = 203;
+  key_snext                     = 204;
+  key_soptions                  = 205;
+  key_sprevious                 = 206;
+  key_sprint                    = 207;
+  key_sredo                     = 208;
+  key_sreplace                  = 209;
+  key_sright                    = 210;
+  key_srsume                    = 211;
+  key_ssave                     = 212;
+  key_ssuspend                  = 213;
+  key_sundo                     = 214;
+  req_for_input                 = 215;
+  key_f11                       = 216;
+  key_f12                       = 217;
+  key_f13                       = 218;
+  key_f14                       = 219;
+  key_f15                       = 220;
+  key_f16                       = 221;
+  key_f17                       = 222;
+  key_f18                       = 223;
+  key_f19                       = 224;
+  key_f20                       = 225;
+  key_f21                       = 226;
+  key_f22                       = 227;
+  key_f23                       = 228;
+  key_f24                       = 229;
+  key_f25                       = 230;
+  key_f26                       = 231;
+  key_f27                       = 232;
+  key_f28                       = 233;
+  key_f29                       = 234;
+  key_f30                       = 235;
+  key_f31                       = 236;
+  key_f32                       = 237;
+  key_f33                       = 238;
+  key_f34                       = 239;
+  key_f35                       = 240;
+  key_f36                       = 241;
+  key_f37                       = 242;
+  key_f38                       = 243;
+  key_f39                       = 244;
+  key_f40                       = 245;
+  key_f41                       = 246;
+  key_f42                       = 247;
+  key_f43                       = 248;
+  key_f44                       = 249;
+  key_f45                       = 250;
+  key_f46                       = 251;
+  key_f47                       = 252;
+  key_f48                       = 253;
+  key_f49                       = 254;
+  key_f50                       = 255;
+  key_f51                       = 256;
+  key_f52                       = 257;
+  key_f53                       = 258;
+  key_f54                       = 259;
+  key_f55                       = 260;
+  key_f56                       = 261;
+  key_f57                       = 262;
+  key_f58                       = 263;
+  key_f59                       = 264;
+  key_f60                       = 265;
+  key_f61                       = 266;
+  key_f62                       = 267;
+  key_f63                       = 268;
+  clr_bol                       = 269;
+  clear_margins                 = 270;
+  set_left_margin               = 271;
+  set_right_margin              = 272;
+  label_format                  = 273;
+  set_clock                     = 274;
+  display_clock                 = 275;
+  remove_clock                  = 276;
+  create_window                 = 277;
+  goto_window                   = 278;
+  hangup                        = 279;
+  dial_phone                    = 280;
+  quick_dial                    = 281;
+  tone                          = 282;
+  pulse                         = 283;
+  flash_hook                    = 284;
+  fixed_pause                   = 285;
+  wait_tone                     = 286;
+  user0                         = 287;
+  user1                         = 288;
+  user2                         = 289;
+  user3                         = 290;
+  user4                         = 291;
+  user5                         = 292;
+  user6                         = 293;
+  user7                         = 294;
+  user8                         = 295;
+  user9                         = 296;
+  orig_pair                     = 297;
+  orig_colors                   = 298;
+  initialize_color              = 299;
+  initialize_pair               = 300;
+  set_color_pair                = 301;
+  set_foreground                = 302;
+  set_background                = 303;
+  change_char_pitch             = 304;
+  change_line_pitch             = 305;
+  change_res_horz               = 306;
+  change_res_vert               = 307;
+  define_char                   = 308;
+  enter_doublewide_mode         = 309;
+  enter_draft_quality           = 310;
+  enter_italics_mode            = 311;
+  enter_leftward_mode           = 312;
+  enter_micro_mode              = 313;
+  enter_near_letter_quality     = 314;
+  enter_normal_quality          = 315;
+  enter_shadow_mode             = 316;
+  enter_subscript_mode          = 317;
+  enter_superscript_mode        = 318;
+  enter_upward_mode             = 319;
+  exit_doublewide_mode          = 320;
+  exit_italics_mode             = 321;
+  exit_leftward_mode            = 322;
+  exit_micro_mode               = 323;
+  exit_shadow_mode              = 324;
+  exit_subscript_mode           = 325;
+  exit_superscript_mode         = 326;
+  exit_upward_mode              = 327;
+  micro_column_address          = 328;
+  micro_down                    = 329;
+  micro_left                    = 330;
+  micro_right                   = 331;
+  micro_row_address             = 332;
+  micro_up                      = 333;
+  order_of_pins                 = 334;
+  parm_down_micro               = 335;
+  parm_left_micro               = 336;
+  parm_right_micro              = 337;
+  parm_up_micro                 = 338;
+  select_char_set               = 339;
+  set_bottom_margin             = 340;
+  set_bottom_margin_parm        = 341;
+  set_left_margin_parm          = 342;
+  set_right_margin_parm         = 343;
+  set_top_margin                = 344;
+  set_top_margin_parm           = 345;
+  start_bit_image               = 346;
+  start_char_set_def            = 347;
+  stop_bit_image                = 348;
+  stop_char_set_def             = 349;
+  subscript_characters          = 350;
+  superscript_characters        = 351;
+  these_cause_cr                = 352;
+  zero_motion                   = 353;
+  char_set_names                = 354;
+  key_mouse                     = 355;
+  mouse_info                    = 356;
+  req_mouse_pos                 = 357;
+  get_mouse                     = 358;
+  set_a_foreground              = 359;
+  set_a_background              = 360;
+  pkey_plab                     = 361;
+  device_type                   = 362;
+  code_set_init                 = 363;
+  set0_des_seq                  = 364;
+  set1_des_seq                  = 365;
+  set2_des_seq                  = 366;
+  set3_des_seq                  = 367;
+  set_lr_margin                 = 368;
+  set_tb_margin                 = 369;
+  bit_image_repeat              = 370;
+  bit_image_newline             = 371;
+  bit_image_carriage_return     = 372;
+  color_names                   = 373;
+  define_bit_image_region       = 374;
+  end_bit_image_region          = 375;
+  set_color_band                = 376;
+  set_page_length               = 377;
+  display_pc_char               = 378;
+  enter_pc_charset_mode         = 379;
+  exit_pc_charset_mode          = 380;
+  enter_scancode_mode           = 381;
+  exit_scancode_mode            = 382;
+  pc_term_options               = 383;
+  scancode_escape               = 384;
+  alt_scancode_esc              = 385;
+  enter_horizontal_hl_mode      = 386;
+  enter_left_hl_mode            = 387;
+  enter_low_hl_mode             = 388;
+  enter_right_hl_mode           = 389;
+  enter_top_hl_mode             = 390;
+  enter_vertical_hl_mode        = 391;
+
+  { older synonyms for some booleans }
+  beehive_glitch                = no_esc_ctlc;
+  teleray_glitch                = dest_tabs_magic_smso;
+  micro_col_size                = micro_char_size;
+  { internal }
+  termcap_init2               = 392;
+  termcap_reset               = 393;
+  magic_cookie_glitch_ul      = 33;
+  backspaces_with_bs          = 37;
+  crt_no_scrolling            = 38;
+  no_correctly_working_cr     = 39;
+  carriage_return_delay       = 34;
+  new_line_delay              = 35;
+  linefeed_if_not_lf          = 394;
+  backspace_if_not_bs         = 395;
+  gnu_has_meta_key            = 40;
+  linefeed_is_newline         = 41;
+  backspace_delay             = 36;
+  horizontal_tab_delay        = 37;
+  number_of_function_keys     = 38;
+  other_non_function_keys     = 396;
+  arrow_key_map               = 397;
+  has_hardware_tabs           = 42;
+  return_does_clr_eol         = 43;
+  acs_ulcorner                = 398;
+  acs_llcorner                = 399;
+  acs_urcorner                = 400;
+  acs_lrcorner                = 401;
+  acs_ltee                    = 402;
+  acs_rtee                    = 403;
+  acs_btee                    = 404;
+  acs_ttee                    = 405;
+  acs_hline                   = 406;
+  acs_vline                   = 407;
+  acs_plus                    = 408;
+  memory_lock                 = 409;
+  memory_unlock               = 410;
+  box_chars_1                 = 411;
+
+
+const
+  NCCS = 32;
+  BoolCount = 44;
+  NumCount = 39;
+  StrCount = 412;
+
+type
+  TCFlag_t = Longint;
+  Speed_t = Longint;
+  TermIOS = record
+    c_iflag, c_oflag, c_cflag, c_lflag: TCFlag_t;
+    c_line: Byte;
+    c_cc: array [0..NCCS-1] of Char;
+    c_ispeed, c_ospeed: Speed_t;
+    Pad: word;
+  end;
+
+  TT_BoolArray = array [0..BoolCount - 1] of Boolean;
+  TT_WordArray = array [0..NumCount - 1] of Word;
+  TT_PCharArray = array [0..StrCount - 1] of PChar;
+
+  TermType4 = record
+    Term_Names: PChar;
+    Str_Table: PChar;
+    Booleans: TT_BoolArray;
+    Numbers: TT_WordArray;
+    Strings: TT_PCharArray;
+  end;
+
+  Terminal_ptr4 = ^Terminal4;
+  Terminal4 = record
+    TType: TermType4;
+    FileDes: Word;
+    Ottyb, Nttyb: Termios;
+    Pad: longint;
+  end;
+
+  TermType5 = record
+    Term_Names: PChar;
+    Str_Table: PChar;
+    Booleans: ^TT_BoolArray;
+    Numbers: ^TT_WordArray;
+    Strings: ^TT_PCharArray;
+  end;
+
+  Terminal_ptr5 = ^Terminal5;
+  Terminal5 = record
+    TType: TermType5;
+    FileDes: Word;
+    Ottyb, Nttyb: Termios;
+    Pad: longint;
+  end;
+
+  TerminalCommon_ptr1 = ^TerminalCommon1;
+  TerminalCommon1 = record
+    Term_Names: PChar;
+    Str_Table: PChar;
+  end;
+
+  TerminalCommon_ptr2 = ^TerminalCommon2;
+  TerminalCommon2 = record
+    FileDes: Word;
+    Ottyb, Nttyb: Termios;
+    Pad: longint;
+  end;
+
+  WriterFunc = function (P: PChar): Longint;
+
+var
+  cur_term : TerminalCommon_ptr1; external name 'cur_term';
+  cur_term_booleans: ^TT_BoolArray;
+  cur_term_numbers: ^TT_WordArray;
+  cur_term_strings: ^TT_PCharArray;
+  cur_term_common: TerminalCommon_ptr2;
+
+const
+  cur_term_valid : boolean = false;
+
+{ Note: the following two procedures expect a pointer to a full terminfo }
+{ structure, not just to the common parts. However, since this structure }
+{ differs for different versions of ncurses,it's impossible to give a    }
+{ general declaration here which is correct (JM)                         }
+function set_curterm(term: TerminalCommon_ptr1): TerminalCommon_ptr1;cdecl;
+function del_curterm(term: TerminalCommon_ptr1): Longint;
+
+{ sets whether to use environment variables for LINES and COLUMNS }
+procedure use_env(B: Longint);cdecl;
+
+function putp(Ndx: Longint): Longint;
+
+{ this function must be called before any terminal properties are accessed }
+function setupterm(Term: PChar; fd: Longint; var ErrCode: Longint): Longint;
+
+{ reinitialize lib }
+function restartterm(Term: PChar; fd: Longint; var ErrCode: Longint): Longint;cdecl;
+
+{function tgetent(P1, P2: PChar): Longint;
+function tgetflag(P: PChar): Longint;
+function tgetnum(P: PChar): Longint;
+function tgoto(P: PChar; L1, L2: Longint): PChar;
+function tgetstr(P: PChar; var R: PChar): PChar;
+function tigetflag(P: PChar): Longint;
+function tigetnum(P: PChar): Longint;
+function tigetstr(P: PChar): PChar;
+function tparm(P: PChar, ...): PChar;
+function tparam(const char *, char *, int, ...): PChar;}
+function tputs(Ndx: Word; L1: Longint; F: WriterFunc): Longint;
+
+implementation
+
+uses
+  Linux;
+
+function putp(Ndx: Longint): Longint;
+var
+  P: PChar;
+begin
+  if not assigned(cur_term) then
+    RunError(219);
+  P := cur_term_strings^[Ndx];
+  putp := fdWrite(cur_term_common^.filedes, P^, StrLen(P));
+end;
+
+function tputs(Ndx: Word; L1: Longint; F: WriterFunc): Longint;
+var
+  P: PChar;
+begin
+  if not assigned(cur_term) then
+    RunError(219);
+  { L1 := L1; why was this here ?? PM }
+  P := cur_term_strings^[Ndx];
+  tputs := F(P);
+end;
+
+function set_curterm(term: TerminalCommon_ptr1): TerminalCommon_ptr1; cdecl; external;
+
+procedure use_env(B: Longint); cdecl; external;
+
+function restartterm(Term: PChar; fd: Longint; var ErrCode: Longint): Longint; cdecl; external;
+
+function setuptermC(Term: PChar; fd: Longint; var ErrCode: Longint): Longint; cdecl; external name 'setupterm';
+
+function setupterm(Term: PChar; fd: Longint; var ErrCode: Longint): Longint;
+var
+  versioncheck: longint;
+begin
+  setupterm := setuptermC(term,fd,errcode);
+  if not assigned(cur_term) then
+    exit;
+  cur_term_valid := true;
+  versioncheck := 0;
+  repeat
+    if (Terminal_ptr4(cur_term)^.ttype.Booleans[versioncheck] in [false,true]) then
+      inc(versioncheck)
+    else versioncheck := -1;
+  until (versioncheck = BoolCount) or
+        (versioncheck = -1);
+  if versioncheck = BoolCount then
+    { version 4.x }
+    begin
+      cur_term_booleans := @Terminal_ptr4(cur_term)^.ttype.Booleans;
+      cur_term_numbers := @Terminal_ptr4(cur_term)^.ttype.Numbers;
+      cur_term_strings := @Terminal_ptr4(cur_term)^.ttype.Strings;
+      cur_term_common := pointer(@Terminal_ptr4(cur_term)^.FileDes);
+    end
+  else
+    { assume 5.x or higher }
+    begin
+      cur_term_booleans := Terminal_ptr5(cur_term)^.ttype.Booleans;
+      cur_term_numbers := Terminal_ptr5(cur_term)^.ttype.Numbers;
+      cur_term_strings := Terminal_ptr5(cur_term)^.ttype.Strings;
+      cur_term_common := pointer(@Terminal_ptr5(cur_term)^.FileDes);
+    end;
+end;
+
+function del_curtermC(term: TerminalCommon_ptr1): Longint; cdecl; external name 'del_curterm';
+
+function del_curterm(term: TerminalCommon_ptr1): Longint;
+var
+  reset_cur_term : boolean;
+begin
+  if term=cur_term then
+    begin
+      cur_term_booleans := nil;
+      cur_term_numbers := nil;
+      cur_term_strings := nil;
+      cur_term_common := nil;
+      reset_cur_term := true;
+    end
+  else
+    reset_cur_term := false;
+  del_curterm := del_curtermC(term);
+  if reset_cur_term then
+    cur_term_valid := false;
+end;
+
+{function tgetent(P1, P2: PChar): Longint; cdecl; external;
+function tgetflag(P: PChar): Longint; cdecl; external;
+function tgetnum(P: PChar): Longint; cdecl; external;
+function tgoto(P: PChar; L1, L2: Longint): PChar; cdecl; external;
+function tgetstr(P: PChar; var R: PChar): PChar; cdecl; external;
+function tigetflag(P: PChar): Longint; cdecl; external;
+function tigetnum(P: PChar): Longint; cdecl; external;
+function tigetstr(P: PChar): PChar; cdecl; external;
+function tparm(P: PChar; ...): PChar; cdecl; external;
+function tparam(const char *, char *, int, ...): PChar; cdecl; external;}
+
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:58  peter
+    * API 2 RTL commit
+
+}

rtl/unix/video.pp

@@ -0,0 +1,826 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Video unit for linux
+
+    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.
+
+ **********************************************************************}
+unit Video;
+
+interface
+
+{$i videoh.inc}
+
+implementation
+
+uses
+  Linux, Strings, TermInfo;
+
+{$i video.inc}
+
+var
+  LastCursorType : byte;
+  TtyFd: Longint;
+  Console: Boolean;
+  OldVideoBuf: PVideoBuf;
+{$ifdef logging}
+  f: file;
+
+const
+  logstart: string = '';
+  nl: char = #10;
+  logend: string = #10#10;
+{$endif logging}
+{$ASMMODE ATT}
+const
+  can_delete_term : boolean = false;
+  ACSIn : string = '';
+  ACSOut : string = '';
+  InACS : boolean =false;
+
+function IsACS(var ch,ACSchar : char): boolean;
+begin
+  IsACS:=false;
+  case ch of
+    #24, #30: {}
+      ch:='^';
+    #25, #31: {}
+      ch:='v';
+    #26, #16: {Never introduce a ctrl-Z ... }
+      ch:='>';
+    {#27,needed in Escape sequences} #17: {}
+      ch:='<';
+    #176, #177, #178: {°±²}
+      begin
+        IsACS:=true;
+        ACSChar:='a';
+      end;
+    #180, #181, #182, #185: {´µ¶¹}
+      begin
+        IsACS:=true;
+        ACSChar:='u';
+      end;
+    #183, #184, #187, #191: {·¸»¿}
+      begin
+        IsACS:=true;
+        ACSChar:='k';
+      end;
+    #188, #189, #190, #217: {¼½¾Ù}
+      begin
+        IsACS:=true;
+        ACSChar:='j';
+      end;
+    #192, #200, #211, #212: {ÀÈÓÔ}
+      begin
+        IsACS:=true;
+        ACSChar:='m';
+      end;
+    #193, #202, #207, #208: {ÁÊÏÐ}
+      begin
+        IsACS:=true;
+        ACSChar:='v';
+      end;
+    #194, #203, #209, #210: {ÂËÑÒ}
+      begin
+        IsACS:=true;
+        ACSChar:='w';
+      end;
+    #195, #198, #199, #204: {ÃÆÇÌ}
+      begin
+        IsACS:=true;
+        ACSChar:='t';
+      end;
+    #196, #205: {ÄÍ}
+      begin
+        IsACS:=true;
+        ACSChar:='q';
+      end;
+    #179, #186: {³º}
+      begin
+        IsACS:=true;
+        ACSChar:='x';
+      end;
+    #197, #206, #215, #216: {ÅÎ×Ø}
+      begin
+        IsACS:=true;
+        ACSChar:='n';
+      end;
+    #201, #213, #214, #218: {ÉÕÖÚ}
+      begin
+        IsACS:=true;
+        ACSChar:='l';
+      end;
+    #254: { þ }
+      begin
+        ch:='*';
+      end;
+    { Shadows for Buttons }
+    #220: { Ü }
+      begin
+        IsACS:=true;
+        ACSChar:='a';
+      end;
+    #223: { ß }
+      begin
+        IsACS:=true;
+        ACSChar:='a';
+      end;
+  end;
+end;
+
+
+function SendEscapeSeqNdx(Ndx: Word) : boolean;
+var
+  P,pdelay: PChar;
+begin
+  SendEscapeSeqNdx:=false;
+  if not assigned(cur_term_Strings) then
+    exit{RunError(219)};
+  P:=cur_term_Strings^[Ndx];
+  if assigned(p) then
+   begin { Do not transmit the delays }
+     pdelay:=strpos(p,'$<');
+     if assigned(pdelay) then
+       pdelay^:=#0;
+     fdWrite(TTYFd, P^, StrLen(P));
+     SendEscapeSeqNdx:=true;
+     if assigned(pdelay) then
+       pdelay^:='$';
+   end;
+end;
+
+
+procedure SendEscapeSeq(const S: String);
+begin
+  fdWrite(TTYFd, S[1], Length(S));
+end;
+
+
+Function IntStr(l:longint):string;
+var
+  s : string;
+begin
+  Str(l,s);
+  IntStr:=s;
+end;
+
+
+Function XY2Ansi(x,y,ox,oy:longint):String;
+{
+  Returns a string with the escape sequences to go to X,Y on the screen
+}
+Begin
+  if y=oy then
+   begin
+     if x=ox then
+      begin
+        XY2Ansi:='';
+        exit;
+      end;
+     if x=1 then
+      begin
+        XY2Ansi:=#13;
+        exit;
+      end;
+     if x>ox then
+      begin
+        XY2Ansi:=#27'['+IntStr(x-ox)+'C';
+        exit;
+      end
+     else
+      begin
+        XY2Ansi:=#27'['+IntStr(ox-x)+'D';
+        exit;
+      end;
+   end;
+  if x=ox then
+   begin
+     if y>oy then
+      begin
+        XY2Ansi:=#27'['+IntStr(y-oy)+'B';
+        exit;
+      end
+     else
+      begin
+        XY2Ansi:=#27'['+IntStr(oy-y)+'A';
+        exit;
+      end;
+   end;
+  if (x=1) and (oy+1=y) then
+   XY2Ansi:=#13#10
+  else
+   XY2Ansi:=#27'['+IntStr(y)+';'+IntStr(x)+'H';
+End;
+
+
+
+const
+  AnsiTbl : string[8]='04261537';
+Function Attr2Ansi(Attr,OAttr:longint):string;
+{
+  Convert Attr to an Ansi String, the Optimal code is calculate
+  with use of the old OAttr
+}
+var
+  hstr : string[16];
+  OFg,OBg,Fg,Bg : longint;
+
+  procedure AddSep(ch:char);
+  begin
+    if length(hstr)>0 then
+     hstr:=hstr+';';
+    hstr:=hstr+ch;
+  end;
+
+begin
+  if Attr=OAttr then
+   begin
+     Attr2Ansi:='';
+     exit;
+   end;
+  Hstr:='';
+  Fg:=Attr and $f;
+  Bg:=Attr shr 4;
+  OFg:=OAttr and $f;
+  OBg:=OAttr shr 4;
+  if (OFg<>7) or (Fg=7) or ((OFg>7) and (Fg<8)) or ((OBg>7) and (Bg<8)) then
+   begin
+     hstr:='0';
+     OFg:=7;
+     OBg:=0;
+   end;
+  if (Fg>7) and (OFg<8) then
+   begin
+     AddSep('1');
+     OFg:=OFg or 8;
+   end;
+  if (Bg and 8)<>(OBg and 8) then
+   begin
+     AddSep('5');
+     OBg:=OBg or 8;
+   end;
+  if (Fg<>OFg) then
+   begin
+     AddSep('3');
+     hstr:=hstr+AnsiTbl[(Fg and 7)+1];
+   end;
+  if (Bg<>OBg) then
+   begin
+     AddSep('4');
+     hstr:=hstr+AnsiTbl[(Bg and 7)+1];
+   end;
+  if hstr='0' then
+   hstr:='';
+  Attr2Ansi:=#27'['+hstr+'m';
+end;
+
+procedure TransformUsingACS(var st : string);
+var
+  res : string;
+  i : longint;
+  ch,ACSch : char;
+begin
+  res:='';
+  for i:=1 to length(st) do
+    begin
+      ch:=st[i];
+      if IsACS(ch,ACSch) then
+        begin
+          if not InACS then
+            begin
+              res:=res+ACSIn;
+              InACS:=true;
+            end;
+          res:=res+ACSch;
+        end
+      else
+        begin
+          if InACS then
+            begin
+              res:=res+ACSOut;
+              InACS:=false;
+            end;
+          res:=res+ch;
+        end;
+    end;
+  st:=res;
+end;
+
+
+procedure UpdateTTY(Force:boolean);
+type
+  tchattr=packed record
+    ch : char;
+    attr : byte;
+  end;
+var
+  outbuf   : array[0..1023+255] of char;
+  chattr   : tchattr;
+  skipped  : boolean;
+  outptr,
+  spaces,
+  eol,
+  x,y,
+  LastX,LastY,
+  SpaceAttr,
+  LastAttr : longint;
+  p,pold   : pvideocell;
+
+  procedure outdata(hstr:string);
+  begin
+    while (eol>0) do
+     begin
+       hstr:=#13#10+hstr;
+       dec(eol);
+     end;
+    if NoExtendedFrame and (ACSIn<>'') and (ACSOut<>'') then
+      TransformUsingACS(Hstr);
+    move(hstr[1],outbuf[outptr],length(hstr));
+    inc(outptr,length(hstr));
+    if outptr>=1024 then
+     begin
+{$ifdef logging}
+       blockwrite(f,logstart[1],length(logstart));
+       blockwrite(f,nl,1);
+       blockwrite(f,outptr,sizeof(outptr));
+       blockwrite(f,nl,1);
+       blockwrite(f,outbuf,outptr);
+       blockwrite(f,nl,1);
+{$endif logging}
+       fdWrite(TTYFd,outbuf,outptr);
+       outptr:=0;
+     end;
+  end;
+
+  procedure OutClr(c:byte);
+  begin
+    if c=LastAttr then
+     exit;
+    OutData(Attr2Ansi(c,LastAttr));
+    LastAttr:=c;
+  end;
+
+  procedure OutSpaces;
+  begin
+    if (Spaces=0) then
+     exit;
+    OutClr(SpaceAttr);
+    OutData(Space(Spaces));
+    LastX:=x;
+    LastY:=y;
+    Spaces:=0;
+  end;
+
+begin
+  OutPtr:=0;
+  Eol:=0;
+  skipped:=true;
+  p:=PVideoCell(VideoBuf);
+  pold:=PVideoCell(OldVideoBuf);
+{ init Attr and X,Y }
+  SendEscapeSeq(#27'[m'{#27'[H'});
+  LastAttr:=7;
+  LastX:=-1;
+  LastY:=-1;
+  for y:=1 to ScreenHeight do
+   begin
+     SpaceAttr:=0;
+     Spaces:=0;
+     for x:=1 to ScreenWidth do
+      begin
+        if (not force) and (p^=pold^) then
+         begin
+           if (Spaces>0) then
+            OutSpaces;
+           skipped:=true;
+         end
+        else
+         begin
+           if skipped then
+            begin
+              OutData(XY2Ansi(x,y,LastX,LastY));
+              LastX:=x;
+              LastY:=y;
+              skipped:=false;
+            end;
+           chattr:=tchattr(p^);
+           if chattr.ch in [#0,#255] then
+            chattr.ch:=' ';
+           if chattr.ch=' ' then
+            begin
+              if Spaces=0 then
+               SpaceAttr:=chattr.Attr;
+              if (chattr.attr and $f0)=(spaceattr and $f0) then
+               chattr.Attr:=SpaceAttr
+              else
+               begin
+                 OutSpaces;
+                 SpaceAttr:=chattr.Attr;
+               end;
+              inc(Spaces);
+            end
+           else
+            begin
+              if (Spaces>0) then
+               OutSpaces;
+              if ord(chattr.ch)<32 then
+                begin
+                  Chattr.Attr:= $ff xor Chattr.Attr;
+                  ChAttr.ch:= chr(ord(chattr.ch)+ord('A')-1);
+                end;
+              if LastAttr<>chattr.Attr then
+               OutClr(chattr.Attr);
+              OutData(chattr.ch);
+              LastX:=x+1;
+              LastY:=y;
+            end;
+           p^:=tvideocell(chattr);
+         end;
+        inc(p);
+        inc(pold);
+      end;
+     if (Spaces>0) then
+      OutSpaces;
+     if force then
+      inc(eol);
+   end;
+  eol:=0;
+  OutData(XY2Ansi(CursorX,CursorY,LastX,LastY));
+{$ifdef logging}
+  blockwrite(f,logstart[1],length(logstart));
+  blockwrite(f,nl,1);
+  blockwrite(f,outptr,sizeof(outptr));
+  blockwrite(f,nl,1);
+  blockwrite(f,outbuf,outptr);
+  blockwrite(f,nl,1);
+{$endif logging}
+  fdWrite(TTYFd,outbuf,outptr);
+  if InACS then
+    SendEscapeSeqNdx(exit_alt_charset_mode);
+end;
+
+var
+  InitialVideoTio, preInitVideoTio, postInitVideoTio: linux.termios;
+  inputRaw, outputRaw: boolean;
+
+procedure saveRawSettings(const tio: linux.termios);
+Begin
+  with tio do
+   begin
+     inputRaw :=
+       ((c_iflag and (IGNBRK or BRKINT or PARMRK or ISTRIP or
+                                INLCR or IGNCR or ICRNL or IXON)) = 0) and
+       ((c_lflag and (ECHO or ECHONL or ICANON or ISIG or IEXTEN)) = 0);
+     outPutRaw :=
+       ((c_oflag and OPOST) = 0) and
+       ((c_cflag and (CSIZE or PARENB)) = 0) and
+       ((c_cflag and CS8) <> 0);
+   end;
+end;
+
+procedure restoreRawSettings(tio: linux.termios);
+begin
+  with tio do
+    begin
+      if inputRaw then
+        begin
+          c_iflag := c_iflag and (not (IGNBRK or BRKINT or PARMRK or ISTRIP or
+            INLCR or IGNCR or ICRNL or IXON));
+          c_lflag := c_lflag and
+            (not (ECHO or ECHONL or ICANON or ISIG or IEXTEN));
+       end;
+     if outPutRaw then
+       begin
+         c_oflag := c_oflag and not(OPOST);
+         c_cflag := c_cflag and not(CSIZE or PARENB) or CS8;
+       end;
+   end;
+  TCSetAttr(1,TCSANOW,tio);
+end;
+
+procedure TargetEntry;
+begin
+  TCGetAttr(1,InitialVideoTio);
+end;
+
+procedure TargetExit;
+begin
+  TCSetAttr(1,TCSANOW,InitialVideoTio);
+end;
+
+procedure prepareInitVideo;
+begin
+  TCGetAttr(1,preInitVideoTio);
+  saveRawSettings(preInitVideoTio);
+end;
+
+procedure videoInitDone;
+begin
+  TCGetAttr(1,postInitVideoTio);
+  restoreRawSettings(postInitVideoTio);
+end;
+
+procedure prepareDoneVideo;
+var
+  tio: linux.termios;
+begin
+  TCGetAttr(1,tio);
+  saveRawSettings(tio);
+  TCSetAttr(1,TCSANOW,postInitVideoTio);
+end;
+
+procedure doneVideoDone;
+begin
+  restoreRawSettings(preInitVideoTio);
+end;
+
+procedure InitVideo;
+const
+  fontstr : string[3]=#27'(K';
+var
+  ThisTTY: String[30];
+  FName: String;
+  WS: packed record
+    ws_row, ws_col, ws_xpixel, ws_ypixel: Word;
+  end;
+  Err: Longint;
+  prev_term : TerminalCommon_ptr1;
+begin
+{$ifndef CPUI386}
+  LowAscii:=false;
+{$endif CPUI386}
+  if VideoBufSize<>0 then
+   begin
+     clearscreen;
+     if Console then
+      SetCursorPos(1,1)
+     else
+      begin
+        if not SendEscapeSeqNdx(cursor_home) then
+          SendEscapeSeq(#27'[H');
+      end;
+     exit;
+   end;
+  { check for tty }
+  ThisTTY:=TTYName(stdinputhandle);
+  if IsATTY(stdinputhandle) then
+   begin
+     { save current terminal characteristics and remove rawness }
+     prepareInitVideo;
+     { write code to set a correct font }
+     fdWrite(stdoutputhandle,fontstr[1],length(fontstr));
+     { running on a tty, find out whether locally or remotely }
+     if (Copy(ThisTTY, 1, 8) = '/dev/tty') and
+        (ThisTTY[9] >= '0') and (ThisTTY[9] <= '9') then
+      begin
+        { running on the console }
+        FName:='/dev/vcsa' + ThisTTY[9];
+        TTYFd:=fdOpen(FName, Octal(666), Open_RdWr); { open console }
+      end
+     else
+      TTYFd:=-1;
+     if TTYFd<>-1 then
+      Console:=true
+     else
+      begin
+        { running on a remote terminal, no error with /dev/vcsa }
+        Console:=False;
+        LowAscii:=false;
+        TTYFd:=stdoutputhandle;
+      end;
+     ioctl(stdinputhandle, TIOCGWINSZ, @WS);
+     if WS.ws_Col=0 then
+      WS.ws_Col:=80;
+     if WS.ws_Row=0 then
+      WS.ws_Row:=25;
+     ScreenWidth:=WS.ws_Col;
+     { TDrawBuffer only has FVMaxWidth elements
+       larger values lead to crashes }
+     if ScreenWidth> FVMaxWidth then
+       ScreenWidth:=FVMaxWidth;
+     ScreenHeight:=WS.ws_Row;
+     CursorX:=1;
+     CursorY:=1;
+     ScreenColor:=True;
+     { allocate pmode memory buffer }
+     VideoBufSize:=ScreenWidth*ScreenHeight*2;
+     GetMem(VideoBuf,VideoBufSize);
+     GetMem(OldVideoBuf,VideoBufSize);
+     { Start with a clear screen }
+     if not Console then
+      begin
+        prev_term:=cur_term;
+        setupterm(nil, stdoutputhandle, err);
+        can_delete_term:=assigned(prev_term) and (prev_term<>cur_term);
+        SendEscapeSeqNdx(cursor_home);
+        SendEscapeSeqNdx(cursor_normal);
+        SendEscapeSeqNdx(cursor_visible);
+        SendEscapeSeqNdx(enter_ca_mode);
+        SetCursorType(crUnderLine);
+      end
+     else if not assigned(cur_term) then
+       begin
+         setupterm(nil, stdoutputhandle, err);
+         can_delete_term:=false;
+       end;
+     if assigned(cur_term_Strings) then
+       begin
+         ACSIn:=StrPas(cur_term_Strings^[enter_alt_charset_mode]);
+         ACSOut:=StrPas(cur_term_Strings^[exit_alt_charset_mode]);
+         if (ACSIn<>'') and (ACSOut<>'') then
+           SendEscapeSeqNdx(ena_acs);
+         if pos('$<',ACSIn)>0 then
+           ACSIn:=Copy(ACSIn,1,Pos('$<',ACSIn)-1);
+         if pos('$<',ACSOut)>0 then
+           ACSOut:=Copy(ACSOut,1,Pos('$<',ACSOut)-1);
+       end
+     else
+       begin
+         ACSIn:='';
+         ACSOut:='';
+       end;
+     ClearScreen;
+{$ifdef logging}
+     assign(f,'video.log');
+     rewrite(f,1);
+{$endif logging}
+     { save new terminal characteristics and possible restore rawness }
+     videoInitDone;
+   end
+  else
+   ErrorCode:=errVioInit; { not a TTY }
+end;
+
+procedure DoneVideo;
+begin
+  if VideoBufSize=0 then
+   exit;
+  prepareDoneVideo;
+  ClearScreen;
+  if Console then
+   SetCursorPos(1,1)
+  else
+   begin
+     SendEscapeSeqNdx(exit_ca_mode);
+     SendEscapeSeqNdx(cursor_home);
+     SendEscapeSeqNdx(cursor_normal);
+     SendEscapeSeqNdx(cursor_visible);
+     SetCursorType(crUnderLine);
+     SendEscapeSeq(#27'[H');
+   end;
+  FreeMem(VideoBuf,VideoBufSize);
+  FreeMem(OldVideoBuf,VideoBufSize);
+  VideoBufSize:=0;
+  ACSIn:='';
+  ACSOut:='';
+  doneVideoDone;
+  if can_delete_term then
+    begin
+      del_curterm(cur_term);
+      can_delete_term:=false;
+    end;
+{$ifdef logging}
+  close(f);
+{$endif logging}
+end;
+
+
+procedure ClearScreen;
+begin
+  FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
+  if Console then
+   UpdateScreen(true)
+  else
+   begin
+     SendEscapeSeq(#27'[0m');
+     SendEscapeSeqNdx(clear_screen);
+   end;
+end;
+
+
+procedure UpdateScreen(Force: Boolean);
+var
+  DoUpdate : boolean;
+begin
+  if LockUpdateScreen<>0 then
+   exit;
+  if not force then
+   begin
+{$ifdef i386}
+     asm
+          movl    VideoBuf,%esi
+          movl    OldVideoBuf,%edi
+          movl    VideoBufSize,%ecx
+          shrl    $2,%ecx
+          repe
+          cmpsl
+          setne   DoUpdate
+     end;
+{$endif i386}
+   end
+  else
+   DoUpdate:=true;
+  if not DoUpdate then
+   exit;
+  if Console then
+   begin
+     fdSeek(TTYFd, 4, Seek_Set);
+     fdWrite(TTYFd, VideoBuf^,VideoBufSize);
+   end
+  else
+   begin
+     UpdateTTY(force);
+   end;
+  Move(VideoBuf^, OldVideoBuf^, VideoBufSize);
+end;
+
+
+function GetCapabilities: Word;
+begin
+{ about cpColor... we should check the terminfo database... }
+  GetCapabilities:=cpUnderLine + cpBlink + cpColor;
+end;
+
+
+procedure SetCursorPos(NewCursorX, NewCursorY: Word);
+var
+  Pos : array [1..2] of Byte;
+begin
+  if Console then
+   begin
+     fdSeek(TTYFd, 2, Seek_Set);
+     Pos[1]:=NewCursorX;
+     Pos[2]:=NewCursorY;
+     fdWrite(TTYFd, Pos, 2);
+   end
+  else
+   begin
+     { newcursorx,y is 0 based ! }
+     SendEscapeSeq(XY2Ansi(NewCursorX+1,NewCursorY+1,0,0));
+   end;
+  CursorX:=NewCursorX+1;
+  CursorY:=NewCursorY+1;
+end;
+
+
+function GetCursorType: Word;
+begin
+  GetCursorType:=LastCursorType;
+end;
+
+
+procedure SetCursorType(NewType: Word);
+begin
+  LastCursorType:=NewType;
+  case NewType of
+   crBlock :
+     Begin
+       If not SendEscapeSeqNdx(cursor_visible) then
+         SendEscapeSeq(#27'[?17;0;64c');
+     End;
+   crHidden :
+     Begin
+       If not SendEscapeSeqNdx(cursor_invisible) then
+         SendEscapeSeq(#27'[?1c');
+     End;
+  else
+    begin
+      If not SendEscapeSeqNdx(cursor_normal) then
+        SendEscapeSeq(#27'[?2c');
+    end;
+  end;
+end;
+
+
+function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean;
+begin
+  DefaultVideoModeSelector:=false;
+end;
+
+
+procedure RegisterVideoModes;
+begin
+end;
+
+initialization
+  RegisterVideoModes;
+
+finalization
+  UnRegisterVideoModes;
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:58  peter
+    * API 2 RTL commit
+
+}
+

rtl/win32/Makefile

@@ -1,5 +1,5 @@
 #
-# Makefile generated by fpcmake v1.00 [2000/12/19]
+# Makefile generated by fpcmake v1.00 [2000/12/22]
 #
 
 defaultrule: all
@@ -50,6 +50,25 @@ else
 SRCEXEEXT=.exe
 endif
 
+# The extension of batch files / scripts
+ifdef inUnix
+BATCHEXT=.sh
+else
+ifdef inOS2
+BATCHEXT=.cmd
+else
+BATCHEXT=.bat
+endif
+endif
+
+# Path Separator, the subst trick is necessary for the \ that can't exists
+# at the end of a line
+ifdef inUnix
+PATHSEP=/
+else
+PATHSEP=$(subst /,\,/)
+endif
+
 # The path which is searched separated by spaces
 ifdef inUnix
 SEARCHPATH=$(subst :, ,$(PATH))
@@ -198,7 +217,7 @@ endif
 # Targets
 
 override LOADEROBJECTS+=wprt0 wdllprt0
-override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings windows ole2 opengl32 os_types winsock initc dos crt objects graph sysutils typinfo math varutils cpu mmx getopts heaptrc lineinfo wincrt winmouse sockets printer dynlibs
+override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings windows ole2 opengl32 os_types winsock initc dos crt objects graph sysutils typinfo math varutils cpu mmx getopts heaptrc lineinfo wincrt winmouse winevent sockets printer dynlibs video mouse keyboard
 override RSTOBJECTS+=math varutils
 
 # Clean
@@ -341,15 +360,7 @@ LD=ld
 endif
 
 # ppas.bat / ppas.sh
-ifdef inUnix
-PPAS=ppas.sh
-else
-ifdef inOS2
-PPAS=ppas.cmd
-else
-PPAS=ppas.bat
-endif
-endif
+PPAS=ppas$(BATCHEXT)
 
 # ldconfig to rebuild .so cache
 ifdef inUnix
@@ -1112,18 +1123,48 @@ USETAR=1
 endif
 endif
 
+# Use a wrapper script by default for OS/2
+ifdef inOS2
+USEZIPWRAPPER=1
+endif
+
+# Create commands to create the zip/tar file
+ZIPWRAPPER=$(DESTZIPDIR)/fpczip$(BATCHEXT)
+ZIPCMD_CDPACK:=cd $(subst /,$(PATHSEP),$(PACKDIR))
+ZIPCMD_CDBASE:=cd $(subst /,$(PATHSEP),$(BASEDIR))
+ifdef USETAR
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
+ZIPCMD_ZIP:=$(TARPROG) cf$(TAROPT) $(ZIPDESTFILE) *
+else
+ZIPDESTFILE:=$(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
+ZIPCMD_ZIP:=$(subst /,$(PATHSEP),$(ZIPPROG)) -Dr $(ZIPOPT) $(ZIPDESTFILE) *
+endif
+
 fpc_zipinstall:
 ifndef ZIPNAME
 	@$(ECHO) "Please specify ZIPNAME!"
 	@exit 1
 else
 	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
-ifdef USETAR
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT)
-	cd $(PACKDIR) ; $(TARPROG) cf$(TAROPT) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR)
+	$(DEL) $(ZIPDESTFILE)
+ifdef USEZIPWRAPPER
+ifneq ($(ECHO),echo)
+	$(ECHO) "$(ZIPCMD_CDPACK)" > $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_ZIP)" >> $(ZIPWRAPPER)
+	$(ECHO) "$(ZIPCMD_CDBASE)" >> $(ZIPWRAPPER)
+else
+	$(ECHO) $(ZIPCMD_CDPACK) > $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_ZIP) >> $(ZIPWRAPPER)
+	$(ECHO) $(ZIPCMD_CDBASE) >> $(ZIPWRAPPER)
+endif
+ifdef inUnix
+	/bin/sh $(ZIPWRAPPER)
+else
+	$(ZIPWRAPPER)
+endif
+	$(DEL) $(ZIPWRAPPER)
 else
-	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT)
-	cd $(PACKDIR) ; $(ZIPPROG) -Dr $(ZIPOPT) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) * ; cd $(BASEDIR)
+	$(ZIPCMD_CDPACK) ; $(ZIPCMD_ZIP) ; $(ZIPCMD_CDBASE)
 endif
 	$(DELTREE) $(PACKDIR)
 endif

rtl/win32/Makefile.fpc

@@ -9,7 +9,9 @@ units=$(SYSTEMUNIT) objpas strings \
       dos crt objects graph \
       sysutils typinfo math varutils \
       cpu mmx getopts heaptrc lineinfo \
-      wincrt winmouse sockets printer dynlibs
+      wincrt winmouse winevent sockets printer dynlibs \
+      video mouse keyboard
+
 rst=math varutils
 
 [require]

rtl/win32/keyboard.pp

@@ -0,0 +1,797 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Keyboard unit for Win32
+
+    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.
+
+ **********************************************************************}
+unit Keyboard;
+interface
+
+{$i keybrdh.inc}
+
+implementation
+
+{ WARNING: Keyboard-Drivers (i.e. german) will only work under WinNT.
+           95 and 98 do not support keyboard-drivers other than us for win32
+           console-apps. So we always get the keys in us-keyboard layout
+           from Win9x.
+}
+
+uses
+{$ifndef DEBUG}
+   Windows,
+{$endif DEBUG}
+   Dos,
+   WinEvent;
+
+{$i keyboard.inc}
+
+const MaxQueueSize = 120;
+      FrenchKeyboard = $040C040C;
+      KeyboardActive : boolean =false;
+var
+   keyboardeventqueue : array[0..maxqueuesize] of TKeyEventRecord;
+   nextkeyevent,nextfreekeyevent : longint;
+   newKeyEvent    : THandle;            {sinaled if key is available}
+   lockVar        : TCriticalSection;   {for queue access}
+   lastShiftState : byte;               {set by handler for PollShiftStateEvent}
+   altNumActive   : boolean;            {for alt+0..9}
+   altNumBuffer   : string [3];
+   { used for keyboard specific stuff }
+   KeyBoardLayout : HKL;
+
+procedure incqueueindex(var l : longint);
+
+  begin
+     inc(l);
+     { wrap around? }
+     if l>maxqueuesize then
+       l:=0;
+  end;
+
+function keyEventsInQueue : boolean;
+begin
+  keyEventsInQueue := (nextkeyevent <> nextfreekeyevent);
+end;
+
+
+{ gets or peeks the next key from the queue, does not wait for new keys }
+function getKeyEventFromQueue (VAR t : TKeyEventRecord; Peek : boolean) : boolean;
+begin
+  EnterCriticalSection (lockVar);
+  if keyEventsInQueue then
+  begin
+    t := keyboardeventqueue[nextkeyevent];
+    if not peek then incqueueindex (nextkeyevent);
+    getKeyEventFromQueue := true;
+    if not keyEventsInQueue then ResetEvent (newKeyEvent);
+  end else
+  begin
+    getKeyEventFromQueue := false;
+    ResetEvent (newKeyEvent);
+  end;
+  LeaveCriticalSection (lockVar);
+end;
+
+
+{ gets the next key from the queue, does wait for new keys }
+function getKeyEventFromQueueWait (VAR t : TKeyEventRecord) : boolean;
+begin
+  WaitForSingleObject (newKeyEvent, INFINITE);
+  getKeyEventFromQueueWait := getKeyEventFromQueue (t, false);
+end;
+
+{ translate win32 shift-state to keyboard shift state }
+function transShiftState (ControlKeyState : dword) : byte;
+var b : byte;
+begin
+  b := 0;
+  if ControlKeyState and SHIFT_PRESSED <> 0 then  { win32 makes no difference between left and right shift }
+    b := b or kbShift;
+  if (ControlKeyState and LEFT_CTRL_PRESSED <> 0) or
+     (ControlKeyState  and RIGHT_CTRL_PRESSED <> 0) then
+    b := b or kbCtrl;
+  if (ControlKeyState and LEFT_ALT_PRESSED <> 0) or
+     (ControlKeyState and RIGHT_ALT_PRESSED <> 0) then
+    b := b or kbAlt;
+  transShiftState := b;
+end;
+
+{ The event-Handler thread from the unit event will call us if a key-event
+  is available }
+
+procedure HandleKeyboard;
+var
+   ir     : INPUT_RECORD;
+   dwRead : DWord;
+   i      : longint;
+   c      : word;
+   addThis: boolean;
+begin
+   dwRead:=1;
+   ReadConsoleInput(TextRec(Input).Handle,ir,1,dwRead);
+   if (dwRead=1) and (ir.EventType=KEY_EVENT) then
+     begin
+         with ir.KeyEvent do
+           begin
+              { key up events are ignored (except alt) }
+              if bKeyDown then
+                begin
+                   EnterCriticalSection (lockVar);
+                   for i:=1 to wRepeatCount do
+                     begin
+                        addThis := true;
+                        if (dwControlKeyState and LEFT_ALT_PRESSED <> 0) or
+                           (dwControlKeyState and RIGHT_ALT_PRESSED <> 0) then            {alt pressed}
+                          if (wVirtualKeyCode >= $60) and (wVirtualKeyCode <= $69) then   {0..9 on NumBlock}
+                          begin
+                            if length (altNumBuffer) = 3 then
+                              delete (altNumBuffer,1,1);
+                            altNumBuffer := altNumBuffer + char (wVirtualKeyCode-48);
+                            altNumActive   := true;
+                            addThis := false;
+                          end else
+                          begin
+                            altNumActive   := false;
+                            altNumBuffer   := '';
+                          end;
+                        if addThis then
+                        begin
+                          keyboardeventqueue[nextfreekeyevent]:=
+                            ir.KeyEvent;
+                          incqueueindex(nextfreekeyevent);
+                        end;
+                     end;
+
+                   lastShiftState := transShiftState (dwControlKeyState);  {save it for PollShiftStateEvent}
+                   SetEvent (newKeyEvent);             {event that a new key is available}
+                   LeaveCriticalSection (lockVar);
+                end else
+                begin
+                  lastShiftState := transShiftState (dwControlKeyState);   {save it for PollShiftStateEvent}
+                  {for alt-number we have to look for alt-key release}
+                  if altNumActive then
+                    if (wVirtualKeyCode = $12) then    {alt-released}
+                    begin
+                      if altNumBuffer <> '' then       {numbers with alt pressed?}
+                      begin
+                        Val (altNumBuffer, c, i);
+                        if (i = 0) and (c <= 255) then {valid number?}
+                        begin                          {add to queue}
+                          fillchar (ir, sizeof (ir), 0);
+                          bKeyDown := true;
+                          AsciiChar := char (c);
+                                                       {and add to queue}
+                          EnterCriticalSection (lockVar);
+                          keyboardeventqueue[nextfreekeyevent]:=
+                            ir.KeyEvent;
+                          incqueueindex(nextfreekeyevent);
+                          SetEvent (newKeyEvent);      {event that a new key is available}
+                          LeaveCriticalSection (lockVar);
+                        end;
+                      end;
+                      altNumActive   := false;         {clear alt-buffer}
+                      altNumBuffer   := '';
+                    end;
+                end;
+           end;
+     end;
+end;
+
+procedure InitKeyboard;
+begin
+   if KeyboardActive then
+     exit;
+   KeyBoardLayout:=GetKeyboardLayout(0);
+   lastShiftState := 0;
+   FlushConsoleInputBuffer(TextRec(Input).Handle);
+   newKeyEvent := CreateEvent (nil,        // address of security attributes
+                               true,       // flag for manual-reset event
+                               false,      // flag for initial state
+                               nil);       // address of event-object name
+   if newKeyEvent = INVALID_HANDLE_VALUE then
+   begin
+     // what to do here ????
+     RunError (217);
+   end;
+   InitializeCriticalSection (lockVar);
+   altNumActive := false;
+   altNumBuffer := '';
+
+   nextkeyevent:=0;
+   nextfreekeyevent:=0;
+   SetKeyboardEventHandler (@HandleKeyboard);
+   KeyboardActive:=true;
+end;
+
+procedure DoneKeyboard;
+begin
+   if not KeyboardActive then
+     exit;
+   SetKeyboardEventHandler(nil);     {hangs???}
+   DeleteCriticalSection (lockVar);
+   FlushConsoleInputBuffer(TextRec(Input).Handle);
+   closeHandle (newKeyEvent);
+   KeyboardActive:=false;
+end;
+
+{$define USEKEYCODES}
+
+{Translatetable Win32 -> Dos for Special Keys = Function Key, Cursor Keys
+ and Keys other than numbers on numblock (to make fv happy) }
+{combinations under dos: Shift+Ctrl: same as Ctrl
+                         Shift+Alt : same as alt
+                         Ctrl+Alt  : nothing (here we get it like alt)}
+{$ifdef USEKEYCODES}
+   { use positive values for ScanCode we want to set
+   0 for key where we should leave the scancode
+   -1 for OEM specifc keys
+   -2 for unassigned
+   -3 for Kanji systems ???
+   }
+const
+  Unassigned = -2;
+  Kanji = -3;
+  OEM_specific = -1;
+  KeyToQwertyScan : array [0..255] of integer =
+  (
+  { 00 } 0,
+  { 01 VK_LBUTTON } 0,
+  { 02 VK_RBUTTON } 0,
+  { 03 VK_CANCEL } 0,
+  { 04 VK_MBUTTON } 0,
+  { 05 unassigned } -2,
+  { 06 unassigned } -2,
+  { 07 unassigned } -2,
+  { 08 VK_BACK } $E,
+  { 09 VK_TAB } $F,
+  { 0A unassigned } -2,
+  { 0B unassigned } -2,
+  { 0C VK_CLEAR ?? } 0,
+  { 0D VK_RETURN } 0,
+  { 0E unassigned } -2,
+  { 0F unassigned } -2,
+  { 10 VK_SHIFT } 0,
+  { 11 VK_CONTROL } 0,
+  { 12 VK_MENU (Alt key) } 0,
+  { 13 VK_PAUSE } 0,
+  { 14 VK_CAPITAL (Caps Lock) } 0,
+  { 15 Reserved for Kanji systems} -3,
+  { 16 Reserved for Kanji systems} -3,
+  { 17 Reserved for Kanji systems} -3,
+  { 18 Reserved for Kanji systems} -3,
+  { 19 Reserved for Kanji systems} -3,
+  { 1A unassigned } -2,
+  { 1B VK_ESCAPE } $1,
+  { 1C Reserved for Kanji systems} -3,
+  { 1D Reserved for Kanji systems} -3,
+  { 1E Reserved for Kanji systems} -3,
+  { 1F Reserved for Kanji systems} -3,
+  { 20 VK_SPACE} 0,
+  { 21 VK_PRIOR (PgUp) } 0,
+  { 22 VK_NEXT (PgDown) } 0,
+  { 23 VK_END } 0,
+  { 24 VK_HOME } 0,
+  { 25 VK_LEFT } 0,
+  { 26 VK_UP } 0,
+  { 27 VK_RIGHT } 0,
+  { 28 VK_DOWN } 0,
+  { 29 VK_SELECT ??? } 0,
+  { 2A OEM specific !! } -1,
+  { 2B VK_EXECUTE } 0,
+  { 2C VK_SNAPSHOT } 0,
+  { 2D VK_INSERT } 0,
+  { 2E VK_DELETE } 0,
+  { 2F VK_HELP } 0,
+  { 30 VK_0 '0' } 11,
+  { 31 VK_1 '1' } 2,
+  { 32 VK_2 '2' } 3,
+  { 33 VK_3 '3' } 4,
+  { 34 VK_4 '4' } 5,
+  { 35 VK_5 '5' } 6,
+  { 36 VK_6 '6' } 7,
+  { 37 VK_7 '7' } 8,
+  { 38 VK_8 '8' } 9,
+  { 39 VK_9 '9' } 10,
+  { 3A unassigned } -2,
+  { 3B unassigned } -2,
+  { 3C unassigned } -2,
+  { 3D unassigned } -2,
+  { 3E unassigned } -2,
+  { 3F unassigned } -2,
+  { 40 unassigned } -2,
+  { 41 VK_A 'A' } $1E,
+  { 42 VK_B 'B' } $30,
+  { 43 VK_C 'C' } $2E,
+  { 44 VK_D 'D' } $20,
+  { 45 VK_E 'E' } $12,
+  { 46 VK_F 'F' } $21,
+  { 47 VK_G 'G' } $22,
+  { 48 VK_H 'H' } $23,
+  { 49 VK_I 'I' } $17,
+  { 4A VK_J 'J' } $24,
+  { 4B VK_K 'K' } $25,
+  { 4C VK_L 'L' } $26,
+  { 4D VK_M 'M' } $32,
+  { 4E VK_N 'N' } $31,
+  { 4F VK_O 'O' } $18,
+  { 50 VK_P 'P' } $19,
+  { 51 VK_Q 'Q' } $10,
+  { 52 VK_R 'R' } $13,
+  { 53 VK_S 'S' } $1F,
+  { 54 VK_T 'T' } $14,
+  { 55 VK_U 'U' } $16,
+  { 56 VK_V 'V' } $2F,
+  { 57 VK_W 'W' } $11,
+  { 58 VK_X 'X' } $2D,
+  { 59 VK_Y 'Y' } $15,
+  { 5A VK_Z 'Z' } $2C,
+  { 5B unassigned } -2,
+  { 5C unassigned } -2,
+  { 5D unassigned } -2,
+  { 5E unassigned } -2,
+  { 5F unassigned } -2,
+  { 60 VK_NUMPAD0 NumKeyPad '0' } 11,
+  { 61 VK_NUMPAD1 NumKeyPad '1' } 2,
+  { 62 VK_NUMPAD2 NumKeyPad '2' } 3,
+  { 63 VK_NUMPAD3 NumKeyPad '3' } 4,
+  { 64 VK_NUMPAD4 NumKeyPad '4' } 5,
+  { 65 VK_NUMPAD5 NumKeyPad '5' } 6,
+  { 66 VK_NUMPAD6 NumKeyPad '6' } 7,
+  { 67 VK_NUMPAD7 NumKeyPad '7' } 8,
+  { 68 VK_NUMPAD8 NumKeyPad '8' } 9,
+  { 69 VK_NUMPAD9 NumKeyPad '9' } 10,
+  { 6A VK_MULTIPLY } 0,
+  { 6B VK_ADD } 0,
+  { 6C VK_SEPARATOR } 0,
+  { 6D VK_SUBSTRACT } 0,
+  { 6E VK_DECIMAL } 0,
+  { 6F VK_DIVIDE } 0,
+  { 70 VK_F1 'F1' } $3B,
+  { 71 VK_F2 'F2' } $3C,
+  { 72 VK_F3 'F3' } $3D,
+  { 73 VK_F4 'F4' } $3E,
+  { 74 VK_F5 'F5' } $3F,
+  { 75 VK_F6 'F6' } $40,
+  { 76 VK_F7 'F7' } $41,
+  { 77 VK_F8 'F8' } $42,
+  { 78 VK_F9 'F9' } $43,
+  { 79 VK_F10 'F10' } $44,
+  { 7A VK_F11 'F11' } $57,
+  { 7B VK_F12 'F12' } $58,
+  { 7C VK_F13 } 0,
+  { 7D VK_F14 } 0,
+  { 7E VK_F15 } 0,
+  { 7F VK_F16 } 0,
+  { 80 VK_F17 } 0,
+  { 81 VK_F18 } 0,
+  { 82 VK_F19 } 0,
+  { 83 VK_F20 } 0,
+  { 84 VK_F21 } 0,
+  { 85 VK_F22 } 0,
+  { 86 VK_F23 } 0,
+  { 87 VK_F24 } 0,
+  { 88 unassigned } -2,
+  { 89 VK_NUMLOCK } 0,
+  { 8A VK_SCROLL } 0,
+  { 8B unassigned } -2,
+  { 8C unassigned } -2,
+  { 8D unassigned } -2,
+  { 8E unassigned } -2,
+  { 8F unassigned } -2,
+  { 90 unassigned } -2,
+  { 91 unassigned } -2,
+  { 92 unassigned } -2,
+  { 93 unassigned } -2,
+  { 94 unassigned } -2,
+  { 95 unassigned } -2,
+  { 96 unassigned } -2,
+  { 97 unassigned } -2,
+  { 98 unassigned } -2,
+  { 99 unassigned } -2,
+  { 9A unassigned } -2,
+  { 9B unassigned } -2,
+  { 9C unassigned } -2,
+  { 9D unassigned } -2,
+  { 9E unassigned } -2,
+  { 9F unassigned } -2,
+  { A0 unassigned } -2,
+  { A1 unassigned } -2,
+  { A2 unassigned } -2,
+  { A3 unassigned } -2,
+  { A4 unassigned } -2,
+  { A5 unassigned } -2,
+  { A6 unassigned } -2,
+  { A7 unassigned } -2,
+  { A8 unassigned } -2,
+  { A9 unassigned } -2,
+  { AA unassigned } -2,
+  { AB unassigned } -2,
+  { AC unassigned } -2,
+  { AD unassigned } -2,
+  { AE unassigned } -2,
+  { AF unassigned } -2,
+  { B0 unassigned } -2,
+  { B1 unassigned } -2,
+  { B2 unassigned } -2,
+  { B3 unassigned } -2,
+  { B4 unassigned } -2,
+  { B5 unassigned } -2,
+  { B6 unassigned } -2,
+  { B7 unassigned } -2,
+  { B8 unassigned } -2,
+  { B9 unassigned } -2,
+  { BA OEM specific } 0,
+  { BB OEM specific } 0,
+  { BC OEM specific } 0,
+  { BD OEM specific } 0,
+  { BE OEM specific } 0,
+  { BF OEM specific } 0,
+  { C0 OEM specific } 0,
+  { C1 unassigned } -2,
+  { C2 unassigned } -2,
+  { C3 unassigned } -2,
+  { C4 unassigned } -2,
+  { C5 unassigned } -2,
+  { C6 unassigned } -2,
+  { C7 unassigned } -2,
+  { C8 unassigned } -2,
+  { C9 unassigned } -2,
+  { CA unassigned } -2,
+  { CB unassigned } -2,
+  { CC unassigned } -2,
+  { CD unassigned } -2,
+  { CE unassigned } -2,
+  { CF unassigned } -2,
+  { D0 unassigned } -2,
+  { D1 unassigned } -2,
+  { D2 unassigned } -2,
+  { D3 unassigned } -2,
+  { D4 unassigned } -2,
+  { D5 unassigned } -2,
+  { D6 unassigned } -2,
+  { D7 unassigned } -2,
+  { D8 unassigned } -2,
+  { D9 unassigned } -2,
+  { DA unassigned } -2,
+  { DB OEM specific } 0,
+  { DC OEM specific } 0,
+  { DD OEM specific } 0,
+  { DE OEM specific } 0,
+  { DF OEM specific } 0,
+  { E0 OEM specific } 0,
+  { E1 OEM specific } 0,
+  { E2 OEM specific } 0,
+  { E3 OEM specific } 0,
+  { E4 OEM specific } 0,
+  { E5 unassigned } -2,
+  { E6 OEM specific } 0,
+  { E7 unassigned } -2,
+  { E8 unassigned } -2,
+  { E9 OEM specific } 0,
+  { EA OEM specific } 0,
+  { EB OEM specific } 0,
+  { EC OEM specific } 0,
+  { ED OEM specific } 0,
+  { EE OEM specific } 0,
+  { EF OEM specific } 0,
+  { F0 OEM specific } 0,
+  { F1 OEM specific } 0,
+  { F2 OEM specific } 0,
+  { F3 OEM specific } 0,
+  { F4 OEM specific } 0,
+  { F5 OEM specific } 0,
+  { F6 unassigned } -2,
+  { F7 unassigned } -2,
+  { F8 unassigned } -2,
+  { F9 unassigned } -2,
+  { FA unassigned } -2,
+  { FB unassigned } -2,
+  { FC unassigned } -2,
+  { FD unassigned } -2,
+  { FE unassigned } -2,
+  { FF unassigned } -2
+  );
+{$endif  USEKEYCODES}
+type TTEntryT = packed record
+                  n,s,c,a : byte;   {normal,shift, ctrl, alt, normal only for f11,f12}
+                end;
+
+CONST
+ DosTT : ARRAY [$3B..$58] OF TTEntryT =
+  ((n : $3B; s : $54; c : $5E; a: $68),      {3B F1}
+   (n : $3C; s : $55; c : $5F; a: $69),      {3C F2}
+   (n : $3D; s : $56; c : $60; a: $6A),      {3D F3}
+   (n : $3E; s : $57; c : $61; a: $6B),      {3E F4}
+   (n : $3F; s : $58; c : $62; a: $6C),      {3F F5}
+   (n : $40; s : $59; c : $63; a: $6D),      {40 F6}
+   (n : $41; s : $5A; c : $64; a: $6E),      {41 F7}
+   (n : $42; s : $5B; c : $65; a: $6F),      {42 F8}
+   (n : $43; s : $5C; c : $66; a: $70),      {43 F9}
+   (n : $44; s : $5D; c : $67; a: $71),      {44 F10}
+   (n : $45; s : $00; c : $00; a: $00),      {45 ???}
+   (n : $46; s : $00; c : $00; a: $00),      {46 ???}
+   (n : $47; s : $47; c : $77; a: $97),      {47 Home}
+   (n : $48; s : $00; c : $8D; a: $98),      {48 Up}
+   (n : $49; s : $49; c : $84; a: $99),      {49 PgUp}
+   (n : $4A; s : $00; c : $8E; a: $4A),      {4A -}
+   (n : $4B; s : $4B; c : $73; a: $9B),      {4B Left}
+   (n : $4C; s : $00; c : $00; a: $00),      {4C ???}
+   (n : $4D; s : $4D; c : $74; a: $9D),      {4D Right}
+   (n : $4E; s : $00; c : $90; a: $4E),      {4E +}
+   (n : $4F; s : $4F; c : $75; a: $9F),      {4F End}
+   (n : $50; s : $50; c : $91; a: $A0),      {50 Down}
+   (n : $51; s : $51; c : $76; a: $A1),      {51 PgDown}
+   (n : $52; s : $52; c : $92; a: $A2),      {52 Insert}
+   (n : $53; s : $53; c : $93; a: $A3),      {53 Del}
+   (n : $54; s : $00; c : $00; a: $00),      {54 ???}
+   (n : $55; s : $00; c : $00; a: $00),      {55 ???}
+   (n : $56; s : $00; c : $00; a: $00),      {56 ???}
+   (n : $85; s : $87; c : $89; a: $8B),      {57 F11}
+   (n : $86; s : $88; c : $8A; a: $8C));     {58 F12}
+
+ DosTT09 : ARRAY [$02..$0F] OF TTEntryT =
+  ((n : $00; s : $00; c : $00; a: $78),      {02 1 }
+   (n : $00; s : $00; c : $00; a: $79),      {03 2 }
+   (n : $00; s : $00; c : $00; a: $7A),      {04 3 }
+   (n : $00; s : $00; c : $00; a: $7B),      {05 4 }
+   (n : $00; s : $00; c : $00; a: $7C),      {06 5 }
+   (n : $00; s : $00; c : $00; a: $7D),      {07 6 }
+   (n : $00; s : $00; c : $00; a: $7E),      {08 7 }
+   (n : $00; s : $00; c : $00; a: $7F),      {09 8 }
+   (n : $00; s : $00; c : $00; a: $80),      {0A 9 }
+   (n : $00; s : $00; c : $00; a: $81),      {0B 0 }
+   (n : $00; s : $00; c : $00; a: $82),      {0C ß }
+   (n : $00; s : $00; c : $00; a: $00),      {0D}
+   (n : $00; s : $09; c : $00; a: $00),      {0E Backspace}
+   (n : $00; s : $0F; c : $94; a: $00));     {0F Tab }
+
+
+function translateKey (t : TKeyEventRecord) : TKeyEvent;
+var key : TKeyEvent;
+    ss  : byte;
+{$ifdef  USEKEYCODES}
+    ScanCode  : byte;
+{$endif  USEKEYCODES}
+    b   : byte;
+begin
+  Key := 0;
+  if t.bKeyDown then
+  begin
+    { ascii-char is <> 0 if not a specal key }
+    { we return it here otherwise we have to translate more later }
+    if t.AsciiChar <> #0 then
+    begin
+      {drivers needs scancode, we return it here as under dos and linux
+       with $03000000 = the lowest two bytes is the physical representation}
+{$ifdef  USEKEYCODES}
+      Scancode:=KeyToQwertyScan[t.wVirtualKeyCode AND $00FF];
+      If ScanCode>0 then
+        t.wVirtualScanCode:=ScanCode;
+      Key := byte (t.AsciiChar) + (t.wVirtualScanCode shl 8) + $03000000;
+      ss := transShiftState (t.dwControlKeyState);
+      key := key or (ss shl 16);
+      if (ss and kbAlt <> 0) and (t.dwControlKeyState and RIGHT_ALT_PRESSED = 0) then
+        key := key and $FFFFFF00;
+{$else not USEKEYCODES}
+      Key := byte (t.AsciiChar) + ((t.wVirtualScanCode AND $00FF) shl 8) + $03000000;
+{$endif not USEKEYCODES}
+    end else
+    begin
+{$ifdef  USEKEYCODES}
+      Scancode:=KeyToQwertyScan[t.wVirtualKeyCode AND $00FF];
+      If ScanCode>0 then
+        t.wVirtualScanCode:=ScanCode;
+{$endif not USEKEYCODES}
+      translateKey := 0;
+      { ignore shift,ctrl,alt,numlock,capslock alone }
+      case t.wVirtualKeyCode of
+        $0010,         {shift}
+        $0011,         {ctrl}
+        $0012,         {alt}
+        $0014,         {capslock}
+        $0090,         {numlock}
+        $0091,         {scrollock}
+        { This should be handled !! }
+        { these last two are OEM specific
+          this is not good !!! }
+        $00DC,         {^ : next key i.e. a is modified }
+        { Strange on my keyboard this corresponds to double point over i or u PM }
+        $00DD: exit;   {´ and ` : next key i.e. e is modified }
+      end;
+
+      key := $03000000 + (t.wVirtualScanCode shl 8);  { make lower 8 bit=0 like under dos }
+    end;
+    { Handling of ~ key as AltGr 2 }
+    { This is also French keyboard specific !! }
+    { but without this I can not get a ~ !! PM }
+    if (t.wVirtualKeyCode=$32) and
+       (KeyBoardLayout = FrenchKeyboard) and
+       (t.dwControlKeyState and RIGHT_ALT_PRESSED <> 0) then
+      key:=(key and $ffffff00) or ord('~');
+    { ok, now add Shift-State }
+    ss := transShiftState (t.dwControlKeyState);
+    key := key or (ss shl 16);
+
+    { Reset Ascii-Char if Alt+Key, fv needs that, may be we
+      need it for other special keys too
+      18 Sept 1999 AD: not for right Alt i.e. for AltGr+ß = \ on german keyboard }
+    if ((ss and kbAlt <> 0) and (t.dwControlKeyState and RIGHT_ALT_PRESSED = 0)) or
+    (*
+      { yes, we need it for cursor keys, 25=left, 26=up, 27=right,28=down}
+      {aggg, this will not work because esc is also virtualKeyCode 27!!}
+      {if (t.wVirtualKeyCode >= 25) and (t.wVirtualKeyCode <= 28) then}
+        no VK_ESCAPE is $1B !!
+        there was a mistake :
+         VK_LEFT is $25 not 25 !! *)
+       { not $2E VK_DELETE because its only the Keypad point !! PM }
+      (t.wVirtualKeyCode in [$21..$28,$2C,$2D,$2F]) then
+      { if t.wVirtualScanCode in [$47..$49,$4b,$4d,$4f,$50..$53] then}
+        key := key and $FFFFFF00;
+
+    {and translate to dos-scancodes to make fv happy, we will convert this
+     back in translateKeyEvent}
+
+     if (t.dwControlKeyState and RIGHT_ALT_PRESSED) = 0 then {not for alt-gr}
+     if (t.wVirtualScanCode >= low (DosTT)) and
+        (t.wVirtualScanCode <= high (dosTT)) then
+     begin
+       b := 0;
+       if (ss and kbAlt) <> 0 then
+         b := DosTT[t.wVirtualScanCode].a
+       else
+       if (ss and kbCtrl) <> 0 then
+         b := DosTT[t.wVirtualScanCode].c
+       else
+       if (ss and kbShift) <> 0 then
+         b := DosTT[t.wVirtualScanCode].s
+       else
+         b := DosTT[t.wVirtualScanCode].n;
+       if b <> 0 then
+         key := (key and $FFFF00FF) or (longint (b) shl 8);
+     end;
+
+     {Alt-0 to Alt-9}
+     if (t.dwControlKeyState and RIGHT_ALT_PRESSED) = 0 then {not for alt-gr}
+       if (t.wVirtualScanCode >= low (DosTT09)) and
+          (t.wVirtualScanCode <= high (dosTT09)) then
+       begin
+         b := 0;
+         if (ss and kbAlt) <> 0 then
+           b := DosTT09[t.wVirtualScanCode].a
+         else
+         if (ss and kbCtrl) <> 0 then
+           b := DosTT09[t.wVirtualScanCode].c
+         else
+         if (ss and kbShift) <> 0 then
+           b := DosTT09[t.wVirtualScanCode].s
+         else
+           b := DosTT09[t.wVirtualScanCode].n;
+         if b <> 0 then
+           key := (key and $FFFF0000) or (longint (b) shl 8);
+       end;
+
+     TranslateKey := key;
+  end;
+  translateKey := Key;
+end;
+
+function GetKeyEvent: TKeyEvent;
+var t   : TKeyEventRecord;
+    key : TKeyEvent;
+begin
+  if PendingKeyEvent<>0 then
+  begin
+    GetKeyEvent:=PendingKeyEvent;
+    PendingKeyEvent:=0;
+    exit;
+  end;
+  key := 0;
+  repeat
+     if getKeyEventFromQueueWait (t) then
+       key := translateKey (t);
+  until key <> 0;
+{$ifdef DEBUG}
+  last_ir.KeyEvent:=t;
+{$endif DEBUG}
+  GetKeyEvent := key;
+end;
+
+function PollKeyEvent: TKeyEvent;
+var t   : TKeyEventRecord;
+    k   : TKeyEvent;
+begin
+  if PendingKeyEvent<>0 then
+    exit(PendingKeyEvent);
+  PollKeyEvent := 0;
+  if getKeyEventFromQueue (t, true) then
+  begin
+    { we get an enty for shift, ctrl, alt... }
+    k := translateKey (t);
+    while (k = 0) do
+    begin
+      getKeyEventFromQueue (t, false);  {remove it}
+      if not getKeyEventFromQueue (t, true) then exit;
+      k := translateKey (t)
+    end;
+    PollKeyEvent := k;
+  end;
+end;
+
+
+function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+  if KeyEvent and $03000000 = $03000000 then
+   begin
+     if KeyEvent and $000000FF <> 0 then
+     begin
+       TranslateKeyEvent := KeyEvent and $00FFFFFF;
+       exit;
+     end;
+     {translate function-keys and other specials, ascii-codes are already ok}
+     case (KeyEvent AND $0000FF00) shr 8 of
+       {F1..F10}
+       $3B..$44     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $3B + $02000000;
+       {F11,F12}
+       $85..$86     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $85 + $02000000;
+       {Shift F1..F10}
+       $54..$5D     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $54 + $02000000;
+       {Shift F11,F12}
+       $87..$88     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $87 + $02000000;
+       {Alt F1..F10}
+       $68..$71     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $68 + $02000000;
+       {Alt F11,F12}
+       $8B..$8C     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $8B + $02000000;
+       {Ctrl F1..F10}
+       $5E..$67     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $5E + $02000000;
+       {Ctrl F11,F12}
+       $89..$8A     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $89 + $02000000;
+
+       {normal,ctrl,alt}
+       $47,$77,$97  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdHome + $02000000;
+       $48,$8D,$98  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdUp + $02000000;
+       $49,$84,$99  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgUp + $02000000;
+       $4b,$73,$9B  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdLeft + $02000000;
+       $4d,$74,$9D  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdRight + $02000000;
+       $4f,$75,$9F  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdEnd + $02000000;
+       $50,$91,$A0  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDown + $02000000;
+       $51,$76,$A1  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgDn + $02000000;
+       $52,$92,$A2  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdInsert + $02000000;
+       $53,$93,$A3  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDelete + $02000000;
+     else
+       TranslateKeyEvent := KeyEvent;
+     end;
+   end else
+     TranslateKeyEvent := KeyEvent;
+end;
+
+function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+  exit (KeyEvent);  {???}
+end;
+
+function PollShiftStateEvent: TKeyEvent;
+var t : TKeyEvent;
+begin
+  {may be better to save the last state and return that if no key is in buffer???}
+  t := lastShiftState;
+  PollShiftStateEvent := t shl 16;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:59  peter
+    * API 2 RTL commit
+
+}

rtl/win32/mouse.pp

@@ -0,0 +1,230 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Mouse unit for linux
+
+    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.
+
+ **********************************************************************}
+unit Mouse;
+interface
+
+const
+  MouseEventBufSize = 255;
+
+{$i mouseh.inc}
+
+implementation
+
+uses
+   windows,dos,Winevent;
+
+var
+   ChangeMouseEvents : TCriticalSection;
+Const
+  MouseEventActive : Boolean = false;
+
+procedure MouseEventHandler;
+
+  var
+     ir : INPUT_RECORD;
+     dwRead : DWord;
+     i: longint;
+     e : TMouseEvent;
+
+  begin
+     ReadConsoleInput(TextRec(Input).Handle,ir,1,dwRead);
+     if (dwRead=1) and (ir.EventType=_MOUSE_EVENT) then
+       begin
+          EnterCriticalSection(ChangeMouseEvents);
+          e.x:=ir.MouseEvent.dwMousePosition.x;
+          e.y:=ir.MouseEvent.dwMousePosition.y;
+          e.buttons:=0;
+          e.action:=0;
+          if (ir.MouseEvent.dwButtonState and FROM_LEFT_1ST_BUTTON_PRESSED<>0) then
+            e.buttons:=e.buttons or MouseLeftButton;
+          if (ir.MouseEvent.dwButtonState and FROM_LEFT_2ND_BUTTON_PRESSED<>0) then
+            e.buttons:=e.buttons or MouseMiddleButton;
+          if (ir.MouseEvent.dwButtonState and RIGHTMOST_BUTTON_PRESSED<>0) then
+            e.buttons:=e.buttons or MouseRightButton;
+
+          { can we compress the events? }
+          if (PendingMouseEvents>0) and
+            (e.buttons=PendingMouseTail^.buttons) and
+            (e.action=PendingMouseTail^.action) then
+            begin
+               PendingMouseTail^.x:=e.x;
+               PendingMouseTail^.y:=e.y;
+            end
+          else
+            begin
+               PutMouseEvent(e);
+               // this should be done in PutMouseEvent, now it is PM
+               // inc(PendingMouseEvents);
+            end;
+          LeaveCriticalSection(ChangeMouseEvents);
+       end;
+  end;
+
+procedure InitMouse;
+
+var
+   mode : dword;
+
+begin
+  if MouseEventActive then
+    exit;
+  // enable mouse events
+  GetConsoleMode(TextRec(Input).Handle,@mode);
+  mode:=mode or ENABLE_MOUSE_INPUT;
+  SetConsoleMode(TextRec(Input).Handle,mode);
+
+  PendingMouseHead:=@PendingMouseEvent;
+  PendingMouseTail:=@PendingMouseEvent;
+  PendingMouseEvents:=0;
+  FillChar(LastMouseEvent,sizeof(TMouseEvent),0);
+  InitializeCriticalSection(ChangeMouseEvents);
+  SetMouseEventHandler(@MouseEventHandler);
+  ShowMouse;
+  MouseEventActive:=true;
+end;
+
+
+procedure DoneMouse;
+var
+   mode : dword;
+begin
+  if not MouseEventActive then
+    exit;
+  HideMouse;
+  // disable mouse events
+  GetConsoleMode(TextRec(Input).Handle,@mode);
+  mode:=mode and (not ENABLE_MOUSE_INPUT);
+  SetConsoleMode(TextRec(Input).Handle,mode);
+
+  SetMouseEventHandler(nil);
+  DeleteCriticalSection(ChangeMouseEvents);
+  MouseEventActive:=false;
+end;
+
+
+function DetectMouse:byte;
+var
+  num : dword;
+begin
+  GetNumberOfConsoleMouseButtons(@num);
+  DetectMouse:=num;
+end;
+
+
+procedure ShowMouse;
+begin
+end;
+
+
+procedure HideMouse;
+begin
+end;
+
+
+function GetMouseX:word;
+begin
+  GetMouseX:=0;
+end;
+
+
+function GetMouseY:word;
+begin
+  GetMouseY:=0;
+end;
+
+
+function GetMouseButtons:word;
+begin
+  GetMouseButtons:=0;
+end;
+
+
+procedure SetMouseXY(x,y:word);
+begin
+end;
+
+
+procedure GetMouseEvent(var MouseEvent: TMouseEvent);
+
+var
+   b : byte;
+
+begin
+  repeat
+    EnterCriticalSection(ChangeMouseEvents);
+    b:=PendingMouseEvents;
+    LeaveCriticalSection(ChangeMouseEvents);
+    if b>0 then
+      break
+    else
+      sleep(50);
+  until false;
+  EnterCriticalSection(ChangeMouseEvents);
+  MouseEvent:=PendingMouseHead^;
+  inc(PendingMouseHead);
+  if longint(PendingMouseHead)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+   PendingMouseHead:=@PendingMouseEvent;
+  dec(PendingMouseEvents);
+  if (LastMouseEvent.x<>MouseEvent.x) or (LastMouseEvent.y<>MouseEvent.y) then
+   MouseEvent.Action:=MouseActionMove;
+  if (LastMouseEvent.Buttons<>MouseEvent.Buttons) then
+   begin
+     if (LastMouseEvent.Buttons=0) then
+      MouseEvent.Action:=MouseActionDown
+     else
+      MouseEvent.Action:=MouseActionUp;
+   end;
+  LastMouseEvent:=MouseEvent;
+  LeaveCriticalSection(ChangeMouseEvents);
+end;
+
+
+procedure PutMouseEvent(const MouseEvent: TMouseEvent);
+begin
+  if PendingMouseEvents<MouseEventBufSize then
+   begin
+     PendingMouseTail^:=MouseEvent;
+     inc(PendingMouseTail);
+     if longint(PendingMouseTail)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+      PendingMouseTail:=@PendingMouseEvent;
+      { why isn't this done here ?
+        so the win32 version do this by hand:}
+       inc(PendingMouseEvents);
+   end;
+end;
+
+
+function PollMouseEvent(var MouseEvent: TMouseEvent):boolean;
+begin
+  EnterCriticalSection(ChangeMouseEvents);
+  if PendingMouseEvents>0 then
+   begin
+     MouseEvent:=PendingMouseHead^;
+     PollMouseEvent:=true;
+   end
+  else
+   PollMouseEvent:=false;
+  LeaveCriticalSection(ChangeMouseEvents);
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:59  peter
+    * API 2 RTL commit
+
+}

rtl/win32/video.pp

@@ -0,0 +1,358 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Video unit for Win32
+
+    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.
+
+ **********************************************************************}
+unit Video;
+interface
+
+{$i videoh.inc}
+
+implementation
+
+uses
+  windows,dos;
+
+{$i video.inc}
+
+var
+  OldVideoBuf : PVideoBuf;
+  ConsoleInfo : TConsoleScreenBufferInfo;
+  ConsoleCursorInfo : TConsoleCursorInfo;
+  MaxVideoBufSize : DWord;
+
+procedure InitVideo;
+begin
+  ScreenColor:=true;
+  GetConsoleScreenBufferInfo(TextRec(Output).Handle, ConsoleInfo);
+  GetConsoleCursorInfo(TextRec(Output).Handle, ConsoleCursorInfo);
+
+  with ConsoleInfo.srWindow do
+    begin
+       ScreenWidth:=right-left+1;
+       ScreenHeight:=bottom-top+1;
+    end;
+
+  { srWindow is sometimes bigger then dwMaximumWindowSize
+    this led to wrong ScreenWidth and ScreenHeight values PM }
+  { damned: its also sometimes less !! PM }
+  with ConsoleInfo.dwMaximumWindowSize do
+    begin
+       {if ScreenWidth>X then}
+         ScreenWidth:=X;
+       {if ScreenHeight>Y then}
+         ScreenHeight:=Y;
+    end;
+
+  { TDrawBuffer only has FVMaxWidth elements
+    larger values lead to crashes }
+  if ScreenWidth> FVMaxWidth then
+    ScreenWidth:=FVMaxWidth;
+
+  CursorX:=ConsoleInfo.dwCursorPosition.x;
+  CursorY:=ConsoleInfo.dwCursorPosition.y;
+  if not ConsoleCursorInfo.bvisible then
+    CursorLines:=0
+  else
+    CursorLines:=ConsoleCursorInfo.dwSize;
+
+  { allocate back buffer }
+  MaxVideoBufSize:= ScreenWidth * ScreenHeight * 2;
+  VideoBufSize:=ScreenWidth*ScreenHeight*2;
+
+  GetMem(VideoBuf,MaxVideoBufSize);
+  GetMem(OldVideoBuf,MaxVideoBufSize);
+
+  {ClearScreen; not needed PM }
+end;
+
+
+procedure DoneVideo;
+begin
+  { ClearScreen; also not needed PM }
+  SetCursorType(crUnderLine);
+  { SetCursorPos(0,0); also not needed PM }
+  FreeMem(VideoBuf,MaxVideoBufSize);
+  FreeMem(OldVideoBuf,MaxVideoBufSize);
+  VideoBufSize:=0;
+end;
+
+
+function GetCapabilities: Word;
+begin
+  GetCapabilities:=cpColor or cpChangeCursor;
+end;
+
+
+procedure SetCursorPos(NewCursorX, NewCursorY: Word);
+var
+  pos : COORD;
+begin
+   pos.x:=NewCursorX;
+   pos.y:=NewCursorY;
+   SetConsoleCursorPosition(TextRec(Output).Handle,pos);
+   CursorX:=pos.x;
+   CursorY:=pos.y;
+end;
+
+
+function GetCursorType: Word;
+begin
+   GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
+   if not ConsoleCursorInfo.bvisible then
+     GetCursorType:=crHidden
+   else
+     case ConsoleCursorInfo.dwSize of
+        1..30:
+          GetCursorType:=crUnderline;
+        31..70:
+          GetCursorType:=crHalfBlock;
+        71..100:
+          GetCursorType:=crBlock;
+     end;
+end;
+
+
+procedure SetCursorType(NewType: Word);
+begin
+   GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
+   if newType=crHidden then
+     ConsoleCursorInfo.bvisible:=false
+   else
+     begin
+        ConsoleCursorInfo.bvisible:=true;
+        case NewType of
+           crUnderline:
+             ConsoleCursorInfo.dwSize:=10;
+
+           crHalfBlock:
+             ConsoleCursorInfo.dwSize:=50;
+
+           crBlock:
+             ConsoleCursorInfo.dwSize:=99;
+        end
+     end;
+   SetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
+end;
+
+
+function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean;
+begin
+end;
+
+
+procedure ClearScreen;
+begin
+  FillWord(VideoBuf^,VideoBufSize div 2,$0720);
+  UpdateScreen(true);
+end;
+
+
+{$IFDEF FPC}
+function WriteConsoleOutput(hConsoleOutput:HANDLE; lpBuffer:pointer; dwBufferSize:COORD; dwBufferCoord:COORD;
+   var lpWriteRegion:SMALL_RECT):WINBOOL; external 'kernel32' name 'WriteConsoleOutputA';
+{$ENDIF}
+
+procedure UpdateScreen(Force: Boolean);
+type TmpRec = Array[0..(1024*32) - 1] of TCharInfo;
+
+type WordRec = record
+                  One, Two: Byte;
+               end; { wordrec }
+
+var
+   BufSize,
+   BufCoord    : COORD;
+   WriteRegion : SMALL_RECT;
+   LineBuf     : ^TmpRec;
+   BufCounter  : Longint;
+   LineCounter,
+   ColCounter  : Longint;
+   smallforce  : boolean;
+{
+begin
+  if LockUpdateScreen<>0 then
+   exit;
+  if not force then
+   begin
+     asm
+        movl    VideoBuf,%esi
+        movl    OldVideoBuf,%edi
+        movl    VideoBufSize,%ecx
+        shrl    $2,%ecx
+        repe
+        cmpsl
+        setne   force
+     end;
+   end;
+  if Force then
+   begin
+      BufSize.X := ScreenWidth;
+      BufSize.Y := ScreenHeight;
+
+      BufCoord.X := 0;
+      BufCoord.Y := 0;
+      with WriteRegion do
+        begin
+           Top :=0;
+           Left :=0;
+           Bottom := ScreenHeight-1;
+           Right := ScreenWidth-1;
+        end;
+      New(LineBuf);
+      BufCounter := 0;
+
+      for LineCounter := 1 to ScreenHeight do
+        begin
+           for ColCounter := 1 to ScreenWidth do
+             begin
+               LineBuf^[BufCounter].UniCodeChar := WordRec(VideoBuf^[BufCounter]).One;
+               LineBuf^[BufCounter].Attributes := WordRec(VideoBuf^[BufCounter]).Two;
+
+               Inc(BufCounter);
+             end; { for }
+        end; { for }
+
+      WriteConsoleOutput(TextRec(Output).Handle, LineBuf, BufSize, BufCoord, WriteRegion);
+      Dispose(LineBuf);
+
+      move(VideoBuf^,OldVideoBuf^,VideoBufSize);
+   end;
+end;
+}
+var
+   x1,y1,x2,y2 : longint;
+
+begin
+  if LockUpdateScreen<>0 then
+   exit;
+  if force then
+   smallforce:=true
+  else
+   begin
+     asm
+        movl    VideoBuf,%esi
+        movl    OldVideoBuf,%edi
+        movl    VideoBufSize,%ecx
+        shrl    $2,%ecx
+        repe
+        cmpsl
+        orl     %ecx,%ecx
+        jz      .Lno_update
+        movb    $1,smallforce
+.Lno_update:
+     end;
+   end;
+  if SmallForce then
+   begin
+      BufSize.X := ScreenWidth;
+      BufSize.Y := ScreenHeight;
+
+      BufCoord.X := 0;
+      BufCoord.Y := 0;
+      with WriteRegion do
+        begin
+           Top :=0;
+           Left :=0;
+           Bottom := ScreenHeight-1;
+           Right := ScreenWidth-1;
+        end;
+      New(LineBuf);
+      BufCounter := 0;
+      x1:=ScreenWidth+1;
+      x2:=-1;
+      y1:=ScreenHeight+1;
+      y2:=-1;
+      for LineCounter := 1 to ScreenHeight do
+        begin
+           for ColCounter := 1 to ScreenWidth do
+             begin
+               if (WordRec(VideoBuf^[BufCounter]).One<>WordRec(OldVideoBuf^[BufCounter]).One) or
+                 (WordRec(VideoBuf^[BufCounter]).Two<>WordRec(OldVideoBuf^[BufCounter]).Two) then
+                 begin
+                    if ColCounter<x1 then
+                      x1:=ColCounter;
+                    if ColCounter>x2 then
+                      x2:=ColCounter;
+                    if LineCounter<y1 then
+                      y1:=LineCounter;
+                    if LineCounter>y2 then
+                      y2:=LineCounter;
+                 end;
+               LineBuf^[BufCounter].UniCodeChar := WordRec(VideoBuf^[BufCounter]).One;
+               { If (WordRec(VideoBuf^[BufCounter]).Two and $80)<>0 then
+                 LineBuf^[BufCounter].Attributes := $100+WordRec(VideoBuf^[BufCounter]).Two
+               else }
+                 LineBuf^[BufCounter].Attributes := WordRec(VideoBuf^[BufCounter]).Two;
+
+               Inc(BufCounter);
+             end; { for }
+        end; { for }
+      BufSize.X := ScreenWidth;
+      BufSize.Y := ScreenHeight;
+
+      with WriteRegion do
+        begin
+           if force then
+             begin
+               Top := 0;
+               Left :=0;
+               Bottom := ScreenHeight-1;
+               Right := ScreenWidth-1;
+               BufCoord.X := 0;
+               BufCoord.Y := 0;
+             end
+           else
+             begin
+               Top := y1-1;
+               Left :=x1-1;
+               Bottom := y2-1;
+               Right := x2-1;
+               BufCoord.X := x1-1;
+               BufCoord.Y := y1-1;
+             end;
+        end;
+      {
+      writeln('X1: ',x1);
+      writeln('Y1: ',y1);
+      writeln('X2: ',x2);
+      writeln('Y2: ',y2);
+      }
+      WriteConsoleOutput(TextRec(Output).Handle, LineBuf, BufSize, BufCoord, WriteRegion);
+      Dispose(LineBuf);
+
+      move(VideoBuf^,OldVideoBuf^,VideoBufSize);
+   end;
+end;
+
+procedure RegisterVideoModes;
+begin
+  { don't know what to do for win32 (FK) }
+  RegisterVideoMode(80, 25, True, @DefaultVideoModeSelector, $00000003);
+end;
+
+
+initialization
+  RegisterVideoModes;
+
+finalization
+  UnRegisterVideoModes;
+end.
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:59  peter
+    * API 2 RTL commit
+
+}
+

rtl/win32/winevent.pp

@@ -0,0 +1,322 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Florian Klaempfl
+    member of the Free Pascal development team
+
+    Event Handling unit for setting Keyboard and Mouse Handlers
+
+    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.
+
+ **********************************************************************}
+unit WinEvent;
+interface
+
+{
+   We need this unit to implement keyboard and mouse,
+   because win32 uses only one message queue for mouse and key events
+}
+
+    type
+       TEventProcedure = Procedure;
+
+    { these procedures must be used to set the event handlers }
+    { these doesn't do something, they signal only the        }
+    { the upper layer that an event occured, this event       }
+    { must be handled with Win32-API function by the upper    }
+    { layer                                                   }
+    Procedure SetMouseEventHandler(p : TEventProcedure);
+    Procedure SetKeyboardEventHandler(p : TEventProcedure);
+    Procedure SetFocusEventHandler(p : TEventProcedure);
+    Procedure SetMenuEventHandler(p : TEventProcedure);
+    Procedure SetResizeEventHandler(p : TEventProcedure);
+    Procedure SetUnknownEventHandler(p : TEventProcedure);
+
+    { these procedures must be used to get the event handlers }
+    Function GetMouseEventHandler : TEventProcedure;
+    Function GetKeyboardEventHandler : TEventProcedure;
+    Function GetFocusEventHandler : TEventProcedure;
+    Function GetMenuEventHandler : TEventProcedure;
+    Function GetResizeEventHandler : TEventProcedure;
+    Function GetUnknownEventHandler : TEventProcedure;
+
+  implementation
+
+    uses
+       windows, dos;
+
+    const
+       { these procedures are called if an event occurs }
+       MouseEventHandler : procedure = nil;
+       KeyboardEventHandler : procedure = nil;
+       FocusEventHandler : procedure = nil;
+       MenuEventHandler : procedure = nil;
+       ResizeEventHandler : procedure = nil;
+       UnknownEventHandler  : procedure = nil;
+
+       { if this counter is zero, the event handler thread is killed }
+       InstalledHandlers : Byte = 0;
+
+    var
+       HandlerChanging : TCriticalSection;
+       OldExitProc : Pointer;
+       EventThreadHandle : Handle;
+       EventThreadID : DWord;
+
+       { true, if the event handler should be stoped }
+       ExitEventHandleThread : boolean;
+
+    Function GetMouseEventHandler : TEventProcedure;
+      begin
+         GetMouseEventHandler:=MouseEventHandler;
+      end;
+
+
+    Function GetKeyboardEventHandler : TEventProcedure;
+      begin
+         GetKeyboardEventHandler:=KeyboardEventHandler;
+      end;
+
+
+    Function GetFocusEventHandler : TEventProcedure;
+      begin
+         GetFocusEventHandler:=FocusEventHandler;
+      end;
+
+
+    Function GetMenuEventHandler : TEventProcedure;
+      begin
+         GetMenuEventHandler:=MenuEventHandler;
+      end;
+
+
+    Function GetResizeEventHandler : TEventProcedure;
+      begin
+         GetResizeEventHandler:=ResizeEventHandler;
+      end;
+
+
+    Function GetUnknownEventHandler : TEventProcedure;
+      begin
+         GetUnknownEventHandler:=UnknownEventHandler;
+      end;
+
+    { removes an event from the event queue }
+    { necessary, if no handler is installed }
+    Procedure DestroyOneEvent;
+      var
+         ir : TInputRecord;
+         dwRead : DWord;
+      begin
+         ReadConsoleInput(TextRec(Input).Handle,ir,1,dwRead);
+      end;
+
+    Function EventHandleThread(p : pointer) : DWord;StdCall;
+      var
+         ir : TInputRecord;
+         dwRead : DWord;
+      begin
+         while not(ExitEventHandleThread) do
+           begin
+              { wait for an event }
+              WaitForSingleObject(TextRec(Input).Handle,INFINITE);
+              { guard this code, else it is doomed to crash, if the
+                thread is switched between the assigned test and
+                the call and the handler is removed
+              }
+              if not(ExitEventHandleThread) then
+                begin
+                   EnterCriticalSection(HandlerChanging);
+                   { read, but don't remove the event }
+                   if (PeekConsoleInput(TextRec(Input).Handle,ir,1,dwRead)) and
+                     (dwRead>0) then
+                     { call the handler }
+                     case ir.EventType of
+                        KEY_EVENT:
+                          begin
+                             if assigned(KeyboardEventHandler) then
+                               KeyboardEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        _MOUSE_EVENT:
+                          begin
+                             if assigned(MouseEventHandler) then
+                               MouseEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        WINDOW_BUFFER_SIZE_EVENT:
+                          begin
+                             if assigned(ResizeEventHandler) then
+                               ResizeEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        MENU_EVENT:
+                          begin
+                             if assigned(MenuEventHandler) then
+                               MenuEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        FOCUS_EVENT:
+                          begin
+                             if assigned(FocusEventHandler) then
+                               FocusEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        else
+                          begin
+                             if assigned(UnknownEventHandler) then
+                               UnknownEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+                     end;
+                   LeaveCriticalSection(HandlerChanging);
+                end;
+           end;
+      end;
+
+    Procedure NewEventHandlerInstalled(p,oldp : TEventProcedure);
+      var
+         oldcount : Byte;
+         ir : TInputRecord;
+         written : DWord;
+      begin
+         oldcount:=InstalledHandlers;
+         if Pointer(oldp)<>nil then
+           dec(InstalledHandlers);
+         if Pointer(p)<>nil then
+           inc(InstalledHandlers);
+         { start event handler thread }
+         if (oldcount=0) and (InstalledHandlers=1) then
+           begin
+              ExitEventHandleThread:=false;
+              EventThreadHandle:=CreateThread(nil,0,@EventHandleThread,
+                nil,0,EventThreadID);
+           end
+         { stop and destroy event handler thread }
+         else if (oldcount=1) and (InstalledHandlers=0) then
+           begin
+              ExitEventHandleThread:=true;
+              { create a dummy event and sent it to the thread, so
+                we can leave WatiForSingleObject }
+              ir.EventType:=KEY_EVENT;
+              { mouse event can be disabled by mouse.inc code
+                in DoneMouse
+                so use a key event instead PM }
+              WriteConsoleInput(TextRec(Input).Handle,ir,1,written);
+              { wait, til the thread is ready }
+              WaitForSingleObject(EventThreadHandle,INFINITE);
+              CloseHandle(EventThreadHandle);
+           end;
+      end;
+
+
+    Procedure SetMouseEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=MouseEventHandler;
+         MouseEventHandler:=p;
+         NewEventHandlerInstalled(MouseEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetKeyboardEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=KeyboardEventHandler;
+         KeyboardEventHandler:=p;
+         NewEventHandlerInstalled(KeyboardEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetFocusEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=FocusEventHandler;
+         FocusEventHandler:=p;
+         NewEventHandlerInstalled(FocusEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetMenuEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=MenuEventHandler;
+         MenuEventHandler:=p;
+         NewEventHandlerInstalled(MenuEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetResizeEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=ResizeEventHandler;
+         ResizeEventHandler:=p;
+         NewEventHandlerInstalled(ResizeEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetUnknownEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=UnknownEventHandler;
+         UnknownEventHandler:=p;
+         NewEventHandlerInstalled(UnknownEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+initialization
+   InitializeCriticalSection(HandlerChanging);
+
+finalization
+  { Uninstall all handlers                   }
+  { this stops also the event handler thread }
+  SetMouseEventHandler(nil);
+  SetKeyboardEventHandler(nil);
+  SetFocusEventHandler(nil);
+  SetMenuEventHandler(nil);
+  SetResizeEventHandler(nil);
+  SetUnknownEventHandler(nil);
+  { delete the critical section object }
+  DeleteCriticalSection(HandlerChanging);
+end.
+
+{
+  $Log$
+  Revision 1.1  2001-01-13 11:03:59  peter
+    * API 2 RTL commit
+
+}