Implement Qt mouse yank primary
ober
c1b5861e27a0d1cb1b16d7c232e4c678f458902c
--- a/src/jerboa-emacs/qt/app.ss +++ b/src/jerboa-emacs/qt/app.ss @@ -867,22 +867,25 @@ (qt-on-mouse-press! editor (lambda () (with-key-handler-errors app - (when (= (qt-last-mouse-button) QT_MOUSE_LEFT) - (let* ((fr (app-state-frame app)) - (widget (qt-last-mouse-widget)) - (x (qt-last-mouse-x)) - (y (qt-last-mouse-y)) - (pos (sci-send editor SCI_POSITIONFROMPOINT x y))) - (let loop ((wins (qt-frame-windows fr)) (idx 0)) - (cond - ((null? wins) (void)) - ((eq? editor (qt-edit-window-editor (car wins))) - (set! (qt-frame-current-idx fr) idx)) - (else (loop (cdr wins) (+ idx 1))))) - (when (and (eq? widget editor) (>= pos 0)) - (qt-plain-text-edit-set-cursor-position! editor pos)) - (qt-widget-set-focus! editor) - (qt-refresh-after-key! app (app-state-echo app) "mouse-press")))))))) + (let ((button (qt-last-mouse-button))) + (when (or (= button QT_MOUSE_LEFT) (= button QT_MOUSE_MIDDLE)) + (let* ((fr (app-state-frame app)) + (widget (qt-last-mouse-widget)) + (x (qt-last-mouse-x)) + (y (qt-last-mouse-y)) + (pos (sci-send editor SCI_POSITIONFROMPOINT x y))) + (let loop ((wins (qt-frame-windows fr)) (idx 0)) + (cond + ((null? wins) (void)) + ((eq? editor (qt-edit-window-editor (car wins))) + (set! (qt-frame-current-idx fr) idx)) + (else (loop (cdr wins) (+ idx 1))))) + (when (and (eq? widget editor) (>= pos 0)) + (qt-plain-text-edit-set-cursor-position! editor pos)) + (qt-widget-set-focus! editor) + (when (= button QT_MOUSE_MIDDLE) + (execute-command! app 'mouse-yank-primary)) + (qt-refresh-after-key! app (app-state-echo app) "mouse-press"))))))))) (def (qt-refresh-after-key! app echo-label origin) (let* ((fr (app-state-frame app)) (trace? (eq? (buffer-lexer-lang (qt-current-buffer fr)) 'dired))) --- a/src/jerboa-emacs/qt/commands-core.ss +++ b/src/jerboa-emacs/qt/commands-core.ss @@ -983,6 +983,21 @@ Returns #t if changed, #f if not or if no record exists." (set! (app-state-last-yank-len app) (- pos-after pos-before)) (set! (app-state-kill-ring-idx app) 0)))) +(def (cmd-mouse-yank-primary app) + "Yank PRIMARY-style text at point, using the clipboard then kill ring." + (let* ((ed (current-qt-editor app)) + (text (qt-clipboard-or-kill-ring app))) + (if (and (string? text) (> (string-length text) 0)) + (let ((pos-before (qt-plain-text-edit-cursor-position ed))) + (when (qt-plain-text-edit-has-selection? ed) + (qt-plain-text-edit-remove-selected-text! ed)) + (qt-plain-text-edit-insert-text! ed text) + (set! (app-state-last-yank-pos app) pos-before) + (set! (app-state-last-yank-len app) (string-length text)) + (set! (app-state-kill-ring-idx app) 0) + (echo-message! (app-state-echo app) "Yanked primary selection")) + (echo-error! (app-state-echo app) "No primary selection or clipboard text")))) + ;;;============================================================================ ;;; Mark and region ;;;============================================================================ --- a/src/jerboa-emacs/qt/commands.ss +++ b/src/jerboa-emacs/qt/commands.ss @@ -1288,6 +1288,7 @@ ;; Kill/Yank (register-command! 'kill-line cmd-kill-line) (register-command! 'yank cmd-yank) + (register-command! 'mouse-yank-primary cmd-mouse-yank-primary) ;; Mark/Region (register-command! 'set-mark cmd-set-mark) (register-command! 'set-mark-command cmd-set-mark) ; Emacs alias --- a/src/jerboa-emacs/qt/sci-shim.ss +++ b/src/jerboa-emacs/qt/sci-shim.ss @@ -76,7 +76,7 @@ ;; Key and mouse events qt-last-key-code qt-last-key-modifiers qt-last-key-text qt-last-key-autorepeat? qt-last-key-widget qt-on-mouse-press! qt-last-mouse-x qt-last-mouse-y qt-last-mouse-button - qt-last-mouse-modifiers qt-last-mouse-widget QT_MOUSE_LEFT + qt-last-mouse-modifiers qt-last-mouse-widget QT_MOUSE_LEFT QT_MOUSE_MIDDLE ;; Line edit qt-line-edit-create qt-line-edit-set-completer! qt-line-edit-set-text! qt-line-edit-text ;; List widget @@ -269,6 +269,7 @@ (ffi-qt-stacked-widget-set-current-widget sw widget)) (def QT_MOUSE_LEFT 1) +(def QT_MOUSE_MIDDLE 4) (def ffi-qt-last-key-widget (foreign-procedure "qt_last_key_widget" () void*)) --- a/tests/test-qt-part2.ss +++ b/tests/test-qt-part2.ss @@ -99,7 +99,9 @@ (check (qt-key-event->string QT_KEY_SPACE QT_MOD_CTRL "") => "C-@") (check (qt-key-event->string QT_KEY_BACKSPACE 0 "") => "DEL") (check QT_MOUSE_LEFT => 1) - (check qt-on-mouse-press! ? procedure?)) + (check QT_MOUSE_MIDDLE => 4) + (check qt-on-mouse-press! ? procedure?) + (check (find-command 'mouse-yank-primary) ? procedure?)) (test-case "group45 command registry shard smoke" (check (find-command 'scroll-up) ? procedure?) @@ -114,6 +116,15 @@ (execute-command! app 'backward-char) (execute-command! app 'delete-char) (check (qt-plain-text-edit-text ed) => "hell"))) +(test-case "group46b mouse-yank-primary inserts kill-ring text" + (let-values (((ed w app) (make-qt-test-app "part2-46b"))) + (qt-plain-text-edit-set-text! ed "ab") + (sci-send ed SCI_GOTOPOS 1) + (app-state-kill-ring-set! app '("X")) + (execute-command! app 'mouse-yank-primary) + (check (qt-plain-text-edit-text ed) => "aXb") + (check (app-state-last-yank-pos app) => 1) + (check (app-state-last-yank-len app) => 1))) (test-case "group47 scroll commands use Scintilla visible line" (let-values (((ed w app) (make-qt-test-app "part2-47")))