Function: mouse-drag-frame-move
mouse-drag-frame-move is a byte-compiled function defined in
mouse.el.gz.
Signature
(mouse-drag-frame-move START-EVENT)
Documentation
Drag a frame or one of its edges with the mouse.
START-EVENT is the starting mouse event of the drag action. Its position window denotes the frame that will be dragged.
PART specifies the part that has been dragged and must be one of
the symbols left, top, right, bottom, top-left,
top-right, bottom-left, bottom-right to drag an internal
border or edge. If PART equals move, this means to move the
frame with the mouse.
Source Code
;; Defined in /usr/src/emacs/lisp/mouse.el.gz
(defun mouse-drag-frame-move (start-event)
"Drag a frame or one of its edges with the mouse.
START-EVENT is the starting mouse event of the drag action. Its
position window denotes the frame that will be dragged.
PART specifies the part that has been dragged and must be one of
the symbols `left', `top', `right', `bottom', `top-left',
`top-right', `bottom-left', `bottom-right' to drag an internal
border or edge. If PART equals `move', this means to move the
frame with the mouse."
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
(let* ((echo-keystrokes 0)
(start (event-start start-event))
(window (posn-window start))
;; FRAME is the frame to drag.
(frame (if (window-live-p window)
(window-frame window)
window))
(native-width (frame-native-width frame))
(native-height (frame-native-height frame))
;; Initial "first" frame position and size. While dragging we
;; base all calculations against that size and position.
(first-pos (frame-position frame))
(first-left (car first-pos))
(first-top (cdr first-pos))
;; PARENT is the parent frame of FRAME or, if FRAME is a
;; top-level frame, FRAME's workarea.
(parent (frame-parent frame))
(parent-edges
(if parent
`(0 0 ,(frame-native-width parent) ,(frame-native-height parent))
(let* ((attributes
(car (display-monitor-attributes-list)))
(workarea (assq 'workarea attributes)))
(and workarea
`(,(nth 1 workarea) ,(nth 2 workarea)
,(+ (nth 1 workarea) (nth 3 workarea))
,(+ (nth 2 workarea) (nth 4 workarea)))))))
(parent-left (and parent-edges (nth 0 parent-edges)))
(parent-top (and parent-edges (nth 1 parent-edges)))
(parent-right (and parent-edges (nth 2 parent-edges)))
(parent-bottom (and parent-edges (nth 3 parent-edges)))
;; Initial "first" mouse position. While dragging we base all
;; calculations against that position.
(first-x-y (mouse-absolute-pixel-position))
(first-x (car first-x-y))
(first-y (cdr first-x-y))
;; `snap-width' (maybe also a yet to be provided `snap-height')
;; could become floats to handle proportionality wrt PARENT.
;; We don't do any checks on this parameter so far.
(snap-width (frame-parameter frame 'snap-width))
;; `snap-x' and `snap-y' record the x- and y-coordinates of the
;; mouse position when FRAME snapped. As soon as the
;; difference between `pos-x' and `snap-x' (or `pos-y' and
;; `snap-y') exceeds the value of FRAME's `snap-width'
;; parameter, unsnap FRAME (at the respective side). `snap-x'
;; and `snap-y' nil mean FRAME is currently not snapped.
snap-x snap-y
(exitfun nil)
(move
(lambda (event)
(interactive "e")
(when (consp event)
(let* ((last-x-y (mouse-absolute-pixel-position))
(last-x (car last-x-y))
(last-y (cdr last-x-y))
(left (- last-x first-x))
(top (- last-y first-y))
right bottom)
(setq left (+ first-left left))
(setq top (+ first-top top))
;; Docking and constraining.
(when (and (numberp snap-width) parent-edges)
(cond
;; Docking at the left parent edge.
((< last-x first-x)
(cond
((and (> left parent-left)
(<= (- left parent-left) snap-width))
;; Snap when the mouse moved leftward and FRAME's
;; left edge would end up within `snap-width'
;; pixels from PARENT's left edge.
(setq snap-x last-x)
(setq left parent-left))
((and (<= left parent-left)
(<= (- parent-left left) snap-width)
snap-x (<= (- snap-x last-x) snap-width))
;; Stay snapped when the mouse moved leftward but
;; not more than `snap-width' pixels from the time
;; FRAME snapped.
(setq left parent-left))
(t
;; Unsnap when the mouse moved more than
;; `snap-width' pixels leftward from the time
;; FRAME snapped.
(setq snap-x nil))))
((> last-x first-x)
(setq right (+ left native-width))
(cond
((and (< right parent-right)
(<= (- parent-right right) snap-width))
;; Snap when the mouse moved rightward and FRAME's
;; right edge would end up within `snap-width'
;; pixels from PARENT's right edge.
(setq snap-x last-x)
(setq left (- parent-right native-width)))
((and (>= right parent-right)
(<= (- right parent-right) snap-width)
snap-x (<= (- last-x snap-x) snap-width))
;; Stay snapped when the mouse moved rightward but
;; not more more than `snap-width' pixels from the
;; time FRAME snapped.
(setq left (- parent-right native-width)))
(t
;; Unsnap when the mouse moved rightward more than
;; `snap-width' pixels from the time FRAME
;; snapped.
(setq snap-x nil)))))
(cond
((< last-y first-y)
(cond
((and (> top parent-top)
(<= (- top parent-top) snap-width))
;; Snap when the mouse moved upward and FRAME's
;; top edge would end up within `snap-width'
;; pixels from PARENT's top edge.
(setq snap-y last-y)
(setq top parent-top))
((and (<= top parent-top)
(<= (- parent-top top) snap-width)
snap-y (<= (- snap-y last-y) snap-width))
;; Stay snapped when the mouse moved upward but
;; not more more than `snap-width' pixels from the
;; time FRAME snapped.
(setq top parent-top))
(t
;; Unsnap when the mouse moved upward more than
;; `snap-width' pixels from the time FRAME
;; snapped.
(setq snap-y nil))))
((> last-y first-y)
(setq bottom (+ top native-height))
(cond
((and (< bottom parent-bottom)
(<= (- parent-bottom bottom) snap-width))
;; Snap when the mouse moved downward and FRAME's
;; bottom edge would end up within `snap-width'
;; pixels from PARENT's bottom edge.
(setq snap-y last-y)
(setq top (- parent-bottom native-height)))
((and (>= bottom parent-bottom)
(<= (- bottom parent-bottom) snap-width)
snap-y (<= (- last-y snap-y) snap-width))
;; Stay snapped when the mouse moved downward but
;; not more more than `snap-width' pixels from the
;; time FRAME snapped.
(setq top (- parent-bottom native-height)))
(t
;; Unsnap when the mouse moved downward more than
;; `snap-width' pixels from the time FRAME
;; snapped.
(setq snap-y nil))))))
;; If requested, constrain FRAME's draggable areas to
;; PARENT's edges. The `top-visible' parameter should
;; be set when FRAME has a draggable header-line. If
;; set to a number, it ascertains that the top of FRAME
;; is always constrained to the top of PARENT and that
;; at least as many pixels of FRAME as specified by that
;; number are visible on each of the three remaining
;; sides of PARENT.
;;
;; The `bottom-visible' parameter should be set when
;; FRAME has a draggable mode-line. If set to a number,
;; it ascertains that the bottom of FRAME is always
;; constrained to the bottom of PARENT and that at least
;; as many pixels of FRAME as specified by that number
;; are visible on each of the three remaining sides of
;; PARENT.
(let ((par (frame-parameter frame 'top-visible))
bottom-visible)
(unless par
(setq par (frame-parameter frame 'bottom-visible))
(setq bottom-visible t))
(when (and (numberp par) parent-edges)
(setq left
(max (min (- parent-right par) left)
(+ (- parent-left native-width) par)))
(setq top
(if bottom-visible
(min (max top (- parent-top (- native-height par)))
(- parent-bottom native-height))
(min (max top parent-top)
(- parent-bottom par))))))
;; Use `modify-frame-parameters' since `left' and `top'
;; may want to move FRAME out of its PARENT.
(modify-frame-parameters frame `((left . (+ ,left)) (top . (+ ,top))))))))
(old-track-mouse track-mouse))
;; Start tracking. The special value 'dragging' signals the
;; display engine to freeze the mouse pointer shape for as long
;; as we drag.
(setq track-mouse 'dragging)
;; Loop reading events and sampling the position of the mouse.
(setq exitfun
(set-transient-map
(let ((map (make-sparse-keymap)))
(define-key map [switch-frame] #'ignore)
(define-key map [select-window] #'ignore)
(define-key map [scroll-bar-movement] #'ignore)
(define-key map [mouse-movement] move)
;; Swallow drag-mouse-1 events to avoid selecting some other window.
(define-key map [drag-mouse-1]
(lambda () (interactive) (funcall exitfun)))
;; Some of the events will of course end up looked up
;; with a mode-line, header-line or vertical-line prefix ...
(define-key map [mode-line] map)
(define-key map [header-line] map)
(define-key map [tab-line] map)
(define-key map [vertical-line] map)
;; ... and some maybe even with a right- or bottom-divider
;; prefix.
(define-key map [right-divider] map)
(define-key map [bottom-divider] map)
map)
t (lambda () (setq track-mouse old-track-mouse))))))