diff --git a/docs/user/ebox-user-guide.en.md b/docs/user/ebox-user-guide.en.md index ad32856..21cf952 100644 --- a/docs/user/ebox-user-guide.en.md +++ b/docs/user/ebox-user-guide.en.md @@ -170,9 +170,12 @@ handles. ## 7. Resize and scroll -A finite height plus `:overflow scroll` creates a scroll window. Ebox buffer -mode installs keyboard and wheel commands that route through the innermost -scroll owner before falling back to ordinary Emacs scrolling. +When content exceeds a finite height, `:overflow scroll` creates an internal +scroll window. Keyboard scrolling targets point; wheel and trackpad scrolling +target the mouse position carried by the event. Remaining distance passes +through enclosing scroll owners from inner to outer, then to ordinary Emacs +scrolling. Events over another column, outside a box, or on the mode line do +not select an unrelated scroll box elsewhere on the page. ```elisp (ebox-build diff --git a/docs/user/ebox-user-guide.zh.md b/docs/user/ebox-user-guide.zh.md index 9fcc936..4d42bf0 100644 --- a/docs/user/ebox-user-guide.zh.md +++ b/docs/user/ebox-user-guide.zh.md @@ -157,8 +157,10 @@ retained TP surface 并返回 buffer。它们和 `ebox-display-buffer` 都接收 ## 7. Resize 与滚动 -有限高度加 `:overflow scroll` 会创建 scroll window。Ebox buffer mode 安装键盘和 -滚轮命令：先交给最内层 scroll owner，无法继续消费时才回退到普通 Emacs 滚动。 +内容超过有限高度时，`:overflow scroll` 会创建内部 scroll window。键盘滚动以 +文本光标（point）为目标；鼠标和触摸板滚动以事件中的鼠标位置为目标。剩余滚动距离 +沿包含该位置的 scroll owner 从内向外传递，最后交给普通 Emacs 滚动。鼠标位于 +其他栏、盒子外或 mode line 时，不会选取页面中无关的滚动盒子。 ```elisp (ebox-build diff --git a/ebox.el b/ebox.el index 9df7328..16eaab0 100644 --- a/ebox.el +++ b/ebox.el @@ -1485,9 +1485,16 @@ coordinator." (when-let* ((start (ignore-errors (event-start event))) (window (posn-window start)) ((window-live-p window)) - (buffer (window-buffer window)) - (position (posn-point start))) - (ebox--native-buffer-scroll-at-position buffer position delta))) + ((null (posn-area start)))) + (with-current-buffer (window-buffer window) + (let* ((position (posn-point start)) + (pos (if (markerp position) + (and (eq (marker-buffer position) (current-buffer)) + (marker-position position)) + position))) + (when (and (integerp pos) (<= (point-min) pos) (< pos (point-max))) + (ebox--native-buffer-scroll-at-position + (current-buffer) pos delta)))))) (defun ebox--scroll-box-contains-grid-p (box) "Return non-nil when BOX's retained scroll source contains a Grid node." @@ -2926,13 +2933,16 @@ Return non-nil while more work remains." (let (candidates) (maphash (lambda (region-id _state) - (when-let* ((bounds - (ebox-surface-region-bounds - (current-buffer) region-id))) - (when (and (<= (car bounds) pos) (< pos (cdr bounds))) - (push (cons region-id - (ebox--scroll-region-semantic-depth region-id)) - candidates)))) + ;; Rows can interleave this box's mounts with unrelated columns. + ;; Their enclosing interval is not the box's mouse hit area. + (when (cl-some + (lambda (mount) + (and (<= (plist-get mount :start) pos) + (< pos (plist-get mount :end)))) + (ebox-surface-region-mounts (current-buffer) region-id)) + (push (cons region-id + (ebox--scroll-region-semantic-depth region-id)) + candidates))) ebox--scroll-global-state) (mapcar #'car (sort candidates @@ -2951,26 +2961,6 @@ nested owners may render equal-sized clipped spans." (node-id (and region-nodes (gethash region-id region-nodes)))) (if node-id (ebox-surface--node-depth state node-id) -1))) -(defun ebox--scroll-region-ids-in-buffer-outer-first () - "Return scroll region ids in the current buffer from outer to inner." - (let (candidates) - (maphash - (lambda (region-id _state) - (when-let* ((bounds - (ebox-surface-region-bounds - (current-buffer) region-id))) - (push (cons region-id - (ebox--scroll-region-semantic-depth region-id)) - candidates))) - ebox--scroll-global-state) - (mapcar #'car - (sort candidates - (lambda (a b) - (if (= (cdr a) (cdr b)) - (string< (format "%S" (car a)) - (format "%S" (car b))) - (< (cdr a) (cdr b)))))))) - (defun ebox--scroll-region-ids-at-pos (pos) "Return scroll candidate region ids at POS from inner to outer." (let (ids) @@ -3615,20 +3605,16 @@ line count so scroll distance is neither duplicated nor dropped." "Return ebox scroll candidate region ids under mouse wheel EVENT." (when-let* ((start (ignore-errors (event-start event))) (window (posn-window start)) - ((window-live-p window))) + ((window-live-p window)) + ((null (posn-area start)))) (with-current-buffer (window-buffer window) (let* ((position (posn-point start)) - (ids - (when (and (integer-or-marker-p position) - (< (point-min) (point-max))) - (let ((pos (if (markerp position) - (marker-position position) - position))) - (ebox--scroll-region-ids-at-pos - (min (max pos (point-min)) - (1- (point-max)))))))) - (or ids - (ebox--scroll-region-ids-in-buffer-outer-first)))))) + (pos (if (markerp position) + (and (eq (marker-buffer position) (current-buffer)) + (marker-position position)) + position))) + (when (and (integerp pos) (<= (point-min) pos) (< pos (point-max))) + (ebox--scroll-region-ids-at-pos pos)))))) (defun ebox--wheel-region-id (event) "Return the innermost ebox region id under mouse wheel EVENT, or nil." diff --git a/tests/ebox-core-render-tests.el b/tests/ebox-core-render-tests.el index dd88643..1227535 100644 --- a/tests/ebox-core-render-tests.el +++ b/tests/ebox-core-render-tests.el @@ -12011,8 +12011,8 @@ explicit visible-window handoff may admit its full-content publication." (should (ebox-surface-region-mounts (current-buffer) target-id)) (should (ebox-test--buffer-visually-matches-runtime-render-p))))) -(ert-deftest ebox-wheel-scroll-uses-buffer-scroll-region-without-point () - "Wheel events from fringe-like areas should still scroll the ebox page." +(ert-deftest ebox-wheel-scroll-without-hovered-text-keeps-native-routing () + "Non-text and invalid wheel positions must not select any scroll owner." (ebox-test--reset-runtime-state) (let* ((layout (ebox-test-box :id "root" :height 2 :overflow 'scroll (ebox-test-column @@ -12020,24 +12020,129 @@ explicit visible-window handoff may admit its full-content publication." (ebox-test-box (ebox-test-text "B") :height 1) (ebox-test-box (ebox-test-text "C") :height 1)))) (root-id (car (ebox-region-ids layout))) - mwheel-called) + mwheel-args) (ebox-test--with-rendered-buffer layout + (save-window-excursion + (switch-to-buffer (current-buffer)) + (let ((before (buffer-string))) + ;; The hovered box is authoritative. An earlier contract routed + ;; mode-line events to any root scroll box in the buffer instead. + (dolist (position (list 'mode-line 'left-fringe 'right-fringe + 'vertical-scroll-bar nil + (point-max) (+ (point-max) 10) + (1- (point-min)))) + (ert-info ((format "wheel position: %S" position)) + (let ((event (list 'wheel-down + (list (selected-window) position '(0 . 0) + 0 nil nil nil nil nil nil)))) + (setq mwheel-args nil) + (cl-letf (((symbol-function 'mwheel-scroll) + (lambda (&rest args) (setq mwheel-args args)))) + (ebox--wheel-scroll event 1 'prefix)) + (should (equal mwheel-args (list event 'prefix))) + (should (= (plist-get (ebox--scroll-get-state root-id) + :scroll-offset) + 0)) + (should (equal-including-properties before (buffer-string))))))))))) + +(defun ebox-test--wheel-columns () + "Return a scroll box whose mounted lines are separated by another column." + (ebox-test-row + (ebox-test-box :id "peer" :width '(20) :height 3 + (ebox-test-text "peer0\npeer1\npeer2")) + (ebox-test-box :id "help" :width '(20) :height 3 :overflow 'scroll + (ebox-test-text "help0\nhelp1\nhelp2\nhelp3\nhelp4")))) + +(ert-deftest ebox-wheel-native-event-rejects-non-text-and-out-of-range-positions () + "Native root wheel routing must validate the mouse position before dispatch." + (with-temp-buffer + (insert "abc") + (save-window-excursion (switch-to-buffer (current-buffer)) - (cl-letf (((symbol-function 'event-start) - (lambda (_event) - (list (selected-window) 'mode-line '(0 . 0) - 0 nil nil nil nil nil nil))) - ((symbol-function 'mwheel-scroll) - (lambda (&rest _args) - (setq mwheel-called t)))) - (ebox--wheel-scroll 'fake-wheel-event 1)) - (should-not mwheel-called) - (should (= (plist-get (ebox--scroll-get-state root-id) - :scroll-offset) - 1)) - (let ((plain (buffer-substring-no-properties (point-min) (point-max)))) - (should (string-match-p "B" plain)) - (should (string-match-p "C" plain)))))) + (let (calls) + (cl-letf (((symbol-function 'ebox--native-buffer-scroll-at-position) + (lambda (buffer position delta) + (push (list buffer position delta) calls) + 1))) + (dolist (position (list 'mode-line 'right-fringe nil + (point-max) (+ (point-max) 10) + (1- (point-min)))) + (ert-info ((format "native wheel position: %S" position)) + (ebox--native-buffer-scroll-at-event + (list 'wheel-down (list (selected-window) position '(0 . 0) 0)) + 1) + (should-not calls))) + (goto-char (point-max)) + (should (= 1 (ebox--native-buffer-scroll-at-event + (list 'wheel-down (list (selected-window) 2 '(0 . 0) 0)) + 1))) + (should (equal calls (list (list (current-buffer) 2 1))))))))) + +(ert-deftest ebox-scroll-mount-hit-test-excludes-between-line-column-gaps () + "Only exact mounted spans belong to a multi-line scroll box." + (ebox-test--reset-runtime-state) + (ebox-test--with-rendered-buffer (ebox-test--wheel-columns) + (let* ((region-id (ebox-test--selector-region-id (current-buffer) "#help")) + (mounts (ebox-surface-region-mounts (current-buffer) region-id)) + (bounds (ebox-surface-region-bounds (current-buffer) region-id)) + (gap-count 0)) + (should (>= (length mounts) 3)) + (cl-loop for position from (car bounds) below (cdr bounds) + for inside = (cl-some + (lambda (mount) + (and (<= (plist-get mount :start) position) + (< position (plist-get mount :end)))) + mounts) + do (unless inside (cl-incf gap-count)) + do (ert-info ((format "mounted hit at position %S" position)) + (should (eq (and (memq region-id + (ebox--scroll-region-ids-in-mounts-at-pos + position)) + t) + inside)))) + (should (> gap-count 0))))) + +(ert-deftest ebox-wheel-scroll-follows-hovered-column-instead-of-point () + "A column gap stays native; hovering help scrolls it with point elsewhere." + (ebox-test--reset-runtime-state) + (ebox-test--with-rendered-buffer (ebox-test--wheel-columns) + (save-window-excursion + (switch-to-buffer (current-buffer)) + (let* ((region-id (ebox-test--selector-region-id (current-buffer) "#help")) + (mounts (ebox-surface-region-mounts (current-buffer) region-id)) + (inside (plist-get (car mounts) :start)) + (gap (save-excursion + (goto-char (point-min)) + (search-forward "peer1") + (1- (point)))) + (before (buffer-string)) + native-events) + (should (< inside gap)) + (should-not (cl-some (lambda (mount) + (and (<= (plist-get mount :start) gap) + (< gap (plist-get mount :end)))) + mounts)) + (goto-char inside) + (let ((event (list 'wheel-down + (list (selected-window) gap '(0 . 0) 0)))) + (cl-letf (((symbol-function 'mwheel-scroll) + (lambda (&rest args) (push args native-events)))) + (ebox--wheel-scroll event 1)) + (should (equal native-events (list (list event nil)))) + (should (= (plist-get (ebox-scroll-state region-id) :scroll-offset) 0)) + (should (equal-including-properties before (buffer-string)))) + (setq native-events nil) + (goto-char (point-min)) + (let ((event (list 'wheel-down + (list (selected-window) inside '(0 . 0) 0)))) + (cl-letf (((symbol-function 'mwheel-scroll) + (lambda (&rest args) (push args native-events)))) + (ebox--wheel-scroll event 1))) + (should-not native-events) + (should (= (plist-get (ebox-scroll-state region-id) :scroll-offset) 1)) + (should (string-match-p "help3" (buffer-string))) + (should-not (string-match-p "help0" (buffer-string))) + (should (string-match-p "peer0" (buffer-string))))))) (ert-deftest ebox-scroll-first-region-ignores-zero-consumption () "A zero-line scroll result should not consume the scroll event." @@ -12148,6 +12253,64 @@ explicit visible-window handoff may admit its full-content publication." (should-not (ebox-scroll-state outer-id)) (should (= native-lines -2)))))) +(ert-deftest ebox-wheel-scroll-distributes-real-nested-capacity-both-directions () + "Real wheel hits drain nested owners and preserve signed native residuals." + (ebox-test--reset-runtime-state) + (let ((layout + (ebox-test-box :id "outer" :height 6 :overflow 'scroll + (ebox-test-column + (ebox-test-box :id "middle" :height 4 :overflow 'scroll + (ebox-test-column + ;; Keep the inner viewport visible after the middle owner + ;; moves, so the reverse event also uses an actual mouse hit. + (ebox-test-box (ebox-test-text "before 0\nbefore 1\nbefore 2") + :height 3) + (ebox-test-box :id "inner" :height 1 :overflow 'scroll + (ebox-test-text "inner 0\ninner 1")) + (ebox-test-box (ebox-test-text "middle 0\nmiddle 1") :height 2))) + (ebox-test-box (ebox-test-text "outer 0\nouter 1") :height 2))))) + (ebox-test--with-rendered-buffer layout + (save-window-excursion + (switch-to-buffer (current-buffer)) + (let ((inner-id (ebox-test--selector-region-id (current-buffer) "#inner")) + (middle-id (ebox-test--selector-region-id (current-buffer) "#middle")) + (outer-id (ebox-test--selector-region-id (current-buffer) "#outer"))) + (dolist (delta '(5 -5)) + (ert-info ((format "nested wheel request: %S" delta)) + (let* ((forward-p (> delta 0)) + (hover + (save-excursion + (goto-char (point-min)) + (search-forward (if forward-p "inner 0" "inner 1")) + (1- (point)))) + (event (list (if forward-p 'wheel-down 'wheel-up) + (list (selected-window) hover '(0 . 0) 0))) + native-calls result) + (goto-char (point-min)) + (search-forward "outer 0") + (cl-letf (((symbol-function 'ebox--wheel-native-residual) + (lambda (received residual requested arg) + (push (list received residual requested arg) + native-calls)))) + (setq result (ebox--wheel-scroll event delta))) + (should (= (plist-get (ebox-scroll-state inner-id) :scroll-offset) + (if forward-p 1 0))) + (should (= (plist-get (ebox-scroll-state middle-id) :scroll-offset) + (if forward-p 2 0))) + (should-not (ebox-scroll-state outer-id)) + (should (= (alist-get inner-id (plist-get result :consumption)) + (if forward-p 1 -1))) + (should (= (alist-get middle-id (plist-get result :consumption)) + (if forward-p 2 -2))) + (should (= (plist-get result :requested) delta)) + (should (= delta (+ (plist-get result :ebox-consumed) + (plist-get result :native-residual)))) + (should (equal native-calls + (list (list event (if forward-p 2 -2) delta nil)))) + (should (string-match-p (if forward-p "inner 1" "inner 0") + (buffer-string))) + (should (string-match-p "outer 0" (buffer-string))))))))))) + (ert-deftest ebox-scroll-intent-refresh-at-boundary-does-not-swallow-input () "Refreshing unchanged pixels should leave the complete line intent residual." (let (native-residual) @@ -12256,8 +12419,8 @@ explicit visible-window handoff may admit its full-content publication." (let ((ebox--scroll-global-state (make-hash-table :test 'equal))) (puthash 'z-owner t ebox--scroll-global-state) (puthash 'a-owner t ebox--scroll-global-state) - (cl-letf (((symbol-function 'ebox-surface-region-bounds) - (lambda (&rest _) '(1 . 5))) + (cl-letf (((symbol-function 'ebox-surface-region-mounts) + (lambda (&rest _) '((:start 1 :end 5)))) ((symbol-function 'ebox--scroll-region-semantic-depth) (lambda (_region-id) 2))) (should (equal (ebox--scroll-region-ids-in-mounts-at-pos 2)