diff options
Diffstat (limited to 'rtl/aros/keyboard.pp')
| -rw-r--r-- | rtl/aros/keyboard.pp | 469 |
1 files changed, 469 insertions, 0 deletions
diff --git a/rtl/aros/keyboard.pp b/rtl/aros/keyboard.pp new file mode 100644 index 0000000000..16e714f4e5 --- /dev/null +++ b/rtl/aros/keyboard.pp @@ -0,0 +1,469 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2006 by Karoly Balogh + + Keyboard unit for MorphOS and Amiga and AROS + + 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 + video, exec,intuition, inputevent, mouse, sysutils, keymap; + +{$i keyboard.inc} +{$i keyscan.inc} +var + LastShiftState : Byte; {set by handler for PollShiftStateEvent} + OldMouseX : LongInt; + OldmouseY : LongInt; + OldButtons: Word; + +procedure SysInitKeyboard; +begin +// writeln('sysinitkeyboard'); + LastShiftState := 0; + OldMouseX := -1; + OldmouseY := -1; + OldButtons := 0; +end; + +procedure SysDoneKeyboard; +begin + +end; + +function IsMsgPortEmpty(Port: PMsgPort): Boolean; inline; +begin + IsMsgPortEmpty := (Port^.mp_MsgList.lh_TailPred = @(Port^.mp_MsgList)); +end; + +var + KeyQueue: TKeyEvent; + +type + RawCodeEntry = record + rc,n,s,c,a : Word; { raw code, normal, shift, ctrl, alt } + end; + +const + RCTABLE_MAXIDX = 24; + RawCodeTable : array[0..RCTABLE_MAXIDX] of RawCodeEntry = + ( + (rc: 66; n: $0F09; s: $0F00; c: $9400; a: $A500; ), // TAB + (rc: 68; n: $1C0D; s: $1C0D; c: $1C0A; a: $1C0D; ), // Enter // shift, alt? + (rc: 69; n: $011B; s: $011B; c: $011B; a: $0100; ), // ESC // shift? + (rc: 70; n: $5300; s: $0700; c: $A300; a: $A200; ), // Delete + (rc: 71; n: $5200; s: $0500; c: $0400; a: $A200; ), // Insert + (rc: 72; n: $4900; s: $4900; c: $8400; a: $9900; ), // PgUP // shift? + (rc: 73; n: $5100; s: $5100; c: $7600; a: $A100; ), // PgDOWN // shift? + + (rc: 76; n: $4800; s: $4800; c: $8D00; a: $9800; ), // UP // shift? + (rc: 77; n: $5000; s: $5000; c: $9100; a: $A000; ), // DOWN // shift? + (rc: 78; n: $4D00; s: $4D00; c: $7400; a: $9D00; ), // RIGHT // shift? + (rc: 79; n: $4B00; s: $4B00; c: $7300; a: $9B00; ), // LEFT // shift? + + (rc: 80; n: $3B00; s: $5400; c: $5E00; a: $6800; ), // F1 + (rc: 81; n: $3C00; s: $5500; c: $5F00; a: $6900; ), // F2 + (rc: 82; n: $3D00; s: $5600; c: $6000; a: $6A00; ), // F3 + (rc: 83; n: $3E00; s: $5700; c: $6100; a: $6B00; ), // F4 + (rc: 84; n: $3F00; s: $5800; c: $6200; a: $6C00; ), // F5 + (rc: 85; n: $4000; s: $5900; c: $6300; a: $6D00; ), // F6 + (rc: 86; n: $4100; s: $5A00; c: $6400; a: $6E00; ), // F7 + (rc: 87; n: $4200; s: $5B00; c: $6500; a: $6F00; ), // F8 + (rc: 88; n: $4300; s: $5C00; c: $6600; a: $7000; ), // F9 + (rc: 89; n: $4400; s: $5D00; c: $6700; a: $7100; ), // F10 + (rc: 75; n: $8500; s: $8700; c: $8900; a: $8B00; ), // F11 + (rc: 76; n: $8600; s: $8800; c: $8A00; a: $8C00; ), // F12 + + (rc: 112; n: $4700; s: $4700; c: $7700; a: $9700; ),// Home // shift? + (rc: 113; n: $4F00; s: $4F00; c: $7500; a: $9F00; ) // End // shift? + ); + +function rcTableIdx(rc: LongInt): LongInt; +var + Counter: LongInt; +begin + rcTableIdx := -1; + Counter := 0; + while (RawCodeTable[Counter].rc <> rc) and (Counter <= RCTABLE_MAXIDX) do + Inc(Counter); + if (Counter <= RCTABLE_MAXIDX) then + rcTableIdx := Counter; +end; + +function HasShift(IQual: Word): Boolean; inline; +begin + HasShift := ((IQual and IEQUALIFIER_LSHIFT) <> 0) or + ((IQual and IEQUALIFIER_RSHIFT) <> 0); +end; + +function HasCtrl(IQual: Word): Boolean; inline; +begin + HasCtrl := ((IQual and IEQUALIFIER_CONTROL) <> 0); +end; + +function HasAlt(IQual: Word): Boolean; inline; +begin + HasAlt := ((IQual and IEQUALIFIER_LALT) <> 0) or + ((IQual and IEQUALIFIER_RALT) <> 0); +end; + +function rcTableCode(IQual: Word; Idx: LongInt): LongInt; +begin + if (Idx < 0) or (Idx > RCTABLE_MAXIDX) then + begin + rcTableCode := -1; + Exit; + end; + + if HasShift(IQual) then + rcTableCode:=RawCodeTable[Idx].s + else + if HasCtrl(IQual) then + rcTableCode:=RawCodeTable[Idx].c + else + if HasAlt(IQual) then + rcTableCode:=RawCodeTable[Idx].a + else + rcTableCode:=RawCodeTable[Idx].n; +end; + +procedure setShiftState(IQual: Word); +begin + LastShiftState := 0; + if ((IQual and IEQUALIFIER_LSHIFT) <> 0) then + LastShiftState := LastShiftState or $01; + if ((IQual and IEQUALIFIER_RSHIFT) <> 0) then + LastShiftState := LastShiftState or $02; + if HasCtrl(IQual) then + LastShiftState := LastShiftState or $04; + if HasAlt(IQual) then + LastShiftState := LastShiftState or $08; + if ((IQual and IEQUALIFIER_NUMERICPAD) <> 0) then + LastShiftState := LastShiftState or $20; + if ((IQual and IEQUALIFIER_CAPSLOCK) <> 0) then + LastShiftState := LastShiftState or $40; +end; + +function SysPollKeyEvent: TKeyEvent; +var + MouseEvent: Boolean; // got a mouseevent -> do not leave cycle + SendMouse: Boolean; // we got a (or many) mouse move send the last one + mes: TMouseEvent; // save mouse message send after cycle -> prevent mouse move stacking + me: TMouseEvent; + KeyCode: LongInt; + OldKeyCode: LongInt; + KeySet: ^TKeyRecord; // points to result to set fields directly + Ret: LongInt; + // + iMsg: PIntuiMessage; + ICode: Word; // save items from Message + IQual: Word; + IClass: Longword; + MouseX: Integer; + MouseY: Integer; + KeyUp: Boolean; // Event is a key up event + Buff: array[0..19] of Char; + ie: TInputEvent; // for mapchar +begin + KeyCode := 0; + SysPollKeyEvent := 0; + KeySet := @SysPollKeyEvent; + FillChar(me, SizeOf(TMouseEvent), 0); + + if KeyQueue <> 0 then + begin + SysPollKeyEvent := KeyQueue; + Exit; + end; + SendMouse := False; + repeat + MouseEvent := False; + if VideoWindow <> nil then + begin + if IsMsgPortEmpty(videoWindow^.UserPort) then + Break; + end else + Exit; + PMessage(iMsg) := GetMsg(VideoWindow^.UserPort); + if (iMsg <> nil) then + begin + ICode := iMsg^.Code; + IQual := iMsg^.Qualifier; + IClass := iMsg^.iClass; + MouseX := iMsg^.MouseX; + MouseY := iMsg^.MouseY; + ReplyMsg(PMessage(iMsg)); // fast reply to system + SetShiftState(IQual); // set Shift state qualifiers. do this for all messages we get. + // main event case + case (IClass) of + IDCMP_CLOSEWINDOW: begin + GotCloseWindow; + end; + IDCMP_CHANGEWINDOW: begin + GotResizeWindow; + end; + IDCMP_MOUSEBUTTONS: begin + MouseEvent := True; + me.x := (MouseX - videoWindow^.BorderLeft) div 8; // calculate char position + me.y := (MouseY - videoWindow^.BorderTop) div 16; + case ICode of + SELECTDOWN: begin + //writeln('left down!'); + me.Action := MouseActionDown; + OldButtons := OldButtons or MouseLeftButton; + me.Buttons := OldButtons; + PutMouseEvent(me); + end; + SELECTUP: begin + //writeln('left up!'); + me.Action := MouseActionUp; + OldButtons := OldButtons and (not MouseLeftButton); + me.Buttons := OldButtons; + PutMouseEvent(me); + end; + MENUDOWN: begin + //writeln('right down!'); + me.Action := MouseActionDown; + OldButtons := OldButtons or MouseRightButton; + me.Buttons := OldButtons; + PutMouseEvent(me); + end; + MENUUP: begin + //writeln('right up!'); + me.Action := MouseActionUp; + OldButtons := OldButtons and (not MouseRightButton); + me.Buttons := OldButtons; + PutMouseEvent(me); + end; + end; + //writeln('Buttons: ' , me.Buttons); + end; + IDCMP_MOUSEMOVE: begin + MouseX := (MouseX - VideoWindow^.BorderLeft) div 8; + MouseY := (MouseY - VideoWindow^.BorderTop) div 16; + if (MouseX >= 0) and (MouseY >= 0) and + (MouseX < Video.ScreenWidth) and (MouseY < Video.ScreenHeight) and + ((MouseX <> OldMouseX) or (MouseY <> OldmouseY)) + then begin +// //writeln('mousemove:',Mousex,'/',Mousey,' oldbutt:',OldButtons); + // Drawing is very slow so when moving window it will drag behind + // because the mouse events stack in the messageport + // -> so we override move until messageport is empty or keyevent is fired + SendMouse := True; + MouseEvent := True; + mes.Action := MouseActionMove; + mes.Buttons := OldButtons; + mes.X := MouseX; + mes.Y := MouseY; + //PutMouseEvent(me); + end; + end; + IDCMP_RAWKEY: begin + // mouse wheel up or down -> pgup and pgdown + if ICode = 122 then + ICode := 72; + if ICode = 123 then + ICode := 73; + // get char from rawkey + KeyUp := (ICode and IECODE_UP_PREFIX) <> 0; // is key up + ICode := ICode and not IECODE_UP_PREFIX; // remove key up from ICode + ie.ie_Class := IECLASS_RAWKEY; + ie.ie_SubClass := 0; + ie.ie_Code := ICode; + ie.ie_Qualifier := IQual; + ie.ie_NextEvent := nil; + Buff[0] := #0; + Ret := MapRawKey(@ie, @Buff[0], 1, nil); + KeyCode := Ord(Buff[0]); + KeySet^.KeyCode := Ord(Buff[0]); // if maprawkey does not work it still is 0 + KeySet^.ShiftState := LastShiftState; // shift state set before the case + KeySet^.Flags := 0; + if keyup then // we do not need key up events up to now + begin + KeySet^.Flags := KeySet^.Flags or kbReleased; // kbReleased does work but make strange effects + SysPollKeyEvent := 0; + Exit; + end; + // check our hard coed list if there is an entry -> leave it must be right ;) + // F-keys, cursor, esc, del, ins, del, pgup, pgdown, pos, end, enter, tab + if rcTableCode(IQual,rcTableIdx(ICode)) >= 0 then + begin + KeyCode := rcTableCode(IQual,rcTableIdx(ICode)); + KeySet^.KeyCode := KeyCode; + KeySet^.Flags := kbPhys; + end else + begin + // left alt or ctrl is pressed -> check for alternative Scancode -> commando + if ((IQual and IEQUALIFIER_LALT) <> 0) or HasCtrl(IQual) then + begin + OldKeyCode := KeyCode; // save keycode if nothing found + KeyCode := 0; + ie.ie_Class := IECLASS_RAWKEY; // get keycode without qualifier easier case + ie.ie_SubClass := 0; + ie.ie_Code := ICode; + ie.ie_Qualifier := 0; + ie.ie_NextEvent := nil; + Buff[0] := #0; + Ret := MapRawKey(@ie, @Buff[0], 1, nil); + if Ret > 0 then + begin + if ((IQual and IEQUALIFIER_LALT) <> 0) then // check left alt keycodes + begin + case Buff[0] of // Alt - keys already defined + 'a': KeyCode := kbAltA shl 8; + 'b': KeyCode := kbAltB shl 8; + 'c': KeyCode := kbAltC shl 8; + 'd': KeyCode := kbAltD shl 8; + 'e': KeyCode := kbAltE shl 8; + 'f': KeyCode := kbAltF shl 8; + 'g': KeyCode := kbAltG shl 8; + 'h': KeyCode := kbAltH shl 8; + 'i': KeyCode := kbAltI shl 8; + 'j': KeyCode := kbAltJ shl 8; + 'k': KeyCode := kbAltK shl 8; + 'l': KeyCode := kbAltL shl 8; + 'm': KeyCode := kbAltM shl 8; + 'n': KeyCode := kbAltN shl 8; + 'o': KeyCode := kbAltO shl 8; + 'p': KeyCode := kbAltP shl 8; + 'q': KeyCode := kbAltQ shl 8; + 'r': KeyCode := kbAltR shl 8; + 's': KeyCode := kbAltS shl 8; + 't': KeyCode := kbAltT shl 8; + 'u': KeyCode := kbAltU shl 8; + 'v': KeyCode := kbAltV shl 8; + 'w': KeyCode := kbAltW shl 8; + 'x': KeyCode := kbAltX shl 8; + 'y': KeyCode := kbAltY shl 8; + 'z': KeyCode := kbAltZ shl 8; + end; + end else + begin + case Buff[0] of // ctrl - keys defined in FreeVision/drivers.pas -> so here direct numbers + 'a': KeyCode := $1E01; + 'b': KeyCode := $3002; + 'c': KeyCode := $2E03; + 'd': KeyCode := $2004; + 'e': KeyCode := $1205; + 'f': KeyCode := $2106; + 'g': KeyCode := $2207; + 'h': KeyCode := $2308; + 'i': KeyCode := $1709; + 'j': KeyCode := $240a; + 'k': KeyCode := $250b; + 'l': KeyCode := $260c; + 'm': KeyCode := $320d; + 'n': KeyCode := $310e; + 'o': KeyCode := $180f; + 'p': KeyCode := $1910; + 'q': KeyCode := $1011; + 'r': KeyCode := $1312; + 's': KeyCode := $1F13; + 't': KeyCode := $1414; + 'u': KeyCode := $1615; + 'v': KeyCode := $2F16; + 'w': KeyCode := $1117; + 'x': KeyCode := $2D18; + 'y': KeyCode := $1519; + 'z': KeyCode := $2C1A; + end; + end; + end; + if KeyCode <= 0 then // nothing found restore keycode + KeyCode := OldKeyCode; + KeySet^.KeyCode := KeyCode; + KeySet^.Flags := kbPhys; + end; + end; + if keycode <= 0 then + begin + KeySet^.KeyCode := 0; + KeyCode := 0; + end; + //writeln('raw keycode: ',iMsg^.code, ' -> $', IntToHex(keycode,4), ' ret: ', ret); + end; + else begin + KeyCode := 0; + end; + end; + end else + Break; + until (not MouseEvent); + // + if SendMouse then + begin + PutMouseEvent(mes); + OldMouseX:=Mousex; + OldmouseY:=Mousey; + end; + if KeyCode <= 0 then // no keycode found then also delete flags and shiftstate + SysPollKeyEvent := 0 + else + KeyQueue:=SysPollKeyEvent; +end; + +function SysGetKeyEvent: TKeyEvent; +var + Res: TKeyEvent; + me: TMouseEvent; +begin + Res := 0; + if VideoWindow <> nil then + begin + if KeyQueue <> 0 then + begin + SysGetKeyEvent := KeyQueue; + KeyQueue := 0; + Exit; + end; + repeat + WaitPort(VideoWindow^.UserPort); + Res := SysPollKeyEvent; + until Res <> 0; + end else + begin + me.Action := MouseActionDown; + me.Buttons := MouseRightButton; + PutMouseEvent(me); + end; + SysGetKeyEvent := Res; +end; + +{function SysTranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent; +begin +end;} + +function SysGetShiftState: Byte; +begin + //writeln('SysgetShiftState:',hexstr(LastShiftState,2)); + SysGetShiftState := LastShiftState; +end; + +const + SysKeyboardDriver : TKeyboardDriver = ( + InitDriver : @SysInitKeyBoard; + DoneDriver : @SysDoneKeyBoard; + GetKeyevent : @SysGetKeyEvent; + PollKeyEvent : @SysPollKeyEvent; + GetShiftState : @SysGetShiftState; +// TranslateKeyEvent : @SysTranslateKeyEvent; + TranslateKeyEvent : Nil; + TranslateKeyEventUnicode : Nil; + ); + +begin + SetKeyBoardDriver(SysKeyBoardDriver); +end. |