diff options
Diffstat (limited to 'third_party/emacs')
22 files changed, 11774 insertions, 0 deletions
diff --git a/third_party/emacs/carp-mode.nix b/third_party/emacs/carp-mode.nix new file mode 100644 index 000000000000..0ddf13654229 --- /dev/null +++ b/third_party/emacs/carp-mode.nix @@ -0,0 +1,23 @@ +{ pkgs, ... }: + +with pkgs; +with emacsPackages; + +melpaBuild rec { + pname = "carp-mode"; + version = "3.0"; + packageRequires = [ clojure-mode ]; + + recipe = builtins.toFile "recipe" '' + (carp-mode :fetcher github + :repo "carp-lang/carp" + :files ("emacs/*.el")) + ''; + + src = fetchFromGitHub { + owner = "carp-lang"; + repo = "carp"; + rev = "6954642cadee730885717201c3180c7acfb1bfa9"; + sha256 = "1pz4x2qkwjbz789bwc6nkacrjpzlxawxhl2nv0xdp731y7q7xyk9"; + }; +} diff --git a/third_party/emacs/explain-pause-mode.nix b/third_party/emacs/explain-pause-mode.nix new file mode 100644 index 000000000000..60e0cd149881 --- /dev/null +++ b/third_party/emacs/explain-pause-mode.nix @@ -0,0 +1,20 @@ +{ pkgs, ... }: + +let + inherit (pkgs) emacsPackages fetchFromGitHub; +in emacsPackages.melpaBuild { + pname = "explain-pause-mode"; + version = "0.1"; # master on 20200603 + + recipe = builtins.toFile "recipe.el" '' + (explain-pause-mode :fetcher github + :repo "lastquestion/explain-pause-mode") + ''; + + src = fetchFromGitHub { + owner = "lastquestion"; + repo = "explain-pause-mode"; + rev = "35f7d780a9c164b5c502023746473b1de3857904"; + sha256 = "0d9lwzqqwmz0n94i7959rj7m24265yf3825a5g8cd7fyzxznl1pc"; + }; +} diff --git a/third_party/emacs/exwm.nix b/third_party/emacs/exwm.nix new file mode 100644 index 000000000000..58552053148f --- /dev/null +++ b/third_party/emacs/exwm.nix @@ -0,0 +1,13 @@ +# EXWM straight from GitHub. As of 2020-05-15, XELB in nixpkgs is +# already at a recent enough version and does not need to be +# overridden. +{ pkgs, ... }: + +pkgs.emacsPackages.exwm.overrideAttrs(_: { + src = pkgs.fetchFromGitHub { + owner = "ch11ng"; + repo = "exwm"; + rev = "48db94f48bea1137132345abfe8256cfc6219248"; + sha256 = "0jj12z6m5kvanq19gds3jpvid2mg8w28bbbq9iycl751y2sj4l1r"; + }; +}) diff --git a/third_party/emacs/exwm/.elpaignore b/third_party/emacs/exwm/.elpaignore new file mode 100644 index 000000000000..b43bf86b50fd --- /dev/null +++ b/third_party/emacs/exwm/.elpaignore @@ -0,0 +1 @@ +README.md diff --git a/third_party/emacs/exwm/.gitignore b/third_party/emacs/exwm/.gitignore new file mode 100644 index 000000000000..9e4b0ee5b48e --- /dev/null +++ b/third_party/emacs/exwm/.gitignore @@ -0,0 +1,3 @@ +*.elc +*-pkg.el +*-autoloads.el diff --git a/third_party/emacs/exwm/README.md b/third_party/emacs/exwm/README.md new file mode 100644 index 000000000000..6d7e0dd1ff17 --- /dev/null +++ b/third_party/emacs/exwm/README.md @@ -0,0 +1,21 @@ +# Emacs X Window Manager + +EXWM (Emacs X Window Manager) is a full-featured tiling X window manager +for Emacs built on top of [XELB](https://github.com/ch11ng/xelb). +It features: ++ Fully keyboard-driven operations ++ Hybrid layout modes (tiling & stacking) ++ Dynamic workspace support ++ ICCCM/EWMH compliance ++ (Optional) RandR (multi-monitor) support ++ (Optional) Builtin system tray ++ (Optional) Builtin input method + +Please check out the +[screenshots](https://github.com/ch11ng/exwm/wiki/Screenshots) +to get an overview of what EXWM is capable of, +and the [user guide](https://github.com/ch11ng/exwm/wiki) +for a detailed explanation of its usage. + +**Note**: If you install EXWM from source, it's recommended to install +XELB also from source (otherwise install both from GNU ELPA). diff --git a/third_party/emacs/exwm/exwm-cm.el b/third_party/emacs/exwm/exwm-cm.el new file mode 100644 index 000000000000..922847785836 --- /dev/null +++ b/third_party/emacs/exwm/exwm-cm.el @@ -0,0 +1,50 @@ +;;; exwm-cm.el --- Compositing Manager for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2016-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module is obsolete since EXWM now supports third-party compositors. + +;;; Code: + +(make-obsolete-variable 'exwm-cm-opacity + "This variable should no longer be used." "26") + +(defun exwm-cm-set-opacity (&rest _args) + (declare (obsolete nil "26"))) + +(defun exwm-cm-enable () + (declare (obsolete nil "26"))) + +(defun exwm-cm-start () + (declare (obsolete nil "26"))) + +(defun exwm-cm-stop () + (declare (obsolete nil "26"))) + +(defun exwm-cm-toggle () + (declare (obsolete nil "26"))) + + + +(provide 'exwm-cm) + +;;; exwm-cm.el ends here diff --git a/third_party/emacs/exwm/exwm-config.el b/third_party/emacs/exwm/exwm-config.el new file mode 100644 index 000000000000..bb8258a7149f --- /dev/null +++ b/third_party/emacs/exwm/exwm-config.el @@ -0,0 +1,131 @@ +;;; exwm-config.el --- Predefined configurations -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module contains typical (yet minimal) configurations of EXWM. + +;;; Code: + +(require 'exwm) +(require 'ido) + +(define-obsolete-function-alias 'exwm-config-default + #'exwm-config-example "27.1") + +(defun exwm-config-example () + "Default configuration of EXWM." + ;; Set the initial workspace number. + (unless (get 'exwm-workspace-number 'saved-value) + (setq exwm-workspace-number 4)) + ;; Make class name the buffer name + (add-hook 'exwm-update-class-hook + (lambda () + (exwm-workspace-rename-buffer exwm-class-name))) + ;; Global keybindings. + (unless (get 'exwm-input-global-keys 'saved-value) + (setq exwm-input-global-keys + `( + ;; 's-r': Reset (to line-mode). + ([?\s-r] . exwm-reset) + ;; 's-w': Switch workspace. + ([?\s-w] . exwm-workspace-switch) + ;; 's-&': Launch application. + ([?\s-&] . (lambda (command) + (interactive (list (read-shell-command "$ "))) + (start-process-shell-command command nil command))) + ;; 's-N': Switch to certain workspace. + ,@(mapcar (lambda (i) + `(,(kbd (format "s-%d" i)) . + (lambda () + (interactive) + (exwm-workspace-switch-create ,i)))) + (number-sequence 0 9))))) + ;; Line-editing shortcuts + (unless (get 'exwm-input-simulation-keys 'saved-value) + (setq exwm-input-simulation-keys + '(([?\C-b] . [left]) + ([?\C-f] . [right]) + ([?\C-p] . [up]) + ([?\C-n] . [down]) + ([?\C-a] . [home]) + ([?\C-e] . [end]) + ([?\M-v] . [prior]) + ([?\C-v] . [next]) + ([?\C-d] . [delete]) + ([?\C-k] . [S-end delete])))) + ;; Enable EXWM + (exwm-enable) + ;; Configure Ido + (exwm-config-ido) + ;; Other configurations + (exwm-config-misc)) + +(defun exwm-config--fix/ido-buffer-window-other-frame () + "Fix `ido-buffer-window-other-frame'." + (defalias 'exwm-config-ido-buffer-window-other-frame + (symbol-function #'ido-buffer-window-other-frame)) + (defun ido-buffer-window-other-frame (buffer) + "This is a version redefined by EXWM. + +You can find the original one at `exwm-config-ido-buffer-window-other-frame'." + (with-current-buffer (window-buffer (selected-window)) + (if (and (derived-mode-p 'exwm-mode) + exwm--floating-frame) + ;; Switch from a floating frame. + (with-current-buffer buffer + (if (and (derived-mode-p 'exwm-mode) + exwm--floating-frame + (eq exwm--frame exwm-workspace--current)) + ;; Switch to another floating frame. + (frame-root-window exwm--floating-frame) + ;; Do not switch if the buffer is not on the current workspace. + (or (get-buffer-window buffer exwm-workspace--current) + (selected-window)))) + (with-current-buffer buffer + (when (derived-mode-p 'exwm-mode) + (if (eq exwm--frame exwm-workspace--current) + (when exwm--floating-frame + ;; Switch to a floating frame on the current workspace. + (frame-selected-window exwm--floating-frame)) + ;; Do not switch to exwm-mode buffers on other workspace (which + ;; won't work unless `exwm-layout-show-all-buffers' is set) + (unless exwm-layout-show-all-buffers + (selected-window))))))))) + +(defun exwm-config-ido () + "Configure Ido to work with EXWM." + (ido-mode 1) + (add-hook 'exwm-init-hook #'exwm-config--fix/ido-buffer-window-other-frame)) + +(defun exwm-config-misc () + "Other configurations." + ;; Make more room + (menu-bar-mode -1) + (tool-bar-mode -1) + (scroll-bar-mode -1) + (fringe-mode 1)) + + + +(provide 'exwm-config) + +;;; exwm-config.el ends here diff --git a/third_party/emacs/exwm/exwm-core.el b/third_party/emacs/exwm/exwm-core.el new file mode 100644 index 000000000000..76454894ab43 --- /dev/null +++ b/third_party/emacs/exwm/exwm-core.el @@ -0,0 +1,375 @@ +;;; exwm-core.el --- Core definitions -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module includes core definitions of variables, macros, functions, etc +;; shared by various other modules. + +;;; Code: + +(require 'kmacro) + +(require 'xcb) +(require 'xcb-icccm) +(require 'xcb-ewmh) +(require 'xcb-debug) + +(defcustom exwm-debug-log-time-function #'exwm-debug-log-uptime + "Function used for generating timestamps in `exwm-debug' logs. + +Here are some predefined candidates: +`exwm-debug-log-uptime': Display the uptime of this Emacs instance. +`exwm-debug-log-time': Display time of day. +`nil': Disable timestamp." + :group 'exwm-debug + :type `(choice (const :tag "Emacs uptime" ,#'exwm-debug-log-uptime) + (const :tag "Time of day" ,#'exwm-debug-log-time) + (const :tag "Off" nil) + (function :tag "Other")) + :set (lambda (symbol value) + (set-default symbol value) + ;; Also change the format for XELB to make logs consistent + ;; (as they share the same buffer). + (setq xcb-debug:log-time-function value))) + +(defalias 'exwm-debug-log-uptime 'xcb-debug:log-uptime + "Add uptime to `exwm-debug' logs.") + +(defalias 'exwm-debug-log-time 'xcb-debug:log-time + "Add time of day to `exwm-debug' logs.") + +(defvar exwm--connection nil "X connection.") + +(defvar exwm--wmsn-window nil + "An X window owning the WM_S0 selection.") + +(defvar exwm--wmsn-acquire-timeout 3 + "Number of seconds to wait for other window managers to release the selection.") + +(defvar exwm--guide-window nil + "An X window separating workspaces and X windows.") + +(defvar exwm--id-buffer-alist nil "Alist of (<X window ID> . <Emacs buffer>).") + +(defvar exwm--root nil "Root window.") + +(defvar exwm-input--global-prefix-keys) +(defvar exwm-input--simulation-keys) +(defvar exwm-input-line-mode-passthrough) +(defvar exwm-input-prefix-keys) +(declare-function exwm-input--fake-key "exwm-input.el" (event)) +(declare-function exwm-input--on-KeyPress-line-mode "exwm-input.el" + (key-press raw-data)) +(declare-function exwm-floating-hide "exwm-floating.el") +(declare-function exwm-floating-toggle-floating "exwm-floating.el") +(declare-function exwm-input-release-keyboard "exwm-input.el") +(declare-function exwm-input-send-next-key "exwm-input.el" (times)) +(declare-function exwm-layout-set-fullscreen "exwm-layout.el" (&optional id)) +(declare-function exwm-layout-toggle-mode-line "exwm-layout.el") +(declare-function exwm-manage--kill-buffer-query-function "exwm-manage.el") +(declare-function exwm-workspace-move-window "exwm-workspace.el" + (frame-or-index &optional id)) + +(define-minor-mode exwm-debug + "Debug-logging enabled if non-nil" + :global t) + +(defmacro exwm--debug (&rest forms) + (when exwm-debug `(progn ,@forms))) + +(defmacro exwm--log (&optional format-string &rest objects) + "Emit a message prepending the name of the function being executed. + +FORMAT-STRING is a string specifying the message to output, as in +`format'. The OBJECTS arguments specify the substitutions." + (unless format-string (setq format-string "")) + `(when exwm-debug + (xcb-debug:message ,(concat "%s%s:\t" format-string "\n") + (if exwm-debug-log-time-function + (funcall exwm-debug-log-time-function) + "") + (xcb-debug:compile-time-function-name) + ,@objects) + nil)) + +(defsubst exwm--id->buffer (id) + "X window ID => Emacs buffer." + (cdr (assoc id exwm--id-buffer-alist))) + +(defsubst exwm--buffer->id (buffer) + "Emacs buffer BUFFER => X window ID." + (car (rassoc buffer exwm--id-buffer-alist))) + +(defun exwm--lock (&rest _args) + "Lock (disable all events)." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--root + :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:NoEvent)) + (xcb:flush exwm--connection)) + +(defun exwm--unlock (&rest _args) + "Unlock (enable all events)." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--root + :value-mask xcb:CW:EventMask + :event-mask (eval-when-compile + (logior xcb:EventMask:SubstructureRedirect + xcb:EventMask:StructureNotify)))) + (xcb:flush exwm--connection)) + +(defun exwm--set-geometry (xwin x y width height) + "Set the geometry of X window XWIN to WIDTHxHEIGHT+X+Y. + +Nil can be passed as placeholder." + (exwm--log "Setting #x%x to %sx%s+%s+%s" xwin width height x y) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window xwin + :value-mask (logior (if x xcb:ConfigWindow:X 0) + (if y xcb:ConfigWindow:Y 0) + (if width xcb:ConfigWindow:Width 0) + (if height xcb:ConfigWindow:Height 0)) + :x x :y y :width width :height height))) + +(defun exwm--intern-atom (atom) + "Intern X11 ATOM." + (slot-value (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:InternAtom + :only-if-exists 0 + :name-len (length atom) + :name atom)) + 'atom)) + +(defmacro exwm--defer (secs function &rest args) + "Defer the execution of FUNCTION. + +The action is to call FUNCTION with arguments ARGS. If Emacs is not idle, +defer the action until Emacs is idle. Otherwise, defer the action until at +least SECS seconds later." + `(run-with-idle-timer (+ (float-time (or (current-idle-time) + (seconds-to-time (- ,secs)))) + ,secs) + nil + ,function + ,@args)) + +(defun exwm--get-client-event-mask () + "Return event mask set on all managed windows." + (logior xcb:EventMask:StructureNotify + xcb:EventMask:PropertyChange + (if mouse-autoselect-window + xcb:EventMask:EnterWindow 0))) + +(defun exwm--color->pixel (color) + "Convert COLOR to PIXEL (index in TrueColor colormap)." + (when (and color + (eq (x-display-visual-class) 'true-color)) + (let ((rgb (x-color-values color))) + (logior (lsh (lsh (pop rgb) -8) 16) + (lsh (lsh (pop rgb) -8) 8) + (lsh (pop rgb) -8))))) + +;; Internal variables +(defvar-local exwm--id nil) ;window ID +(defvar-local exwm--configurations nil) ;initial configurations. +(defvar-local exwm--frame nil) ;workspace frame +(defvar-local exwm--floating-frame nil) ;floating frame +(defvar-local exwm--mode-line-format nil) ;save mode-line-format +(defvar-local exwm--floating-frame-position nil) ;set when hidden. +(defvar-local exwm--fixed-size nil) ;fixed size +(defvar-local exwm--selected-input-mode 'line-mode + "Input mode as selected by the user. +One of `line-mode' or `char-mode'.") +(defvar-local exwm--input-mode 'line-mode + "Actual input mode, i.e. whether mouse and keyboard are grabbed.") +;; Properties +(defvar-local exwm--desktop nil "_NET_WM_DESKTOP.") +(defvar-local exwm-window-type nil "_NET_WM_WINDOW_TYPE.") +(defvar-local exwm--geometry nil) +(defvar-local exwm-class-name nil "Class name in WM_CLASS.") +(defvar-local exwm-instance-name nil "Instance name in WM_CLASS.") +(defvar-local exwm-title nil "Window title (either _NET_WM_NAME or WM_NAME)") +(defvar-local exwm--title-is-utf8 nil) +(defvar-local exwm-transient-for nil "WM_TRANSIENT_FOR.") +(defvar-local exwm--protocols nil) +(defvar-local exwm-state xcb:icccm:WM_STATE:NormalState "WM_STATE.") +(defvar-local exwm--ewmh-state nil "_NET_WM_STATE.") +;; _NET_WM_NORMAL_HINTS +(defvar-local exwm--normal-hints-x nil) +(defvar-local exwm--normal-hints-y nil) +(defvar-local exwm--normal-hints-width nil) +(defvar-local exwm--normal-hints-height nil) +(defvar-local exwm--normal-hints-min-width nil) +(defvar-local exwm--normal-hints-min-height nil) +(defvar-local exwm--normal-hints-max-width nil) +(defvar-local exwm--normal-hints-max-height nil) +;; (defvar-local exwm--normal-hints-win-gravity nil) +;; WM_HINTS +(defvar-local exwm--hints-input nil) +(defvar-local exwm--hints-urgency nil) +;; _MOTIF_WM_HINTS +(defvar-local exwm--mwm-hints-decorations t) + +(defvar exwm-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-d\C-l" #'xcb-debug:clear) + (define-key map "\C-c\C-d\C-m" #'xcb-debug:mark) + (define-key map "\C-c\C-d\C-t" #'exwm-debug) + (define-key map "\C-c\C-f" #'exwm-layout-set-fullscreen) + (define-key map "\C-c\C-h" #'exwm-floating-hide) + (define-key map "\C-c\C-k" #'exwm-input-release-keyboard) + (define-key map "\C-c\C-m" #'exwm-workspace-move-window) + (define-key map "\C-c\C-q" #'exwm-input-send-next-key) + (define-key map "\C-c\C-t\C-f" #'exwm-floating-toggle-floating) + (define-key map "\C-c\C-t\C-m" #'exwm-layout-toggle-mode-line) + map) + "Keymap for `exwm-mode'.") + +(defvar exwm--kmacro-map + (let ((map (make-sparse-keymap))) + (define-key map [t] + (lambda () + (interactive) + (cond + ((or exwm-input-line-mode-passthrough + ;; Do not test `exwm-input--during-command'. + (active-minibuffer-window) + (memq last-input-event exwm-input--global-prefix-keys) + (memq last-input-event exwm-input-prefix-keys) + (lookup-key exwm-mode-map (vector last-input-event)) + (gethash last-input-event exwm-input--simulation-keys)) + (set-transient-map (make-composed-keymap (list exwm-mode-map + global-map))) + (push last-input-event unread-command-events)) + (t + (exwm-input--fake-key last-input-event))))) + map) + "Keymap used when executing keyboard macros.") + +;; This menu mainly acts as an reminder for users. Thus it should be as +;; detailed as possible, even some entries do not make much sense here. +;; Also, inactive entries should be disabled rather than hidden. +(easy-menu-define exwm-mode-menu exwm-mode-map + "Menu for `exwm-mode'." + '("EXWM" + "---" + "*General*" + "---" + ["Toggle floating" exwm-floating-toggle-floating] + ["Toggle fullscreen mode" exwm-layout-toggle-fullscreen] + ["Hide window" exwm-floating-hide exwm--floating-frame] + ["Close window" (kill-buffer (current-buffer))] + + "---" + "*Resizing*" + "---" + ["Toggle mode-line" exwm-layout-toggle-mode-line] + ["Enlarge window vertically" exwm-layout-enlarge-window] + ["Enlarge window horizontally" exwm-layout-enlarge-window-horizontally] + ["Shrink window vertically" exwm-layout-shrink-window] + ["Shrink window horizontally" exwm-layout-shrink-window-horizontally] + + "---" + "*Keyboard*" + "---" + ["Toggle keyboard mode" exwm-input-toggle-keyboard] + ["Send key" exwm-input-send-next-key (eq exwm--input-mode 'line-mode)] + ;; This is merely a reference. + ("Send simulation key" :filter + (lambda (&rest _args) + (let (result) + (maphash + (lambda (key value) + (when (sequencep key) + (setq result (append result + `([ + ,(format "Send '%s'" + (key-description value)) + (lambda () + (interactive) + (dolist (i ',value) + (exwm-input--fake-key i))) + :keys ,(key-description key)]))))) + exwm-input--simulation-keys) + result))) + + ["Define global binding" exwm-input-set-key] + + "---" + "*Workspace*" + "---" + ["Add workspace" exwm-workspace-add] + ["Delete current workspace" exwm-workspace-delete] + ["Move workspace to" exwm-workspace-move] + ["Swap workspaces" exwm-workspace-swap] + ["Move X window to" exwm-workspace-move-window] + ["Move X window from" exwm-workspace-switch-to-buffer] + ["Toggle minibuffer" exwm-workspace-toggle-minibuffer] + ["Switch workspace" exwm-workspace-switch] + ;; Place this entry at bottom to avoid selecting others by accident. + ("Switch to" :filter + (lambda (&rest _args) + (mapcar (lambda (i) + `[,(format "Workspace %d" i) + (lambda () + (interactive) + (exwm-workspace-switch ,i)) + (/= ,i exwm-workspace-current-index)]) + (number-sequence 0 (1- (exwm-workspace--count)))))))) + +(define-derived-mode exwm-mode nil "EXWM" + "Major mode for managing X windows. + +\\{exwm-mode-map}" + ;; + (setq mode-name + '(:eval (propertize "EXWM" 'face + (when (cl-some (lambda (i) + (frame-parameter i 'exwm-urgency)) + exwm-workspace--list) + 'font-lock-warning-face)))) + ;; Change major-mode is not allowed + (add-hook 'change-major-mode-hook #'kill-buffer nil t) + ;; Kill buffer -> close window + (add-hook 'kill-buffer-query-functions + #'exwm-manage--kill-buffer-query-function nil t) + ;; Redirect events when executing keyboard macros. + (push `(executing-kbd-macro . ,exwm--kmacro-map) + minor-mode-overriding-map-alist) + (setq buffer-read-only t + cursor-type nil + left-margin-width nil + right-margin-width nil + left-fringe-width 0 + right-fringe-width 0 + vertical-scroll-bar nil)) + + + +(provide 'exwm-core) + +;;; exwm-core.el ends here diff --git a/third_party/emacs/exwm/exwm-floating.el b/third_party/emacs/exwm/exwm-floating.el new file mode 100644 index 000000000000..d1882cf74615 --- /dev/null +++ b/third_party/emacs/exwm/exwm-floating.el @@ -0,0 +1,783 @@ +;;; exwm-floating.el --- Floating Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module deals with the conversion between floating and non-floating +;; states and implements moving/resizing operations on floating windows. + +;;; Code: + +(require 'xcb-cursor) +(require 'exwm-core) + +(defgroup exwm-floating nil + "Floating." + :version "25.3" + :group 'exwm) + +(defcustom exwm-floating-setup-hook nil + "Normal hook run when an X window has been made floating, in the +context of the corresponding buffer." + :type 'hook) + +(defcustom exwm-floating-exit-hook nil + "Normal hook run when an X window has exited floating state, in the +context of the corresponding buffer." + :type 'hook) + +(defcustom exwm-floating-border-color "navy" + "Border color of floating windows." + :type 'color + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (set-default symbol value) + ;; Change border color for all floating X windows. + (when exwm--connection + (let ((border-pixel (exwm--color->pixel value))) + (when border-pixel + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when exwm--floating-frame + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window + (frame-parameter exwm--floating-frame + 'exwm-container) + :value-mask xcb:CW:BorderPixel + :border-pixel border-pixel))))) + (xcb:flush exwm--connection)))))) + +(defcustom exwm-floating-border-width 1 + "Border width of floating windows." + :type '(integer + :validate (lambda (widget) + (when (< (widget-value widget) 0) + (widget-put widget :error "Border width is at least 0") + widget))) + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (let ((delta (- value exwm-floating-border-width)) + container) + (set-default symbol value) + ;; Change border width for all floating X windows. + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when exwm--floating-frame + (setq container (frame-parameter exwm--floating-frame + 'exwm-container)) + (with-slots (x y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container + :value-mask + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y + xcb:ConfigWindow:BorderWidth) + :border-width value + :x (- x delta) + :y (- y delta))))))) + (when exwm--connection + (xcb:flush exwm--connection))))) + +;; Cursors for moving/resizing a window +(defvar exwm-floating--cursor-move nil) +(defvar exwm-floating--cursor-top-left nil) +(defvar exwm-floating--cursor-top nil) +(defvar exwm-floating--cursor-top-right nil) +(defvar exwm-floating--cursor-right nil) +(defvar exwm-floating--cursor-bottom-right nil) +(defvar exwm-floating--cursor-bottom nil) +(defvar exwm-floating--cursor-bottom-left nil) +(defvar exwm-floating--cursor-left nil) + +(defvar exwm-floating--moveresize-calculate nil + "Calculate move/resize parameters [buffer event-mask x y width height].") + +(defvar exwm-workspace--current) +(defvar exwm-workspace--frame-y-offset) +(defvar exwm-workspace--window-y-offset) +(defvar exwm-workspace--workareas) +(declare-function exwm-layout--hide "exwm-layout.el" (id)) +(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id)) +(declare-function exwm-layout--refresh "exwm-layout.el" ()) +(declare-function exwm-layout--show "exwm-layout.el" (id &optional window)) +(declare-function exwm-workspace--position "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--update-offsets "exwm-workspace.el" ()) + +(defun exwm-floating--set-allowed-actions (id tilling) + "Set _NET_WM_ALLOWED_ACTIONS." + (exwm--log "#x%x" id) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_ALLOWED_ACTIONS + :window id + :data (if tilling + (vector xcb:Atom:_NET_WM_ACTION_MINIMIZE + xcb:Atom:_NET_WM_ACTION_FULLSCREEN + xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP + xcb:Atom:_NET_WM_ACTION_CLOSE) + (vector xcb:Atom:_NET_WM_ACTION_MOVE + xcb:Atom:_NET_WM_ACTION_RESIZE + xcb:Atom:_NET_WM_ACTION_MINIMIZE + xcb:Atom:_NET_WM_ACTION_FULLSCREEN + xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP + xcb:Atom:_NET_WM_ACTION_CLOSE))))) + +(defun exwm-floating--set-floating (id) + "Make window ID floating." + (let ((window (get-buffer-window (exwm--id->buffer id)))) + (when window + ;; Hide the non-floating X window first. + (set-window-buffer window (other-buffer nil t)))) + (let* ((original-frame (buffer-local-value 'exwm--frame + (exwm--id->buffer id))) + ;; Create new frame + (frame (with-current-buffer + (or (get-buffer "*scratch*") + (progn + (set-buffer-major-mode + (get-buffer-create "*scratch*")) + (get-buffer "*scratch*"))) + (make-frame + `((minibuffer . ,(minibuffer-window exwm--frame)) + (left . ,(* window-min-width -10000)) + (top . ,(* window-min-height -10000)) + (width . ,window-min-width) + (height . ,window-min-height) + (unsplittable . t))))) ;and fix the size later + (outer-id (string-to-number (frame-parameter frame 'outer-window-id))) + (window-id (string-to-number (frame-parameter frame 'window-id))) + (frame-container (xcb:generate-id exwm--connection)) + (window (frame-first-window frame)) ;and it's the only window + (x (slot-value exwm--geometry 'x)) + (y (slot-value exwm--geometry 'y)) + (width (slot-value exwm--geometry 'width)) + (height (slot-value exwm--geometry 'height))) + ;; Force drawing menu-bar & tool-bar. + (redisplay t) + (exwm-workspace--update-offsets) + (exwm--log "Floating geometry (original): %dx%d%+d%+d" width height x y) + ;; Save frame parameters. + (set-frame-parameter frame 'exwm-outer-id outer-id) + (set-frame-parameter frame 'exwm-id window-id) + (set-frame-parameter frame 'exwm-container frame-container) + ;; Fix illegal parameters + ;; FIXME: check normal hints restrictions + (let* ((workarea (elt exwm-workspace--workareas + (exwm-workspace--position original-frame))) + (x* (aref workarea 0)) + (y* (aref workarea 1)) + (width* (aref workarea 2)) + (height* (aref workarea 3))) + ;; Center floating windows + (when (and (or (= x 0) (= x x*)) + (or (= y 0) (= y y*))) + (let ((buffer (exwm--id->buffer exwm-transient-for)) + window edges) + (when (and buffer (setq window (get-buffer-window buffer))) + (setq edges (window-inside-absolute-pixel-edges window)) + (unless (and (<= width (- (elt edges 2) (elt edges 0))) + (<= height (- (elt edges 3) (elt edges 1)))) + (setq edges nil))) + (if edges + ;; Put at the center of leading window + (setq x (+ x* (/ (- (elt edges 2) (elt edges 0) width) 2)) + y (+ y* (/ (- (elt edges 3) (elt edges 1) height) 2))) + ;; Put at the center of screen + (setq x (/ (- width* width) 2) + y (/ (- height* height) 2))))) + (if (> width width*) + ;; Too wide + (progn (setq x x* + width width*)) + ;; Invalid width + (when (= 0 width) (setq width (/ width* 2))) + ;; Make sure at least half of the window is visible + (unless (< x* (+ x (/ width 2)) (+ x* width*)) + (setq x (+ x* (/ (- width* width) 2))))) + (if (> height height*) + ;; Too tall + (setq y y* + height height*) + ;; Invalid height + (when (= 0 height) (setq height (/ height* 2))) + ;; Make sure at least half of the window is visible + (unless (< y* (+ y (/ height 2)) (+ y* height*)) + (setq y (+ y* (/ (- height* height) 2))))) + ;; The geometry can be overridden by user options. + (let ((x** (plist-get exwm--configurations 'x)) + (y** (plist-get exwm--configurations 'y)) + (width** (plist-get exwm--configurations 'width)) + (height** (plist-get exwm--configurations 'height))) + (if (integerp x**) + (setq x (+ x* x**)) + (when (and (floatp x**) + (>= 1 x** 0)) + (setq x (+ x* (round (* x** width*)))))) + (if (integerp y**) + (setq y (+ y* y**)) + (when (and (floatp y**) + (>= 1 y** 0)) + (setq y (+ y* (round (* y** height*)))))) + (if (integerp width**) + (setq width width**) + (when (and (floatp width**) + (> 1 width** 0)) + (setq width (max 1 (round (* width** width*)))))) + (if (integerp height**) + (setq height height**) + (when (and (floatp height**) + (> 1 height** 0)) + (setq height (max 1 (round (* height** height*)))))))) + (exwm--set-geometry id x y nil nil) + (xcb:flush exwm--connection) + (exwm--log "Floating geometry (corrected): %dx%d%+d%+d" width height x y) + ;; Fit frame to client + ;; It seems we have to make the frame invisible in order to resize it + ;; timely. + ;; The frame will be made visible by `select-frame-set-input-focus'. + (make-frame-invisible frame) + (let* ((edges (window-inside-pixel-edges window)) + (frame-width (+ width (- (frame-pixel-width frame) + (- (elt edges 2) (elt edges 0))))) + (frame-height (+ height (- (frame-pixel-height frame) + (- (elt edges 3) (elt edges 1))) + ;; Use `frame-outer-height' in the future. + exwm-workspace--frame-y-offset)) + (floating-mode-line (plist-get exwm--configurations + 'floating-mode-line)) + (floating-header-line (plist-get exwm--configurations + 'floating-header-line)) + (border-pixel (exwm--color->pixel exwm-floating-border-color))) + (if floating-mode-line + (setq exwm--mode-line-format (or exwm--mode-line-format + mode-line-format) + mode-line-format floating-mode-line) + (if (and (not (plist-member exwm--configurations 'floating-mode-line)) + exwm--mwm-hints-decorations) + (when exwm--mode-line-format + (setq mode-line-format exwm--mode-line-format)) + ;; The mode-line need to be hidden in floating mode. + (setq frame-height (- frame-height (window-mode-line-height + (frame-root-window frame))) + exwm--mode-line-format (or exwm--mode-line-format + mode-line-format) + mode-line-format nil))) + (if floating-header-line + (setq header-line-format floating-header-line) + (if (and (not (plist-member exwm--configurations + 'floating-header-line)) + exwm--mwm-hints-decorations) + (setq header-line-format nil) + ;; The header-line need to be hidden in floating mode. + (setq frame-height (- frame-height (window-header-line-height + (frame-root-window frame))) + header-line-format nil))) + (set-frame-size frame frame-width frame-height t) + ;; Create the frame container as the parent of the frame. + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid frame-container + :parent exwm--root + :x x + :y (- y exwm-workspace--window-y-offset) + :width width + :height height + :border-width + (with-current-buffer (exwm--id->buffer id) + (let ((border-witdh (plist-get exwm--configurations + 'border-width))) + (if (and (integerp border-witdh) + (>= border-witdh 0)) + border-witdh + exwm-floating-border-width))) + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask (logior xcb:CW:BackPixmap + (if border-pixel + xcb:CW:BorderPixel 0) + xcb:CW:OverrideRedirect) + :background-pixmap xcb:BackPixmap:ParentRelative + :border-pixel border-pixel + :override-redirect 1)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window frame-container + :data + (format "EXWM floating frame container for 0x%x" id))) + ;; Map it. + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window frame-container)) + ;; Put the X window right above this frame container. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window id + :value-mask (logior xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling frame-container + :stack-mode xcb:StackMode:Above))) + ;; Reparent this frame to its container. + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id :parent frame-container :x 0 :y 0)) + (exwm-floating--set-allowed-actions id nil) + (xcb:flush exwm--connection) + ;; Set window/buffer + (with-current-buffer (exwm--id->buffer id) + (setq window-size-fixed exwm--fixed-size + exwm--floating-frame frame) + ;; Do the refresh manually. + (remove-hook 'window-configuration-change-hook #'exwm-layout--refresh) + (set-window-buffer window (current-buffer)) ;this changes current buffer + (add-hook 'window-configuration-change-hook #'exwm-layout--refresh) + (set-window-dedicated-p window t) + (exwm-layout--show id window)) + (with-current-buffer (exwm--id->buffer id) + (if (exwm-layout--iconic-state-p id) + ;; Hide iconic floating X windows. + (exwm-floating-hide) + (with-selected-frame exwm--frame + (exwm-layout--refresh))) + (select-frame-set-input-focus frame)) + ;; FIXME: Strangely, the Emacs frame can move itself at this point + ;; when there are left/top struts set. Force resetting its + ;; position seems working, but it'd better to figure out why. + ;; FIXME: This also happens in another case (#220) where the cause is + ;; still unclear. + (exwm--set-geometry outer-id 0 0 nil nil) + (xcb:flush exwm--connection)) + (with-current-buffer (exwm--id->buffer id) + (run-hooks 'exwm-floating-setup-hook)) + ;; Redraw the frame. + (redisplay t)) + +(defun exwm-floating--unset-floating (id) + "Make window ID non-floating." + (exwm--log "#x%x" id) + (let ((buffer (exwm--id->buffer id))) + (with-current-buffer buffer + (when exwm--floating-frame + ;; The X window is already mapped. + ;; Unmap the X window. + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:NoEvent)) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask (exwm--get-client-event-mask))) + ;; Reparent the floating frame back to the root window. + (let ((frame-id (frame-parameter exwm--floating-frame 'exwm-outer-id)) + (frame-container (frame-parameter exwm--floating-frame + 'exwm-container))) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window frame-id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window frame-id + :parent exwm--root + :x 0 :y 0)) + ;; Also destroy its container. + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow :window frame-container)))) + ;; Place the X window just above the reference X window. + ;; (the stacking order won't change from now on). + ;; Also hide the possible floating border. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window id + :value-mask (logior xcb:ConfigWindow:BorderWidth + xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :border-width 0 + :sibling exwm--guide-window + :stack-mode xcb:StackMode:Above))) + (exwm-floating--set-allowed-actions id t) + (xcb:flush exwm--connection) + (with-current-buffer buffer + (when exwm--floating-frame ;from floating to non-floating + (set-window-dedicated-p (frame-first-window exwm--floating-frame) nil) + ;; Select a tiling window and delete the old frame. + (select-window (frame-selected-window exwm-workspace--current)) + (with-current-buffer buffer + (delete-frame exwm--floating-frame)))) + (with-current-buffer buffer + (setq window-size-fixed nil + exwm--floating-frame nil) + (if (not (plist-member exwm--configurations 'tiling-mode-line)) + (when exwm--mode-line-format + (setq mode-line-format exwm--mode-line-format)) + (setq exwm--mode-line-format (or exwm--mode-line-format + mode-line-format) + mode-line-format (plist-get exwm--configurations + 'tiling-mode-line))) + (if (not (plist-member exwm--configurations 'tiling-header-line)) + (setq header-line-format nil) + (setq header-line-format (plist-get exwm--configurations + 'tiling-header-line)))) + ;; Only show X windows in normal state. + (unless (exwm-layout--iconic-state-p) + (pop-to-buffer-same-window buffer))) + (with-current-buffer (exwm--id->buffer id) + (run-hooks 'exwm-floating-exit-hook))) + +;;;###autoload +(cl-defun exwm-floating-toggle-floating () + "Toggle the current window between floating and non-floating states." + (interactive) + (exwm--log) + (unless (derived-mode-p 'exwm-mode) + (cl-return-from exwm-floating-toggle-floating)) + (with-current-buffer (window-buffer) + (if exwm--floating-frame + (exwm-floating--unset-floating exwm--id) + (exwm-floating--set-floating exwm--id)))) + +;;;###autoload +(defun exwm-floating-hide () + "Hide the current floating X window (which would show again when selected)." + (interactive) + (exwm--log) + (when (and (derived-mode-p 'exwm-mode) + exwm--floating-frame) + (exwm-layout--hide exwm--id) + (select-frame-set-input-focus exwm-workspace--current))) + +(defun exwm-floating--start-moveresize (id &optional type) + "Start move/resize." + (exwm--log "#x%x" id) + (let ((buffer-or-id (or (exwm--id->buffer id) id)) + frame container-or-id x y width height cursor) + (if (bufferp buffer-or-id) + ;; Managed. + (with-current-buffer buffer-or-id + (setq frame exwm--floating-frame + container-or-id (frame-parameter exwm--floating-frame + 'exwm-container))) + ;; Unmanaged. + (setq container-or-id id)) + (when (and container-or-id + ;; Test if the pointer can be grabbed + (= xcb:GrabStatus:Success + (slot-value + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GrabPointer + :owner-events 0 + :grab-window container-or-id + :event-mask xcb:EventMask:NoEvent + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async + :confine-to xcb:Window:None + :cursor xcb:Cursor:None + :time xcb:Time:CurrentTime)) + 'status))) + (with-slots (root-x root-y win-x win-y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryPointer :window id)) + (if (not (bufferp buffer-or-id)) + ;; Unmanaged. + (unless (eq type xcb:ewmh:_NET_WM_MOVERESIZE_MOVE) + (with-slots ((width* width) + (height* height)) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry :drawable id)) + (setq width width* + height height*))) + ;; Managed. + (select-window (frame-first-window frame)) ;transfer input focus + (setq width (frame-pixel-width frame) + height (frame-pixel-height frame)) + (unless type + ;; Determine the resize type according to the pointer position + ;; Clicking the center 1/3 part to resize has no effect + (setq x (/ (* 3 win-x) (float width)) + y (/ (* 3 win-y) (float height)) + type (cond ((and (< x 1) (< y 1)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPLEFT) + ((and (> x 2) (< y 1)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPRIGHT) + ((and (> x 2) (> y 2)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT) + ((and (< x 1) (> y 2)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT) + ((> x 2) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_RIGHT) + ((> y 2) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOM) + ((< x 1) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_LEFT) + ((< y 1) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOP))))) + (if (not type) + (exwm-floating--stop-moveresize) + (cond ((= type xcb:ewmh:_NET_WM_MOVERESIZE_MOVE) + (setq cursor exwm-floating--cursor-move + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y)) + (- x win-x) (- y win-y) 0 0)))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPLEFT) + (setq cursor exwm-floating--cursor-top-left + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + (- x win-x) (- y win-y) + (- (+ root-x width) x) + (- (+ root-y height) y))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOP) + (setq cursor exwm-floating--cursor-top + exwm-floating--moveresize-calculate + (lambda (_x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Height)) + 0 (- y win-y) 0 (- (+ root-y height) y))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPRIGHT) + (setq cursor exwm-floating--cursor-top-right + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + 0 (- y win-y) (- x (- root-x width)) + (- (+ root-y height) y))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_RIGHT) + (setq cursor exwm-floating--cursor-right + exwm-floating--moveresize-calculate + (lambda (x _y) + (vector buffer-or-id + xcb:ConfigWindow:Width + 0 0 (- x (- root-x width)) 0)))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT) + (setq cursor exwm-floating--cursor-bottom-right + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + 0 0 (- x (- root-x width)) + (- y (- root-y height)))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOM) + (setq cursor exwm-floating--cursor-bottom + exwm-floating--moveresize-calculate + (lambda (_x y) + (vector buffer-or-id + xcb:ConfigWindow:Height + 0 0 0 (- y (- root-y height)))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT) + (setq cursor exwm-floating--cursor-bottom-left + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + (- x win-x) + 0 + (- (+ root-x width) x) + (- y (- root-y height)))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_LEFT) + (setq cursor exwm-floating--cursor-left + exwm-floating--moveresize-calculate + (lambda (x _y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Width)) + (- x win-x) 0 (- (+ root-x width) x) 0))))) + ;; Select events and change cursor (should always succeed) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GrabPointer + :owner-events 0 :grab-window container-or-id + :event-mask (eval-when-compile + (logior xcb:EventMask:ButtonRelease + xcb:EventMask:ButtonMotion)) + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async + :confine-to xcb:Window:None + :cursor cursor + :time xcb:Time:CurrentTime))))))) + +(defun exwm-floating--stop-moveresize (&rest _args) + "Stop move/resize." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:UngrabPointer :time xcb:Time:CurrentTime)) + (when exwm-floating--moveresize-calculate + (let (result buffer-or-id outer-id container-id) + (setq result (funcall exwm-floating--moveresize-calculate 0 0) + buffer-or-id (aref result 0)) + (when (bufferp buffer-or-id) + (with-current-buffer buffer-or-id + (setq outer-id (frame-parameter exwm--floating-frame 'exwm-outer-id) + container-id (frame-parameter exwm--floating-frame + 'exwm-container)) + (with-slots (x y width height border-width) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container-id)) + ;; Notify Emacs frame about this the position change. + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination outer-id + :event-mask xcb:EventMask:StructureNotify + :event + (xcb:marshal + (make-instance 'xcb:ConfigureNotify + :event outer-id + :window outer-id + :above-sibling xcb:Window:None + :x (+ x border-width) + :y (+ y border-width) + :width width + :height height + :border-width 0 + :override-redirect 0) + exwm--connection))) + (xcb:flush exwm--connection)) + (exwm-layout--show exwm--id + (frame-root-window exwm--floating-frame))))) + (setq exwm-floating--moveresize-calculate nil))) + +(defun exwm-floating--do-moveresize (data _synthetic) + "Perform move/resize." + (when exwm-floating--moveresize-calculate + (let* ((obj (make-instance 'xcb:MotionNotify)) + result value-mask x y width height buffer-or-id container-or-id) + (xcb:unmarshal obj data) + (setq result (funcall exwm-floating--moveresize-calculate + (slot-value obj 'root-x) (slot-value obj 'root-y)) + buffer-or-id (aref result 0) + value-mask (aref result 1) + x (aref result 2) + y (aref result 3) + width (max 1 (aref result 4)) + height (max 1 (aref result 5))) + (if (not (bufferp buffer-or-id)) + ;; Unmanaged. + (setq container-or-id buffer-or-id) + ;; Managed. + (setq container-or-id + (with-current-buffer buffer-or-id + (frame-parameter exwm--floating-frame 'exwm-container)) + x (- x exwm-floating-border-width) + ;; Use `frame-outer-height' in the future. + y (- y exwm-floating-border-width + exwm-workspace--window-y-offset) + height (+ height exwm-workspace--window-y-offset))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container-or-id + :value-mask (aref result 1) + :x x + :y y + :width width + :height height)) + (when (bufferp buffer-or-id) + ;; Managed. + (setq value-mask (logand value-mask (logior xcb:ConfigWindow:Width + xcb:ConfigWindow:Height))) + (when (/= 0 value-mask) + (with-current-buffer buffer-or-id + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-outer-id) + :value-mask value-mask + :width width + :height height))))) + (xcb:flush exwm--connection)))) + +(defun exwm-floating-move (&optional delta-x delta-y) + "Move a floating window right by DELTA-X pixels and down by DELTA-Y pixels. + +Both DELTA-X and DELTA-Y default to 1. This command should be bound locally." + (exwm--log "delta-x: %s, delta-y: %s" delta-x delta-y) + (unless (and (derived-mode-p 'exwm-mode) exwm--floating-frame) + (user-error "[EXWM] `exwm-floating-move' is only for floating X windows")) + (unless delta-x (setq delta-x 1)) + (unless delta-y (setq delta-y 1)) + (unless (and (= 0 delta-x) (= 0 delta-y)) + (let* ((floating-container (frame-parameter exwm--floating-frame + 'exwm-container)) + (geometry (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable floating-container))) + (edges (window-inside-absolute-pixel-edges))) + (with-slots (x y) geometry + (exwm--set-geometry floating-container + (+ x delta-x) (+ y delta-y) nil nil)) + (exwm--set-geometry exwm--id + (+ (pop edges) delta-x) + (+ (pop edges) delta-y) + nil nil)) + (xcb:flush exwm--connection))) + +(defun exwm-floating--init () + "Initialize floating module." + (exwm--log) + ;; Initialize cursors for moving/resizing a window + (xcb:cursor:init exwm--connection) + (setq exwm-floating--cursor-move + (xcb:cursor:load-cursor exwm--connection "fleur") + exwm-floating--cursor-top-left + (xcb:cursor:load-cursor exwm--connection "top_left_corner") + exwm-floating--cursor-top + (xcb:cursor:load-cursor exwm--connection "top_side") + exwm-floating--cursor-top-right + (xcb:cursor:load-cursor exwm--connection "top_right_corner") + exwm-floating--cursor-right + (xcb:cursor:load-cursor exwm--connection "right_side") + exwm-floating--cursor-bottom-right + (xcb:cursor:load-cursor exwm--connection "bottom_right_corner") + exwm-floating--cursor-bottom + (xcb:cursor:load-cursor exwm--connection "bottom_side") + exwm-floating--cursor-bottom-left + (xcb:cursor:load-cursor exwm--connection "bottom_left_corner") + exwm-floating--cursor-left + (xcb:cursor:load-cursor exwm--connection "left_side"))) + +(defun exwm-floating--exit () + "Exit the floating module." + (exwm--log)) + + + +(provide 'exwm-floating) + +;;; exwm-floating.el ends here diff --git a/third_party/emacs/exwm/exwm-input.el b/third_party/emacs/exwm/exwm-input.el new file mode 100644 index 000000000000..decfc8128cc9 --- /dev/null +++ b/third_party/emacs/exwm/exwm-input.el @@ -0,0 +1,1227 @@ +;;; exwm-input.el --- Input Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module deals with key/mouse matters, including: +;; + Input focus, +;; + Key/Button event handling, +;; + Key events filtering and simulation. + +;; Todo: +;; + Pointer simulation mode (e.g. 'C-c 1'/'C-c 2' for single/double click, +;; move with arrow keys). +;; + Simulation keys to mimic Emacs key bindings for text edit (redo, select, +;; cancel, clear, etc). Some of them are not present on common keyboard +;; (keycode = 0). May need to use XKB extension. + +;;; Code: + +(require 'xcb-keysyms) +(require 'exwm-core) + +(defgroup exwm-input nil + "Input." + :version "25.3" + :group 'exwm) + +(defcustom exwm-input-prefix-keys + '(?\C-x ?\C-u ?\C-h ?\M-x ?\M-` ?\M-& ?\M-:) + "List of prefix keys EXWM should forward to Emacs when in line-mode. + +The point is to make keys like 'C-x C-f' forwarded to Emacs in line-mode. +There is no need to add prefix keys for global/simulation keys or those +defined in `exwm-mode-map' here." + :type '(repeat key-sequence) + :get (lambda (symbol) + (mapcar #'vector (default-value symbol))) + :set (lambda (symbol value) + (set symbol (mapcar (lambda (i) + (if (sequencep i) + (aref i 0) + i)) + value)))) + +(defcustom exwm-input-move-event 's-down-mouse-1 + "Emacs event to start moving a window." + :type 'key-sequence + :get (lambda (symbol) + (let ((value (default-value symbol))) + (if (mouse-event-p value) + value + (vector value)))) + :set (lambda (symbol value) + (set symbol (if (sequencep value) + (aref value 0) + value)))) + +(defcustom exwm-input-resize-event 's-down-mouse-3 + "Emacs event to start resizing a window." + :type 'key-sequence + :get (lambda (symbol) + (let ((value (default-value symbol))) + (if (mouse-event-p value) + value + (vector value)))) + :set (lambda (symbol value) + (set symbol (if (sequencep value) + (aref value 0) + value)))) + +(defcustom exwm-input-line-mode-passthrough nil + "Non-nil makes 'line-mode' forward all events to Emacs." + :type 'boolean) + +;; Input focus update requests should be accumulated for a short time +;; interval so that only the last one need to be processed. This not +;; improves the overall performance, but avoids the problem of input +;; focus loop, which is a result of the interaction with Emacs frames. +;; +;; FIXME: The time interval is hard to decide and perhaps machine-dependent. +;; A value too small can cause redundant updates of input focus, +;; and even worse, dead loops. OTOH a large value would bring +;; laggy experience. +(defconst exwm-input--update-focus-interval 0.01 + "Time interval (in seconds) for accumulating input focus update requests.") + +(defvar exwm-input--during-command nil + "Indicate whether between `pre-command-hook' and `post-command-hook'.") + +(defvar exwm-input--global-keys nil "Global key bindings.") + +(defvar exwm-input--global-prefix-keys nil + "List of prefix keys of global key bindings.") + +(defvar exwm-input--line-mode-cache nil "Cache for incomplete key sequence.") + +(defvar exwm-input--local-simulation-keys nil + "Whether simulation keys are local.") + +(defvar exwm-input--simulation-keys nil "Simulation keys in line-mode.") + +(defvar exwm-input--skip-buffer-list-update nil + "Skip the upcoming 'buffer-list-update'.") + +(defvar exwm-input--temp-line-mode nil + "Non-nil indicates it's in temporary line-mode for char-mode.") + +(defvar exwm-input--timestamp-atom nil) + +(defvar exwm-input--timestamp-callback nil) + +(defvar exwm-input--timestamp-window nil) + +(defvar exwm-input--update-focus-defer-timer nil "Timer for polling the lock.") + +(defvar exwm-input--update-focus-lock nil + "Lock for solving input focus update contention.") + +(defvar exwm-input--update-focus-timer nil + "Timer for deferring the update of input focus.") + +(defvar exwm-input--update-focus-window nil "The (Emacs) window to be focused. +This value should always be overwritten.") + +(defvar exwm-input--echo-area-timer nil "Timer for detecting echo area dirty.") + +(defvar exwm-input--event-hook nil + "Hook to run when EXWM receives an event.") + +(defvar exwm-input-input-mode-change-hook nil + "Hook to run when an input mode changes on an `exwm-mode' buffer. +Current buffer will be the `exwm-mode' buffer when this hook runs.") + +(defvar exwm-workspace--current) +(declare-function exwm-floating--do-moveresize "exwm-floating.el" + (data _synthetic)) +(declare-function exwm-floating--start-moveresize "exwm-floating.el" + (id &optional type)) +(declare-function exwm-floating--stop-moveresize "exwm-floating.el" + (&rest _args)) +(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id)) +(declare-function exwm-layout--show "exwm-layout.el" (id &optional window)) +(declare-function exwm-reset "exwm.el" ()) +(declare-function exwm-workspace--client-p "exwm-workspace.el" + (&optional frame)) +(declare-function exwm-workspace--minibuffer-own-frame-p "exwm-workspace.el") +(declare-function exwm-workspace--workspace-p "exwm-workspace.el" (workspace)) +(declare-function exwm-workspace-switch "exwm-workspace.el" + (frame-or-index &optional force)) + +(defun exwm-input--set-focus (id) + "Set input focus to window ID in a proper way." + (let ((from (slot-value (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetInputFocus)) + 'focus)) + tree) + (if (or (exwm--id->buffer from) + (eq from id)) + (exwm--log "#x%x => #x%x" (or from 0) (or id 0)) + ;; Attempt to find the top-level X window for a 'focus proxy'. + (unless (= from xcb:Window:None) + (setq tree (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryTree + :window from))) + (when tree + (setq from (slot-value tree 'parent)))) + (exwm--log "#x%x (corrected) => #x%x" (or from 0) (or id 0))) + (when (and (exwm--id->buffer id) + ;; Avoid redundant input focus transfer. + (not (eq from id))) + (with-current-buffer (exwm--id->buffer id) + (exwm-input--update-timestamp + (lambda (timestamp id send-input-focus wm-take-focus) + (when send-input-focus + (xcb:+request exwm--connection + (make-instance 'xcb:SetInputFocus + :revert-to xcb:InputFocus:Parent + :focus id + :time timestamp))) + (when wm-take-focus + (let ((event (make-instance 'xcb:icccm:WM_TAKE_FOCUS + :window id + :time timestamp))) + (setq event (xcb:marshal event exwm--connection)) + (xcb:+request exwm--connection + (make-instance 'xcb:icccm:SendEvent + :destination id + :event event)))) + (exwm-input--set-active-window id) + (xcb:flush exwm--connection)) + id + (or exwm--hints-input + (not (memq xcb:Atom:WM_TAKE_FOCUS exwm--protocols))) + (memq xcb:Atom:WM_TAKE_FOCUS exwm--protocols)))))) + +(defun exwm-input--update-timestamp (callback &rest args) + "Fetch the latest timestamp from the server and feed it to CALLBACK. + +ARGS are additional arguments to CALLBACK." + (setq exwm-input--timestamp-callback (cons callback args)) + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Replace + :window exwm-input--timestamp-window + :property exwm-input--timestamp-atom + :type xcb:Atom:CARDINAL + :format 32 + :data-len 0 + :data nil)) + (xcb:flush exwm--connection)) + +(defun exwm-input--on-PropertyNotify (data _synthetic) + "Handle PropertyNotify events." + (exwm--log) + (when exwm-input--timestamp-callback + (let ((obj (make-instance 'xcb:PropertyNotify))) + (xcb:unmarshal obj data) + (when (= exwm-input--timestamp-window + (slot-value obj 'window)) + (apply (car exwm-input--timestamp-callback) + (slot-value obj 'time) + (cdr exwm-input--timestamp-callback)) + (setq exwm-input--timestamp-callback nil))))) + +(defvar exwm-input--last-enter-notify-position nil) + +(defun exwm-input--on-EnterNotify (data _synthetic) + "Handle EnterNotify events." + (let ((evt (make-instance 'xcb:EnterNotify)) + buffer window frame frame-xid edges fake-evt) + (xcb:unmarshal evt data) + (with-slots (time root event root-x root-y event-x event-y state) evt + (setq buffer (exwm--id->buffer event) + window (get-buffer-window buffer t)) + (exwm--log "buffer=%s; window=%s" buffer window) + (when (and buffer window (not (eq window (selected-window))) + (not (equal exwm-input--last-enter-notify-position + (vector root-x root-y)))) + (setq frame (window-frame window) + frame-xid (frame-parameter frame 'exwm-id)) + (unless (eq frame exwm-workspace--current) + (if (exwm-workspace--workspace-p frame) + ;; The X window is on another workspace. + (exwm-workspace-switch frame) + (with-current-buffer buffer + (when (and (derived-mode-p 'exwm-mode) + (not (eq exwm--frame exwm-workspace--current))) + ;; The floating X window is on another workspace. + (exwm-workspace-switch exwm--frame))))) + ;; Send a fake MotionNotify event to Emacs. + (setq edges (window-inside-pixel-edges window) + fake-evt (make-instance 'xcb:MotionNotify + :detail 0 + :time time + :root root + :event frame-xid + :child xcb:Window:None + :root-x root-x + :root-y root-y + :event-x (+ event-x (elt edges 0)) + :event-y (+ event-y (elt edges 1)) + :state state + :same-screen 1)) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination frame-xid + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal fake-evt exwm--connection))) + (xcb:flush exwm--connection)) + (setq exwm-input--last-enter-notify-position (vector root-x root-y))))) + +(defun exwm-input--on-keysyms-update () + (exwm--log) + (let ((exwm-input--global-prefix-keys nil)) + (exwm-input--update-global-prefix-keys))) + +(defun exwm-input--on-buffer-list-update () + "Run in `buffer-list-update-hook' to track input focus." + (when (and (not (exwm-workspace--client-p)) + (not exwm-input--skip-buffer-list-update)) + (exwm--log "current-buffer=%S selected-window=%S" + (current-buffer) (selected-window)) + (redirect-frame-focus (selected-frame) nil) + (setq exwm-input--update-focus-window (selected-window)) + (exwm-input--update-focus-defer))) + +(defun exwm-input--update-focus-defer () + "Defer updating input focus." + (when exwm-input--update-focus-defer-timer + (cancel-timer exwm-input--update-focus-defer-timer)) + (if exwm-input--update-focus-lock + (setq exwm-input--update-focus-defer-timer + (exwm--defer 0 #'exwm-input--update-focus-defer)) + (setq exwm-input--update-focus-defer-timer nil) + (when exwm-input--update-focus-timer + (cancel-timer exwm-input--update-focus-timer)) + (setq exwm-input--update-focus-timer + ;; Attempt to accumulate successive events close enough. + (run-with-timer exwm-input--update-focus-interval + nil + #'exwm-input--update-focus-commit + exwm-input--update-focus-window)))) + +(defun exwm-input--update-focus-commit (window) + "Commit updating input focus." + (setq exwm-input--update-focus-lock t) + (unwind-protect + (exwm-input--update-focus window) + (setq exwm-input--update-focus-lock nil))) + +(defun exwm-input--update-focus (window) + "Update input focus." + (when (window-live-p window) + (exwm--log "focus-window=%s focus-buffer=%s" window (window-buffer window)) + (with-current-buffer (window-buffer window) + (if (derived-mode-p 'exwm-mode) + (if (not (eq exwm--frame exwm-workspace--current)) + (progn + (set-frame-parameter exwm--frame 'exwm-selected-window window) + (exwm--defer 0 #'exwm-workspace-switch exwm--frame)) + (exwm--log "Set focus on #x%x" exwm--id) + (when exwm--floating-frame + ;; Adjust stacking orders of the floating X window. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window exwm--id + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:TopIf)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-container) + :value-mask (logior + xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling exwm--id + :stack-mode xcb:StackMode:Below)) + ;; This floating X window might be hide by `exwm-floating-hide'. + (when (exwm-layout--iconic-state-p) + (exwm-layout--show exwm--id window)) + (xcb:flush exwm--connection)) + (exwm-input--set-focus exwm--id)) + (when (eq (selected-window) window) + (exwm--log "Focus on %s" window) + (if (and (exwm-workspace--workspace-p (selected-frame)) + (not (eq (selected-frame) exwm-workspace--current))) + ;; The focus is on another workspace (e.g. it got clicked) + ;; so switch to it. + (progn + (exwm--log "Switching to %s's workspace %s (%s)" + window + (window-frame window) + (selected-frame)) + (set-frame-parameter (selected-frame) 'exwm-selected-window + window) + (exwm--defer 0 #'exwm-workspace-switch (selected-frame))) + ;; The focus is still on the current workspace. + (if (not (and (exwm-workspace--minibuffer-own-frame-p) + (minibufferp))) + (x-focus-frame (window-frame window)) + ;; X input focus should be set on the previously selected + ;; frame. + (x-focus-frame (window-frame (minibuffer-window)))) + (exwm-input--set-active-window) + (xcb:flush exwm--connection))))))) + +(defun exwm-input--set-active-window (&optional id) + "Set _NET_ACTIVE_WINDOW." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_ACTIVE_WINDOW + :window exwm--root + :data (or id xcb:Window:None)))) + +(defun exwm-input--on-ButtonPress (data _synthetic) + "Handle ButtonPress event." + (let ((obj (make-instance 'xcb:ButtonPress)) + (mode xcb:Allow:SyncPointer) + button-event window buffer frame fake-last-command) + (xcb:unmarshal obj data) + (exwm--log "major-mode=%s buffer=%s" + major-mode (buffer-name (current-buffer))) + (with-slots (detail event state) obj + (setq button-event (xcb:keysyms:keysym->event exwm--connection + detail state) + buffer (exwm--id->buffer event) + window (get-buffer-window buffer t)) + (cond ((and (eq button-event exwm-input-move-event) + buffer + ;; Either an undecorated or a floating X window. + (with-current-buffer buffer + (or (not (derived-mode-p 'exwm-mode)) + exwm--floating-frame))) + ;; Move + (exwm-floating--start-moveresize + event xcb:ewmh:_NET_WM_MOVERESIZE_MOVE)) + ((and (eq button-event exwm-input-resize-event) + buffer + (with-current-buffer buffer + (or (not (derived-mode-p 'exwm-mode)) + exwm--floating-frame))) + ;; Resize + (exwm-floating--start-moveresize event)) + (buffer + ;; Click to focus + (setq fake-last-command t) + (unless (eq window (selected-window)) + (setq frame (window-frame window)) + (unless (eq frame exwm-workspace--current) + (if (exwm-workspace--workspace-p frame) + ;; The X window is on another workspace + (exwm-workspace-switch frame) + (with-current-buffer buffer + (when (and (derived-mode-p 'exwm-mode) + (not (eq exwm--frame + exwm-workspace--current))) + ;; The floating X window is on another workspace + (exwm-workspace-switch exwm--frame))))) + ;; It has been reported that the `window' may have be deleted + (if (window-live-p window) + (select-window window) + (setq window (get-buffer-window buffer t)) + (when window (select-window window)))) + ;; Also process keybindings. + (with-current-buffer buffer + (when (derived-mode-p 'exwm-mode) + (cl-case exwm--input-mode + (line-mode + (setq mode (exwm-input--on-ButtonPress-line-mode + buffer button-event))) + (char-mode + (setq mode (exwm-input--on-ButtonPress-char-mode))))))) + (t + ;; Replay this event by default. + (setq fake-last-command t) + (setq mode xcb:Allow:ReplayPointer)))) + (when fake-last-command + (exwm-input--fake-last-command)) + (xcb:+request exwm--connection + (make-instance 'xcb:AllowEvents :mode mode :time xcb:Time:CurrentTime)) + (xcb:flush exwm--connection)) + (run-hooks 'exwm-input--event-hook)) + +(defun exwm-input--on-KeyPress (data _synthetic) + "Handle KeyPress event." + (with-current-buffer (window-buffer (selected-window)) + (let ((obj (make-instance 'xcb:KeyPress))) + (xcb:unmarshal obj data) + (exwm--log "major-mode=%s buffer=%s" + major-mode (buffer-name (current-buffer))) + (if (derived-mode-p 'exwm-mode) + (cl-case exwm--input-mode + (line-mode + (exwm-input--on-KeyPress-line-mode obj data)) + (char-mode + (exwm-input--on-KeyPress-char-mode obj data))) + (exwm-input--on-KeyPress-char-mode obj))) + (run-hooks 'exwm-input--event-hook))) + +(defun exwm-input--on-CreateNotify (data _synthetic) + "Handle CreateNotify events." + (exwm--log) + (let ((evt (make-instance 'xcb:CreateNotify))) + (xcb:unmarshal evt data) + (with-slots (window) evt + (exwm-input--grab-global-prefix-keys window)))) + +(defun exwm-input--update-global-prefix-keys () + "Update `exwm-input--global-prefix-keys'." + (exwm--log) + (when exwm--connection + (let ((original exwm-input--global-prefix-keys)) + (setq exwm-input--global-prefix-keys nil) + (dolist (i exwm-input--global-keys) + (cl-pushnew (elt i 0) exwm-input--global-prefix-keys)) + (unless (equal original exwm-input--global-prefix-keys) + (apply #'exwm-input--grab-global-prefix-keys + (slot-value (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryTree + :window exwm--root)) + 'children)))))) + +(defun exwm-input--grab-global-prefix-keys (&rest xwins) + (exwm--log) + (let ((req (make-instance 'xcb:GrabKey + :owner-events 0 + :grab-window nil + :modifiers nil + :key nil + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async)) + keysyms keycode alt-modifier) + (dolist (k exwm-input--global-prefix-keys) + (setq keysyms (xcb:keysyms:event->keysyms exwm--connection k)) + (if (not keysyms) + (warn "Key unavailable: %s" (key-description (vector k))) + (setq keycode (xcb:keysyms:keysym->keycode exwm--connection + (caar keysyms))) + (exwm--log "Grabbing key=%s (keysyms=%s keycode=%s)" + (single-key-description k) keysyms keycode) + (dolist (keysym keysyms) + (setf (slot-value req 'modifiers) (cdr keysym) + (slot-value req 'key) keycode) + ;; Also grab this key with num-lock mask set. + (when (and (/= 0 xcb:keysyms:num-lock-mask) + (= 0 (logand (cdr keysym) xcb:keysyms:num-lock-mask))) + (setf alt-modifier (logior (cdr keysym) + xcb:keysyms:num-lock-mask))) + (dolist (xwin xwins) + (setf (slot-value req 'grab-window) xwin) + (xcb:+request exwm--connection req) + (when alt-modifier + (setf (slot-value req 'modifiers) alt-modifier) + (xcb:+request exwm--connection req)))))) + (xcb:flush exwm--connection))) + +(defun exwm-input--set-key (key command) + (exwm--log "key: %s, command: %s" key command) + (global-set-key key command) + (cl-pushnew key exwm-input--global-keys)) + +(defcustom exwm-input-global-keys nil + "Global keys. + +It is an alist of the form (key . command), meaning giving KEY (a key +sequence) a global binding as COMMAND. + +Notes: +* Setting the value directly (rather than customizing it) after EXWM + finishes initialization has no effect." + :type '(alist :key-type key-sequence :value-type function) + :set (lambda (symbol value) + (when (boundp symbol) + (dolist (i (symbol-value symbol)) + (global-unset-key (car i)))) + (set symbol value) + (setq exwm-input--global-keys nil) + (dolist (i value) + (exwm-input--set-key (car i) (cdr i))) + (when exwm--connection + (exwm-input--update-global-prefix-keys)))) + +;;;###autoload +(defun exwm-input-set-key (key command) + "Set a global key binding. + +The new key binding only takes effect in real time when this command is +called interactively, and is lost when this session ends unless it's +specifically saved in the Customize interface for `exwm-input-global-keys'. + +In configuration you should customize or set `exwm-input-global-keys' +instead." + (interactive "KSet key globally: \nCSet key %s to command: ") + (exwm--log) + (setq exwm-input-global-keys (append exwm-input-global-keys + (list (cons key command)))) + (exwm-input--set-key key command) + (when (called-interactively-p 'any) + (exwm-input--update-global-prefix-keys))) + +;; Putting (t . EVENT) into `unread-command-events' does not really work +;; as documented for Emacs < 26.2. +(eval-and-compile + (if (or (< emacs-major-version 26) + (and (= emacs-major-version 26) + (< emacs-minor-version 2))) + (defsubst exwm-input--unread-event (event) + (setq unread-command-events + (append unread-command-events (list event)))) + (defsubst exwm-input--unread-event (event) + (setq unread-command-events + (append unread-command-events `((t . ,event))))))) + +(defun exwm-input--mimic-read-event (event) + "Process EVENT as if it were returned by `read-event'." + (exwm--log) + (unless (eq 0 extra-keyboard-modifiers) + (setq event (event-convert-list (append (event-modifiers + extra-keyboard-modifiers) + event)))) + (when (characterp event) + (let ((event* (when keyboard-translate-table + (aref keyboard-translate-table event)))) + (when event* + (setq event event*)))) + event) + +(cl-defun exwm-input--translate (key) + (let (translation) + (dolist (map (list input-decode-map + local-function-key-map + key-translation-map)) + (setq translation (lookup-key map key)) + (if (functionp translation) + (cl-return-from exwm-input--translate (funcall translation nil)) + (when (vectorp translation) + (cl-return-from exwm-input--translate translation))))) + key) + +(defun exwm-input--cache-event (event &optional temp-line-mode) + "Cache EVENT." + (exwm--log "%s" event) + (setq exwm-input--line-mode-cache + (vconcat exwm-input--line-mode-cache (vector event))) + ;; Attempt to translate this key sequence. + (setq exwm-input--line-mode-cache + (exwm-input--translate exwm-input--line-mode-cache)) + ;; When the key sequence is complete (not a keymap). + ;; Note that `exwm-input--line-mode-cache' might get translated to nil, for + ;; example 'mouse--down-1-maybe-follows-link' does this. + (if (and exwm-input--line-mode-cache + (keymapp (key-binding exwm-input--line-mode-cache))) + ;; Grab keyboard temporarily to intercept the complete key sequence. + (when temp-line-mode + (setq exwm-input--temp-line-mode t) + (exwm-input--grab-keyboard)) + (setq exwm-input--line-mode-cache nil) + (when exwm-input--temp-line-mode + (setq exwm-input--temp-line-mode nil) + (exwm-input--release-keyboard)))) + +(defun exwm-input--event-passthrough-p (event) + "Whether EVENT should be passed to Emacs. +Current buffer must be an `exwm-mode' buffer." + (or exwm-input-line-mode-passthrough + exwm-input--during-command + ;; Forward the event when there is an incomplete key + ;; sequence or when the minibuffer is active. + exwm-input--line-mode-cache + (eq (active-minibuffer-window) (selected-window)) + ;; + (memq event exwm-input--global-prefix-keys) + (memq event exwm-input-prefix-keys) + (when overriding-terminal-local-map + (lookup-key overriding-terminal-local-map + (vector event))) + (lookup-key (current-local-map) (vector event)) + (gethash event exwm-input--simulation-keys))) + +(defun exwm-input--noop (&rest _args) + "A placeholder command." + (interactive)) + +(defun exwm-input--fake-last-command () + "Fool some packages into thinking there is a change in the buffer." + (setq last-command #'exwm-input--noop) + (run-hooks 'pre-command-hook) + (run-hooks 'post-command-hook)) + +(defun exwm-input--on-KeyPress-line-mode (key-press raw-data) + "Parse X KeyPress event to Emacs key event and then feed the command loop." + (with-slots (detail state) key-press + (let ((keysym (xcb:keysyms:keycode->keysym exwm--connection detail state)) + event raw-event mode) + (exwm--log "%s" keysym) + (when (and (/= 0 (car keysym)) + (setq raw-event (xcb:keysyms:keysym->event + exwm--connection (car keysym) + (logand state (lognot (cdr keysym))))) + (setq event (exwm-input--mimic-read-event raw-event)) + (exwm-input--event-passthrough-p event)) + (setq mode xcb:Allow:AsyncKeyboard) + (exwm-input--cache-event event) + (exwm-input--unread-event raw-event)) + (unless mode + (if (= 0 (logand #x6000 state)) ;Check the 13~14 bits. + ;; Not an XKB state; just replay it. + (setq mode xcb:Allow:ReplayKeyboard) + ;; An XKB state; sent it with SendEvent. + ;; FIXME: Can this also be replayed? + ;; FIXME: KeyRelease events are lost. + (setq mode xcb:Allow:AsyncKeyboard) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination (slot-value key-press 'event) + :event-mask xcb:EventMask:NoEvent + :event raw-data))) + (when event + (if (not defining-kbd-macro) + (exwm-input--fake-last-command) + ;; Make Emacs aware of this event when defining keyboard macros. + (set-transient-map `(keymap (t . ,#'exwm-input--noop))) + (exwm-input--unread-event event)))) + (xcb:+request exwm--connection + (make-instance 'xcb:AllowEvents + :mode mode + :time xcb:Time:CurrentTime)) + (xcb:flush exwm--connection)))) + +(defun exwm-input--on-KeyPress-char-mode (key-press &optional _raw-data) + "Handle KeyPress event in char-mode." + (with-slots (detail state) key-press + (let ((keysym (xcb:keysyms:keycode->keysym exwm--connection detail state)) + event raw-event) + (exwm--log "%s" keysym) + (when (and (/= 0 (car keysym)) + (setq raw-event (xcb:keysyms:keysym->event + exwm--connection (car keysym) + (logand state (lognot (cdr keysym))))) + (setq event (exwm-input--mimic-read-event raw-event))) + (if (not (derived-mode-p 'exwm-mode)) + (exwm-input--unread-event raw-event) + (exwm-input--cache-event event t) + (exwm-input--unread-event raw-event))))) + (xcb:+request exwm--connection + (make-instance 'xcb:AllowEvents + :mode xcb:Allow:AsyncKeyboard + :time xcb:Time:CurrentTime)) + (xcb:flush exwm--connection)) + +(defun exwm-input--on-ButtonPress-line-mode (buffer button-event) + "Handle button events in line mode. +BUFFER is the `exwm-mode' buffer the event was generated +on. BUTTON-EVENT is the X event converted into an Emacs event. + +The return value is used as event_mode to release the original +button event." + (with-current-buffer buffer + (let ((read-event (exwm-input--mimic-read-event button-event))) + (exwm--log "%s" read-event) + (if (and read-event + (exwm-input--event-passthrough-p read-event)) + ;; The event should be forwarded to emacs + (progn + (exwm-input--cache-event read-event) + (exwm-input--unread-event button-event) + xcb:Allow:SyncPointer) + ;; The event should be replayed + xcb:Allow:ReplayPointer)))) + +(defun exwm-input--on-ButtonPress-char-mode () + "Handle button events in char-mode. +The return value is used as event_mode to release the original +button event." + (exwm--log) + xcb:Allow:ReplayPointer) + +(defun exwm-input--update-mode-line (id) + "Update the propertized `mode-line-process' for window ID." + (exwm--log "#x%x" id) + (let (help-echo cmd mode) + (with-current-buffer (exwm--id->buffer id) + (cl-case exwm--input-mode + (line-mode + (setq mode "line" + help-echo "mouse-1: Switch to char-mode" + cmd (lambda () + (interactive) + (exwm-input-release-keyboard id)))) + (char-mode + (setq mode "char" + help-echo "mouse-1: Switch to line-mode" + cmd (lambda () + (interactive) + (exwm-input-grab-keyboard id))))) + (setq mode-line-process + `(": " + (:propertize ,mode + help-echo ,help-echo + mouse-face mode-line-highlight + local-map + (keymap + (mode-line + keymap + (down-mouse-1 . ,cmd)))))) + (force-mode-line-update)))) + +(defun exwm-input--grab-keyboard (&optional id) + "Grab all key events on window ID." + (unless id (setq id (exwm--buffer->id (window-buffer)))) + (when id + (exwm--log "id=#x%x" id) + (when (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:GrabKey + :owner-events 0 + :grab-window id + :modifiers xcb:ModMask:Any + :key xcb:Grab:Any + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Sync)) + (exwm--log "Failed to grab keyboard for #x%x" id)) + (let ((buffer (exwm--id->buffer id))) + (when buffer + (with-current-buffer buffer + (setq exwm--input-mode 'line-mode) + (run-hooks 'exwm-input-input-mode-change-hook)))))) + +(defun exwm-input--release-keyboard (&optional id) + "Ungrab all key events on window ID." + (unless id (setq id (exwm--buffer->id (window-buffer)))) + (when id + (exwm--log "id=#x%x" id) + (when (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:UngrabKey + :key xcb:Grab:Any + :grab-window id + :modifiers xcb:ModMask:Any)) + (exwm--log "Failed to release keyboard for #x%x" id)) + (exwm-input--grab-global-prefix-keys id) + (let ((buffer (exwm--id->buffer id))) + (when buffer + (with-current-buffer buffer + (setq exwm--input-mode 'char-mode) + (run-hooks 'exwm-input-input-mode-change-hook)))))) + +;;;###autoload +(defun exwm-input-grab-keyboard (&optional id) + "Switch to line-mode." + (interactive (list (when (derived-mode-p 'exwm-mode) + (exwm--buffer->id (window-buffer))))) + (when id + (exwm--log "id=#x%x" id) + (setq exwm--selected-input-mode 'line-mode) + (exwm-input--grab-keyboard id) + (exwm-input--update-mode-line id))) + +;;;###autoload +(defun exwm-input-release-keyboard (&optional id) + "Switch to char-mode." + (interactive (list (when (derived-mode-p 'exwm-mode) + (exwm--buffer->id (window-buffer))))) + (when id + (exwm--log "id=#x%x" id) + (setq exwm--selected-input-mode 'char-mode) + (exwm-input--release-keyboard id) + (exwm-input--update-mode-line id))) + +;;;###autoload +(defun exwm-input-toggle-keyboard (&optional id) + "Toggle between 'line-mode' and 'char-mode'." + (interactive (list (when (derived-mode-p 'exwm-mode) + (exwm--buffer->id (window-buffer))))) + (when id + (exwm--log "id=#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (cl-case exwm--input-mode + (line-mode + (exwm-input-release-keyboard id)) + (char-mode + (exwm-reset)))))) + +(defun exwm-input--fake-key (event) + "Fake a key event equivalent to Emacs event EVENT." + (let* ((keysyms (xcb:keysyms:event->keysyms exwm--connection event)) + keycode id) + (when (= 0 (caar keysyms)) + (user-error "[EXWM] Invalid key: %s" (single-key-description event))) + (setq keycode (xcb:keysyms:keysym->keycode exwm--connection + (caar keysyms))) + (when (/= 0 keycode) + (setq id (exwm--buffer->id (window-buffer (selected-window)))) + (exwm--log "id=#x%x event=%s keycode" id event keycode) + (dolist (class '(xcb:KeyPress xcb:KeyRelease)) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 :destination id + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal + (make-instance class + :detail keycode + :time xcb:Time:CurrentTime + :root exwm--root :event id + :child 0 + :root-x 0 :root-y 0 + :event-x 0 :event-y 0 + :state (cdar keysyms) + :same-screen 1) + exwm--connection))))) + (xcb:flush exwm--connection))) + +;;;###autoload +(cl-defun exwm-input-send-next-key (times &optional end-key) + "Send next key to client window. + +EXWM will prompt for the key to send. This command can be prefixed to send +multiple keys. If END-KEY is non-nil, stop sending keys if it's pressed." + (interactive "p") + (exwm--log) + (unless (derived-mode-p 'exwm-mode) + (cl-return-from exwm-input-send-next-key)) + (when (> times 12) (setq times 12)) + (let (key keys) + (dotimes (i times) + ;; Skip events not from keyboard + (let ((exwm-input-line-mode-passthrough t)) + (catch 'break + (while t + (setq key (read-key (format "Send key: %s (%d/%d) %s" + (key-description keys) + (1+ i) times + (if end-key + (concat "To exit, press: " + (key-description + (list end-key))) + "")))) + (unless (listp key) (throw 'break nil))))) + (setq keys (vconcat keys (vector key))) + (when (eq key end-key) (cl-return-from exwm-input-send-next-key)) + (exwm-input--fake-key key)))) + +(defun exwm-input--set-simulation-keys (simulation-keys &optional no-refresh) + "Set simulation keys." + (exwm--log "%s" simulation-keys) + (unless no-refresh + ;; Unbind simulation keys. + (let ((hash (buffer-local-value 'exwm-input--simulation-keys + (current-buffer)))) + (when (hash-table-p hash) + (maphash (lambda (key _value) + (when (sequencep key) + (if exwm-input--local-simulation-keys + (local-unset-key key) + (define-key exwm-mode-map key nil)))) + hash))) + ;; Abandon the old hash table. + (setq exwm-input--simulation-keys (make-hash-table :test #'equal))) + (dolist (i simulation-keys) + (let ((original (vconcat (car i))) + (simulated (cdr i))) + (setq simulated (if (sequencep simulated) + (append simulated nil) + (list simulated))) + ;; The key stored is a key sequence (vector). + ;; The value stored is a list of key events. + (puthash original simulated exwm-input--simulation-keys) + ;; Also mark the prefix key as used. + (puthash (aref original 0) t exwm-input--simulation-keys))) + ;; Update keymaps. + (maphash (lambda (key _value) + (when (sequencep key) + (if exwm-input--local-simulation-keys + (local-set-key key #'exwm-input-send-simulation-key) + (define-key exwm-mode-map key + #'exwm-input-send-simulation-key)))) + exwm-input--simulation-keys)) + +(defun exwm-input-set-simulation-keys (simulation-keys) + "Please customize or set `exwm-input-simulation-keys' instead." + (declare (obsolete nil "26")) + (exwm-input--set-simulation-keys simulation-keys)) + +(defcustom exwm-input-simulation-keys nil + "Simulation keys. + +It is an alist of the form (original-key . simulated-key), where both +original-key and simulated-key are key sequences. Original-key is what you +type to an X window in line-mode which then gets translated to simulated-key +by EXWM and forwarded to the X window. + +Notes: +* Setting the value directly (rather than customizing it) after EXWM + finishes initialization has no effect. +* Original-keys consist of multiple key events are only supported in Emacs + 26.2 and later. +* A minority of applications do not accept simulated keys by default. It's + required to customize them to accept events sent by SendEvent. +* The predefined examples in the Customize interface are not guaranteed to + work for all applications. This can be tweaked on a per application basis + with `exwm-input-set-local-simulation-keys'." + :type '(alist :key-type (key-sequence :tag "Original") + :value-type (choice (key-sequence :tag "User-defined") + (key-sequence :tag "Move left" [left]) + (key-sequence :tag "Move right" [right]) + (key-sequence :tag "Move up" [up]) + (key-sequence :tag "Move down" [down]) + (key-sequence :tag "Move to BOL" [home]) + (key-sequence :tag "Move to EOL" [end]) + (key-sequence :tag "Page up" [prior]) + (key-sequence :tag "Page down" [next]) + (key-sequence :tag "Copy" [C-c]) + (key-sequence :tag "Paste" [C-v]) + (key-sequence :tag "Delete" [delete]) + (key-sequence :tag "Delete to EOL" + [S-end delete]))) + :set (lambda (symbol value) + (set symbol value) + (exwm-input--set-simulation-keys value))) + +(defcustom exwm-input-pre-post-command-blacklist '(exit-minibuffer + abort-recursive-edit + minibuffer-keyboard-quit) + "Commands impossible to detect with `post-command-hook'." + :type '(repeat function)) + +(cl-defun exwm-input--read-keys (prompt stop-key) + (let ((cursor-in-echo-area t) + keys key) + (while (not (eq key stop-key)) + (setq key (read-key (format "%s (terminate with %s): %s" + prompt + (key-description (vector stop-key)) + (key-description keys))) + keys (vconcat keys (vector key)))) + (when (> (length keys) 1) + (substring keys 0 -1)))) + +;;;###autoload +(defun exwm-input-set-simulation-key (original-key simulated-key) + "Set a simulation key. + +The simulation key takes effect in real time, but is lost when this session +ends unless it's specifically saved in the Customize interface for +`exwm-input-simulation-keys'." + (interactive + (let (original simulated) + (setq original (exwm-input--read-keys "Translate from" ?\C-g)) + (when original + (setq simulated (exwm-input--read-keys + (format "Translate from %s to" + (key-description original)) + ?\C-g))) + (list original simulated))) + (exwm--log "original: %s, simulated: %s" original-key simulated-key) + (when (and original-key simulated-key) + (let ((entry `((,original-key . ,simulated-key)))) + (setq exwm-input-simulation-keys (append exwm-input-simulation-keys + entry)) + (exwm-input--set-simulation-keys entry t)))) + +(defun exwm-input--unset-simulation-keys () + "Clear simulation keys and key bindings defined." + (exwm--log) + (when (hash-table-p exwm-input--simulation-keys) + (maphash (lambda (key _value) + (when (sequencep key) + (define-key exwm-mode-map key nil))) + exwm-input--simulation-keys) + (clrhash exwm-input--simulation-keys))) + +(defun exwm-input-set-local-simulation-keys (simulation-keys) + "Set buffer-local simulation keys. + +SIMULATION-KEYS is an alist of the form (original-key . simulated-key), +where both ORIGINAL-KEY and SIMULATED-KEY are key sequences." + (exwm--log) + (make-local-variable 'exwm-input--simulation-keys) + (use-local-map (copy-keymap exwm-mode-map)) + (let ((exwm-input--local-simulation-keys t)) + (exwm-input--set-simulation-keys simulation-keys))) + +;;;###autoload +(cl-defun exwm-input-send-simulation-key (times) + "Fake a key event according to the last input key sequence." + (interactive "p") + (exwm--log) + (unless (derived-mode-p 'exwm-mode) + (cl-return-from exwm-input-send-simulation-key)) + (let ((keys (gethash (this-single-command-keys) + exwm-input--simulation-keys))) + (dotimes (_ times) + (dolist (key keys) + (exwm-input--fake-key key))))) + +;;;###autoload +(defmacro exwm-input-invoke-factory (keys) + "Make a command that invokes KEYS when called. + +One use is to access the keymap bound to KEYS (as prefix keys) in char-mode." + (let* ((keys (kbd keys)) + (description (key-description keys))) + `(defun ,(intern (concat "exwm-input--invoke--" description)) () + ,(format "Invoke `%s'." description) + (interactive) + (mapc (lambda (key) + (exwm-input--cache-event key t) + (exwm-input--unread-event key)) + ',(listify-key-sequence keys))))) + +(defun exwm-input--on-pre-command () + "Run in `pre-command-hook'." + (unless (or (eq this-command #'exwm-input--noop) + (memq this-command exwm-input-pre-post-command-blacklist)) + (setq exwm-input--during-command t))) + +(defun exwm-input--on-post-command () + "Run in `post-command-hook'." + (unless (eq this-command #'exwm-input--noop) + (setq exwm-input--during-command nil))) + +(defun exwm-input--on-minibuffer-setup () + "Run in `minibuffer-setup-hook' to grab keyboard if necessary." + (exwm--log) + (with-current-buffer + (window-buffer (frame-selected-window exwm-workspace--current)) + (when (and (derived-mode-p 'exwm-mode) + (not (exwm-workspace--client-p)) + (eq exwm--selected-input-mode 'char-mode)) + (exwm-input--grab-keyboard exwm--id)))) + +(defun exwm-input--on-minibuffer-exit () + "Run in `minibuffer-exit-hook' to release keyboard if necessary." + (exwm--log) + (with-current-buffer + (window-buffer (frame-selected-window exwm-workspace--current)) + (when (and (derived-mode-p 'exwm-mode) + (not (exwm-workspace--client-p)) + (eq exwm--selected-input-mode 'char-mode) + (eq exwm--input-mode 'line-mode)) + (exwm-input--release-keyboard exwm--id)))) + +(defun exwm-input--on-echo-area-dirty () + "Run when new message arrives to grab keyboard if necessary." + (exwm--log) + (when (and (not (active-minibuffer-window)) + (not (exwm-workspace--client-p)) + cursor-in-echo-area) + (exwm-input--on-minibuffer-setup))) + +(defun exwm-input--on-echo-area-clear () + "Run in `echo-area-clear-hook' to release keyboard if necessary." + (exwm--log) + (unless (current-message) + (exwm-input--on-minibuffer-exit))) + +(defun exwm-input--init () + "Initialize the keyboard module." + (exwm--log) + ;; Refresh keyboard mapping + (xcb:keysyms:init exwm--connection #'exwm-input--on-keysyms-update) + ;; Create the X window and intern the atom used to fetch timestamp. + (setq exwm-input--timestamp-window (xcb:generate-id exwm--connection)) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid exwm-input--timestamp-window + :parent exwm--root + :x -1 + :y -1 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:CopyFromParent + :visual 0 + :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:PropertyChange)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window exwm-input--timestamp-window + :data "EXWM: exwm-input--timestamp-window")) + (setq exwm-input--timestamp-atom (exwm--intern-atom "_TIME")) + ;; Initialize global keys. + (dolist (i exwm-input-global-keys) + (exwm-input--set-key (car i) (cdr i))) + ;; Initialize simulation keys. + (when exwm-input-simulation-keys + (exwm-input--set-simulation-keys exwm-input-simulation-keys)) + ;; Attach event listeners + (xcb:+event exwm--connection 'xcb:PropertyNotify + #'exwm-input--on-PropertyNotify) + (xcb:+event exwm--connection 'xcb:CreateNotify #'exwm-input--on-CreateNotify) + (xcb:+event exwm--connection 'xcb:KeyPress #'exwm-input--on-KeyPress) + (xcb:+event exwm--connection 'xcb:ButtonPress #'exwm-input--on-ButtonPress) + (xcb:+event exwm--connection 'xcb:ButtonRelease + #'exwm-floating--stop-moveresize) + (xcb:+event exwm--connection 'xcb:MotionNotify + #'exwm-floating--do-moveresize) + (when mouse-autoselect-window + (xcb:+event exwm--connection 'xcb:EnterNotify + #'exwm-input--on-EnterNotify)) + ;; Control `exwm-input--during-command' + (add-hook 'pre-command-hook #'exwm-input--on-pre-command) + (add-hook 'post-command-hook #'exwm-input--on-post-command) + ;; Grab/Release keyboard when minibuffer/echo becomes active/inactive. + (add-hook 'minibuffer-setup-hook #'exwm-input--on-minibuffer-setup) + (add-hook 'minibuffer-exit-hook #'exwm-input--on-minibuffer-exit) + (setq exwm-input--echo-area-timer + (run-with-idle-timer 0 t #'exwm-input--on-echo-area-dirty)) + (add-hook 'echo-area-clear-hook #'exwm-input--on-echo-area-clear) + ;; Update focus when buffer list updates + (add-hook 'buffer-list-update-hook #'exwm-input--on-buffer-list-update)) + +(defun exwm-input--post-init () + "The second stage in the initialization of the input module." + (exwm--log) + (exwm-input--update-global-prefix-keys)) + +(defun exwm-input--exit () + "Exit the input module." + (exwm--log) + (exwm-input--unset-simulation-keys) + (remove-hook 'pre-command-hook #'exwm-input--on-pre-command) + (remove-hook 'post-command-hook #'exwm-input--on-post-command) + (remove-hook 'minibuffer-setup-hook #'exwm-input--on-minibuffer-setup) + (remove-hook 'minibuffer-exit-hook #'exwm-input--on-minibuffer-exit) + (when exwm-input--echo-area-timer + (cancel-timer exwm-input--echo-area-timer) + (setq exwm-input--echo-area-timer nil)) + (remove-hook 'echo-area-clear-hook #'exwm-input--on-echo-area-clear) + (remove-hook 'buffer-list-update-hook #'exwm-input--on-buffer-list-update) + (when exwm-input--update-focus-defer-timer + (cancel-timer exwm-input--update-focus-defer-timer)) + (when exwm-input--update-focus-timer + (cancel-timer exwm-input--update-focus-timer)) + ;; Make input focus working even without a WM. + (xcb:+request exwm--connection + (make-instance 'xcb:SetInputFocus + :revert-to xcb:InputFocus:PointerRoot + :focus exwm--root + :time xcb:Time:CurrentTime)) + (xcb:flush exwm--connection)) + + + +(provide 'exwm-input) + +;;; exwm-input.el ends here diff --git a/third_party/emacs/exwm/exwm-layout.el b/third_party/emacs/exwm/exwm-layout.el new file mode 100644 index 000000000000..79d0c95bcd47 --- /dev/null +++ b/third_party/emacs/exwm/exwm-layout.el @@ -0,0 +1,620 @@ +;;; exwm-layout.el --- Layout Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module is responsible for keeping X client window properly displayed. + +;;; Code: + +(require 'exwm-core) + +(defgroup exwm-layout nil + "Layout." + :version "25.3" + :group 'exwm) + +(defcustom exwm-layout-auto-iconify t + "Non-nil to automatically iconify unused X windows when possible." + :type 'boolean) + +(defcustom exwm-layout-show-all-buffers nil + "Non-nil to allow switching to buffers on other workspaces." + :type 'boolean) + +(defconst exwm-layout--floating-hidden-position -101 + "Where to place hidden floating X windows.") + +(defvar exwm-layout--other-buffer-exclude-buffers nil + "List of buffers that should not be selected by `other-buffer'.") + +(defvar exwm-layout--other-buffer-exclude-exwm-mode-buffers nil + "When non-nil, prevent EXWM buffers from being selected by `other-buffer'.") + +(defvar exwm-layout--timer nil "Timer used to track echo area changes.") + +(defvar exwm-workspace--current) +(defvar exwm-workspace--frame-y-offset) +(declare-function exwm-input--release-keyboard "exwm-input.el") +(declare-function exwm-input--grab-keyboard "exwm-input.el") +(declare-function exwm-input-grab-keyboard "exwm-input.el") +(declare-function exwm-workspace--active-p "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--client-p "exwm-workspace.el" + (&optional frame)) +(declare-function exwm-workspace--minibuffer-own-frame-p "exwm-workspace.el") +(declare-function exwm-workspace--workspace-p "exwm-workspace.el" + (workspace)) +(declare-function exwm-workspace-move-window "exwm-workspace.el" + (frame-or-index &optional id)) + +(defun exwm-layout--set-state (id state) + "Set WM_STATE." + (exwm--log "id=#x%x" id) + (xcb:+request exwm--connection + (make-instance 'xcb:icccm:set-WM_STATE + :window id :state state :icon xcb:Window:None)) + (with-current-buffer (exwm--id->buffer id) + (setq exwm-state state))) + +(defun exwm-layout--iconic-state-p (&optional id) + (= xcb:icccm:WM_STATE:IconicState + (if id + (buffer-local-value 'exwm-state (exwm--id->buffer id)) + exwm-state))) + +(defun exwm-layout--set-ewmh-state (xwin) + "Set _NET_WM_STATE." + (with-current-buffer (exwm--id->buffer xwin) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_STATE + :window exwm--id + :data exwm--ewmh-state)))) + +(defun exwm-layout--fullscreen-p () + (when (derived-mode-p 'exwm-mode) + (memq xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state))) + +(defun exwm-layout--auto-iconify () + (when (and exwm-layout-auto-iconify + (not exwm-transient-for)) + (let ((xwin exwm--id) + (state exwm-state)) + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when (and exwm--floating-frame + (eq exwm-transient-for xwin) + (not (eq exwm-state state))) + (if (eq state xcb:icccm:WM_STATE:NormalState) + (exwm-layout--refresh-floating exwm--floating-frame) + (exwm-layout--hide exwm--id)))))))) + +(defun exwm-layout--show (id &optional window) + "Show window ID exactly fit in the Emacs window WINDOW." + (exwm--log "Show #x%x in %s" id window) + (let* ((edges (window-inside-absolute-pixel-edges window)) + (x (pop edges)) + (y (pop edges)) + (width (- (pop edges) x)) + (height (- (pop edges) y)) + frame-x frame-y frame-width frame-height) + (with-current-buffer (exwm--id->buffer id) + (when exwm--floating-frame + (setq frame-width (frame-pixel-width exwm--floating-frame) + frame-height (+ (frame-pixel-height exwm--floating-frame) + ;; Use `frame-outer-height' in the future. + exwm-workspace--frame-y-offset)) + (when exwm--floating-frame-position + (setq frame-x (elt exwm--floating-frame-position 0) + frame-y (elt exwm--floating-frame-position 1) + x (+ x frame-x (- exwm-layout--floating-hidden-position)) + y (+ y frame-y (- exwm-layout--floating-hidden-position))) + (setq exwm--floating-frame-position nil)) + (exwm--set-geometry (frame-parameter exwm--floating-frame + 'exwm-container) + frame-x frame-y frame-width frame-height)) + (when (exwm-layout--fullscreen-p) + (with-slots ((x* x) + (y* y) + (width* width) + (height* height)) + (exwm-workspace--get-geometry exwm--frame) + (setq x x* + y y* + width width* + height height*))) + (exwm--set-geometry id x y width height) + (xcb:+request exwm--connection (make-instance 'xcb:MapWindow :window id)) + (exwm-layout--set-state id xcb:icccm:WM_STATE:NormalState) + (setq exwm--ewmh-state + (delq xcb:Atom:_NET_WM_STATE_HIDDEN exwm--ewmh-state)) + (exwm-layout--set-ewmh-state id) + (exwm-layout--auto-iconify))) + (xcb:flush exwm--connection)) + +(defun exwm-layout--hide (id) + "Hide window ID." + (with-current-buffer (exwm--id->buffer id) + (unless (or (exwm-layout--iconic-state-p) + (and exwm--floating-frame + (eq 4294967295. exwm--desktop))) + (exwm--log "Hide #x%x" id) + (when exwm--floating-frame + (let* ((container (frame-parameter exwm--floating-frame + 'exwm-container)) + (geometry (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container)))) + (setq exwm--floating-frame-position + (vector (slot-value geometry 'x) (slot-value geometry 'y))) + (exwm--set-geometry container exwm-layout--floating-hidden-position + exwm-layout--floating-hidden-position + 1 + 1))) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:NoEvent)) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask (exwm--get-client-event-mask))) + (exwm-layout--set-state id xcb:icccm:WM_STATE:IconicState) + (cl-pushnew xcb:Atom:_NET_WM_STATE_HIDDEN exwm--ewmh-state) + (exwm-layout--set-ewmh-state id) + (exwm-layout--auto-iconify) + (xcb:flush exwm--connection)))) + +;;;###autoload +(cl-defun exwm-layout-set-fullscreen (&optional id) + "Make window ID fullscreen." + (interactive) + (exwm--log "id=#x%x" (or id 0)) + (unless (and (or id (derived-mode-p 'exwm-mode)) + (not (exwm-layout--fullscreen-p))) + (cl-return-from exwm-layout-set-fullscreen)) + (with-current-buffer (if id (exwm--id->buffer id) (window-buffer)) + ;; Expand the X window to fill the whole screen. + (with-slots (x y width height) (exwm-workspace--get-geometry exwm--frame) + (exwm--set-geometry exwm--id x y width height)) + ;; Raise the X window. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window exwm--id + :value-mask (logior xcb:ConfigWindow:BorderWidth + xcb:ConfigWindow:StackMode) + :border-width 0 + :stack-mode xcb:StackMode:Above)) + (cl-pushnew xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state) + (exwm-layout--set-ewmh-state exwm--id) + (xcb:flush exwm--connection) + (set-window-dedicated-p (get-buffer-window) t) + (exwm-input--release-keyboard exwm--id))) + +;;;###autoload +(cl-defun exwm-layout-unset-fullscreen (&optional id) + "Restore window from fullscreen state." + (interactive) + (exwm--log "id=#x%x" (or id 0)) + (unless (and (or id (derived-mode-p 'exwm-mode)) + (exwm-layout--fullscreen-p)) + (cl-return-from exwm-layout-unset-fullscreen)) + (with-current-buffer (if id (exwm--id->buffer id) (window-buffer)) + (setq exwm--ewmh-state + (delq xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state)) + (if exwm--floating-frame + (exwm-layout--show exwm--id (frame-root-window exwm--floating-frame)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window exwm--id + :value-mask (logior xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling exwm--guide-window + :stack-mode xcb:StackMode:Above)) + (let ((window (get-buffer-window nil t))) + (when window + (exwm-layout--show exwm--id window)))) + (setq exwm--ewmh-state + (delq xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state)) + (exwm-layout--set-ewmh-state exwm--id) + (xcb:flush exwm--connection) + (set-window-dedicated-p (get-buffer-window) nil) + (when (eq 'line-mode exwm--selected-input-mode) + (exwm-input--grab-keyboard exwm--id)))) + +;;;###autoload +(cl-defun exwm-layout-toggle-fullscreen (&optional id) + "Toggle fullscreen mode." + (interactive (list (exwm--buffer->id (window-buffer)))) + (exwm--log "id=#x%x" (or id 0)) + (unless (or id (derived-mode-p 'exwm-mode)) + (cl-return-from exwm-layout-toggle-fullscreen)) + (when id + (with-current-buffer (exwm--id->buffer id) + (if (exwm-layout--fullscreen-p) + (exwm-layout-unset-fullscreen id) + (exwm-layout-set-fullscreen id))))) + +(defun exwm-layout--other-buffer-predicate (buffer) + "Return non-nil when the BUFFER may be displayed in selected frame. + +Prevents EXWM-mode buffers already being displayed on some other window from +being selected. + +Should be set as `buffer-predicate' frame parameter for all +frames. Used by `other-buffer'. + +When variable `exwm-layout--other-buffer-exclude-exwm-mode-buffers' +is t EXWM buffers are never selected by `other-buffer'. + +When variable `exwm-layout--other-buffer-exclude-buffers' is a +list of buffers, EXWM buffers belonging to that list are never +selected by `other-buffer'." + (or (not (with-current-buffer buffer (derived-mode-p 'exwm-mode))) + (and (not exwm-layout--other-buffer-exclude-exwm-mode-buffers) + (not (memq buffer exwm-layout--other-buffer-exclude-buffers)) + ;; Do not select if already shown in some window. + (not (get-buffer-window buffer t))))) + +(defun exwm-layout--set-client-list-stacking () + "Set _NET_CLIENT_LIST_STACKING." + (exwm--log) + (let (id clients-floating clients clients-iconic clients-other) + (dolist (pair exwm--id-buffer-alist) + (setq id (car pair)) + (with-current-buffer (cdr pair) + (if (eq exwm--frame exwm-workspace--current) + (if exwm--floating-frame + ;; A floating X window on the current workspace. + (setq clients-floating (cons id clients-floating)) + (if (get-buffer-window (cdr pair) exwm-workspace--current) + ;; A normal tilling X window on the current workspace. + (setq clients (cons id clients)) + ;; An iconic tilling X window on the current workspace. + (setq clients-iconic (cons id clients-iconic)))) + ;; X window on other workspaces. + (setq clients-other (cons id clients-other))))) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_CLIENT_LIST_STACKING + :window exwm--root + :data (vconcat (append clients-other clients-iconic + clients clients-floating)))))) + +(defun exwm-layout--refresh (&optional frame) + "Refresh layout." + ;; `window-size-change-functions' sets this argument while + ;; `window-configuration-change-hook' makes the frame selected. + (unless frame + (setq frame (selected-frame))) + (exwm--log "frame=%s" frame) + (if (not (exwm-workspace--workspace-p frame)) + (if (frame-parameter frame 'exwm-outer-id) + (exwm-layout--refresh-floating frame) + (exwm-layout--refresh-other frame)) + (exwm-layout--refresh-workspace frame))) + +(defun exwm-layout--refresh-floating (frame) + "Refresh floating frame FRAME." + (exwm--log "Refresh floating %s" frame) + (let ((window (frame-first-window frame))) + (with-current-buffer (window-buffer window) + (when (and (derived-mode-p 'exwm-mode) + ;; It may be a buffer waiting to be killed. + (exwm--id->buffer exwm--id)) + (exwm--log "Refresh floating window #x%x" exwm--id) + (if (exwm-workspace--active-p exwm--frame) + (exwm-layout--show exwm--id window) + (exwm-layout--hide exwm--id)))))) + +(defun exwm-layout--refresh-other (frame) + "Refresh client or nox frame FRAME." + ;; Other frames (e.g. terminal/graphical frame of emacsclient) + ;; We shall bury all `exwm-mode' buffers in this case + (exwm--log "Refresh other %s" frame) + (let ((windows (window-list frame 'nomini)) ;exclude minibuffer + (exwm-layout--other-buffer-exclude-exwm-mode-buffers t)) + (dolist (window windows) + (with-current-buffer (window-buffer window) + (when (derived-mode-p 'exwm-mode) + (if (window-prev-buffers window) + (switch-to-prev-buffer window) + (switch-to-next-buffer window))))))) + +(defun exwm-layout--refresh-workspace (frame) + "Refresh workspace frame FRAME." + (exwm--log "Refresh workspace %s" frame) + ;; Workspaces other than the active one can also be refreshed (RandR) + (let (covered-buffers ;EXWM-buffers covered by a new X window. + vacated-windows) ;Windows previously displaying EXWM-buffers. + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when (and (not exwm--floating-frame) ;exclude floating X windows + (or exwm-layout-show-all-buffers + ;; Exclude X windows on other workspaces + (eq frame exwm--frame))) + (let (;; List of windows in current frame displaying the `exwm-mode' + ;; buffers. + (windows (get-buffer-window-list (current-buffer) 'nomini + frame))) + (if (not windows) + (when (eq frame exwm--frame) + ;; Hide it if it was being shown in this workspace. + (exwm-layout--hide exwm--id)) + (let ((window (car windows))) + (if (eq frame exwm--frame) + ;; Show it if `frame' is active, hide otherwise. + (if (exwm-workspace--active-p frame) + (exwm-layout--show exwm--id window) + (exwm-layout--hide exwm--id)) + ;; It was last shown in other workspace; move it here. + (exwm-workspace-move-window frame exwm--id)) + ;; Vacate any other windows (in any workspace) showing this + ;; `exwm-mode' buffer. + (setq vacated-windows + (append vacated-windows (remove + window + (get-buffer-window-list + (current-buffer) 'nomini t)))) + ;; Note any `exwm-mode' buffer is being covered by another + ;; `exwm-mode' buffer. We want to avoid that `exwm-mode' + ;; buffer to be reappear in any of the vacated windows. + (let ((prev-buffer (car-safe + (car-safe (window-prev-buffers window))))) + (and + prev-buffer + (with-current-buffer prev-buffer + (derived-mode-p 'exwm-mode)) + (push prev-buffer covered-buffers))))))))) + ;; Set some sensible buffer to vacated windows. + (let ((exwm-layout--other-buffer-exclude-buffers covered-buffers)) + (dolist (window vacated-windows) + (if (window-prev-buffers window) + (switch-to-prev-buffer window) + (switch-to-next-buffer window)))) + ;; Make sure windows floating / on other workspaces are excluded + (let ((exwm-layout--other-buffer-exclude-exwm-mode-buffers t)) + (dolist (window (window-list frame 'nomini)) + (with-current-buffer (window-buffer window) + (when (and (derived-mode-p 'exwm-mode) + (or exwm--floating-frame (not (eq frame exwm--frame)))) + (if (window-prev-buffers window) + (switch-to-prev-buffer window) + (switch-to-next-buffer window)))))) + (exwm-layout--set-client-list-stacking) + (xcb:flush exwm--connection))) + +(defun exwm-layout--on-minibuffer-setup () + "Refresh layout when minibuffer grows." + (exwm--log) + (unless (exwm-workspace--client-p) + (exwm--defer 0 (lambda () + (when (< 1 (window-height (minibuffer-window))) + (exwm-layout--refresh)))))) + +(defun exwm-layout--on-echo-area-change (&optional dirty) + "Run when message arrives or in `echo-area-clear-hook' to refresh layout." + (when (and (current-message) + (not (exwm-workspace--client-p)) + (or (cl-position ?\n (current-message)) + (> (length (current-message)) + (frame-width exwm-workspace--current)))) + (exwm--log) + (if dirty + (exwm-layout--refresh) + (exwm--defer 0 #'exwm-layout--refresh)))) + +;;;###autoload +(defun exwm-layout-enlarge-window (delta &optional horizontal) + "Make the selected window DELTA pixels taller. + +If no argument is given, make the selected window one pixel taller. If the +optional argument HORIZONTAL is non-nil, make selected window DELTA pixels +wider. If DELTA is negative, shrink selected window by -DELTA pixels. + +Normal hints are checked and regarded if the selected window is displaying an +`exwm-mode' buffer. However, this may violate the normal hints set on other X +windows." + (interactive "p") + (exwm--log) + (cond + ((zerop delta)) ;no operation + ((window-minibuffer-p)) ;avoid resize minibuffer-window + ((not (and (derived-mode-p 'exwm-mode) exwm--floating-frame)) + ;; Resize on tiling layout + (unless (= 0 (window-resizable nil delta horizontal nil t)) ;not resizable + (let ((window-resize-pixelwise t)) + (window-resize nil delta horizontal nil t)))) + ;; Resize on floating layout + (exwm--fixed-size) ;fixed size + (horizontal + (let* ((width (frame-pixel-width)) + (edges (window-inside-pixel-edges)) + (inner-width (- (elt edges 2) (elt edges 0))) + (margin (- width inner-width))) + (if (> delta 0) + (if (not exwm--normal-hints-max-width) + (cl-incf width delta) + (if (>= inner-width exwm--normal-hints-max-width) + (setq width nil) + (setq width (min (+ exwm--normal-hints-max-width margin) + (+ width delta))))) + (if (not exwm--normal-hints-min-width) + (cl-incf width delta) + (if (<= inner-width exwm--normal-hints-min-width) + (setq width nil) + (setq width (max (+ exwm--normal-hints-min-width margin) + (+ width delta)))))) + (when (and width (> width 0)) + (setf (slot-value exwm--geometry 'width) width) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-outer-id) + :value-mask xcb:ConfigWindow:Width + :width width)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-container) + :value-mask xcb:ConfigWindow:Width + :width width)) + (xcb:flush exwm--connection)))) + (t + (let* ((height (+ (frame-pixel-height) exwm-workspace--frame-y-offset)) + (edges (window-inside-pixel-edges)) + (inner-height (- (elt edges 3) (elt edges 1))) + (margin (- height inner-height))) + (if (> delta 0) + (if (not exwm--normal-hints-max-height) + (cl-incf height delta) + (if (>= inner-height exwm--normal-hints-max-height) + (setq height nil) + (setq height (min (+ exwm--normal-hints-max-height margin) + (+ height delta))))) + (if (not exwm--normal-hints-min-height) + (cl-incf height delta) + (if (<= inner-height exwm--normal-hints-min-height) + (setq height nil) + (setq height (max (+ exwm--normal-hints-min-height margin) + (+ height delta)))))) + (when (and height (> height 0)) + (setf (slot-value exwm--geometry 'height) height) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-outer-id) + :value-mask xcb:ConfigWindow:Height + :height height)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-container) + :value-mask xcb:ConfigWindow:Height + :height height)) + (xcb:flush exwm--connection)))))) + +;;;###autoload +(defun exwm-layout-enlarge-window-horizontally (delta) + "Make the selected window DELTA pixels wider. + +See also `exwm-layout-enlarge-window'." + (interactive "p") + (exwm--log "%s" delta) + (exwm-layout-enlarge-window delta t)) + +;;;###autoload +(defun exwm-layout-shrink-window (delta) + "Make the selected window DELTA pixels lower. + +See also `exwm-layout-enlarge-window'." + (interactive "p") + (exwm--log "%s" delta) + (exwm-layout-enlarge-window (- delta))) + +;;;###autoload +(defun exwm-layout-shrink-window-horizontally (delta) + "Make the selected window DELTA pixels narrower. + +See also `exwm-layout-enlarge-window'." + (interactive "p") + (exwm--log "%s" delta) + (exwm-layout-enlarge-window (- delta) t)) + +;;;###autoload +(defun exwm-layout-hide-mode-line () + "Hide mode-line." + (interactive) + (exwm--log) + (when (and (derived-mode-p 'exwm-mode) mode-line-format) + (let (mode-line-height) + (when exwm--floating-frame + (setq mode-line-height (window-mode-line-height + (frame-root-window exwm--floating-frame)))) + (setq exwm--mode-line-format mode-line-format + mode-line-format nil) + (if (not exwm--floating-frame) + (exwm-layout--show exwm--id) + (set-frame-height exwm--floating-frame + (- (frame-pixel-height exwm--floating-frame) + mode-line-height) + nil t))))) + +;;;###autoload +(defun exwm-layout-show-mode-line () + "Show mode-line." + (interactive) + (exwm--log) + (when (and (derived-mode-p 'exwm-mode) (not mode-line-format)) + (setq mode-line-format exwm--mode-line-format + exwm--mode-line-format nil) + (if (not exwm--floating-frame) + (exwm-layout--show exwm--id) + (set-frame-height exwm--floating-frame + (+ (frame-pixel-height exwm--floating-frame) + (window-mode-line-height (frame-root-window + exwm--floating-frame))) + nil t) + (call-interactively #'exwm-input-grab-keyboard)) + (force-mode-line-update))) + +;;;###autoload +(defun exwm-layout-toggle-mode-line () + "Toggle the display of mode-line." + (interactive) + (exwm--log) + (when (derived-mode-p 'exwm-mode) + (if mode-line-format + (exwm-layout-hide-mode-line) + (exwm-layout-show-mode-line)))) + +(defun exwm-layout--init () + "Initialize layout module." + ;; Auto refresh layout + (exwm--log) + (add-hook 'window-configuration-change-hook #'exwm-layout--refresh) + ;; The behavior of `window-configuration-change-hook' will be changed. + (when (fboundp 'window-pixel-width-before-size-change) + (add-hook 'window-size-change-functions #'exwm-layout--refresh)) + (unless (exwm-workspace--minibuffer-own-frame-p) + ;; Refresh when minibuffer grows + (add-hook 'minibuffer-setup-hook #'exwm-layout--on-minibuffer-setup t) + (setq exwm-layout--timer + (run-with-idle-timer 0 t #'exwm-layout--on-echo-area-change t)) + (add-hook 'echo-area-clear-hook #'exwm-layout--on-echo-area-change))) + +(defun exwm-layout--exit () + "Exit the layout module." + (exwm--log) + (remove-hook 'window-configuration-change-hook #'exwm-layout--refresh) + (when (fboundp 'window-pixel-width-before-size-change) + (remove-hook 'window-size-change-functions #'exwm-layout--refresh)) + (remove-hook 'minibuffer-setup-hook #'exwm-layout--on-minibuffer-setup) + (when exwm-layout--timer + (cancel-timer exwm-layout--timer) + (setq exwm-layout--timer nil)) + (remove-hook 'echo-area-clear-hook #'exwm-layout--on-echo-area-change)) + + + +(provide 'exwm-layout) + +;;; exwm-layout.el ends here diff --git a/third_party/emacs/exwm/exwm-manage.el b/third_party/emacs/exwm/exwm-manage.el new file mode 100644 index 000000000000..a7866f1ef885 --- /dev/null +++ b/third_party/emacs/exwm/exwm-manage.el @@ -0,0 +1,805 @@ +;;; exwm-manage.el --- Window Management Module for -*- lexical-binding: t -*- +;;; EXWM + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This is the fundamental module of EXWM that deals with window management. + +;;; Code: + +(require 'exwm-core) + +(defgroup exwm-manage nil + "Manage." + :version "25.3" + :group 'exwm) + +(defcustom exwm-manage-finish-hook nil + "Normal hook run after a window is just managed, in the context of the +corresponding buffer." + :type 'hook) + +(defcustom exwm-manage-force-tiling nil + "Non-nil to force managing all X windows in tiling layout. +You can still make the X windows floating afterwards." + :type 'boolean) + +(defcustom exwm-manage-ping-timeout 3 + "Seconds to wait before killing a client." + :type 'integer) + +(defcustom exwm-manage-configurations nil + "Per-application configurations. + +Configuration options allow to override various default behaviors of EXWM +and only take effect when they are present. Note for certain options +specifying nil is not exactly the same as leaving them out. Currently +possible choices: +* floating: Force floating (non-nil) or tiling (nil) on startup. +* x/y/width/height: Override the initial geometry (floating X window only). +* border-width: Override the border width (only visible when floating). +* fullscreen: Force full screen (non-nil) on startup. +* floating-mode-line: `mode-line-format' used when floating. +* tiling-mode-line: `mode-line-format' used when tiling. +* floating-header-line: `header-line-format' used when floating. +* tiling-header-line: `header-line-format' used when tiling. +* char-mode: Force char-mode (non-nil) on startup. +* prefix-keys: `exwm-input-prefix-keys' local to this X window. +* simulation-keys: `exwm-input-simulation-keys' local to this X window. +* workspace: The initial workspace. +* managed: Force to manage (non-nil) or not manage (nil) the X window. + +For each X window managed for the first time, matching criteria (sexps) are +evaluated sequentially and the first configuration with a non-nil matching +criterion would be applied. Apart from generic forms, one would typically +want to match against EXWM internal variables such as `exwm-title', +`exwm-class-name' and `exwm-instance-name'." + :type '(alist :key-type (sexp :tag "Matching criterion" nil) + :value-type + (plist :tag "Configurations" + :options + (((const :tag "Floating" floating) boolean) + ((const :tag "X" x) number) + ((const :tag "Y" y) number) + ((const :tag "Width" width) number) + ((const :tag "Height" height) number) + ((const :tag "Border width" border-width) integer) + ((const :tag "Fullscreen" fullscreen) boolean) + ((const :tag "Floating mode-line" floating-mode-line) + sexp) + ((const :tag "Tiling mode-line" tiling-mode-line) sexp) + ((const :tag "Floating header-line" + floating-header-line) + sexp) + ((const :tag "Tiling header-line" tiling-header-line) + sexp) + ((const :tag "Char-mode" char-mode) boolean) + ((const :tag "Prefix keys" prefix-keys) + (repeat key-sequence)) + ((const :tag "Simulation keys" simulation-keys) + (alist :key-type (key-sequence :tag "From") + :value-type (key-sequence :tag "To"))) + ((const :tag "Workspace" workspace) integer) + ((const :tag "Managed" managed) boolean) + ;; For forward compatibility. + ((other) sexp)))) + ;; TODO: This is admittedly ugly. We'd be better off with an event type. + :get (lambda (symbol) + (mapcar (lambda (pair) + (let* ((match (car pair)) + (config (cdr pair)) + (prefix-keys (plist-get config 'prefix-keys))) + (when prefix-keys + (setq config (copy-tree config) + config (plist-put config 'prefix-keys + (mapcar (lambda (i) + (if (sequencep i) + i + (vector i))) + prefix-keys)))) + (cons match config))) + (default-value symbol))) + :set (lambda (symbol value) + (set symbol + (mapcar (lambda (pair) + (let* ((match (car pair)) + (config (cdr pair)) + (prefix-keys (plist-get config 'prefix-keys))) + (when prefix-keys + (setq config (copy-tree config) + config (plist-put config 'prefix-keys + (mapcar (lambda (i) + (if (sequencep i) + (aref i 0) + i)) + prefix-keys)))) + (cons match config))) + value)))) + +;; FIXME: Make the following values as small as possible. +(defconst exwm-manage--height-delta-min 5) +(defconst exwm-manage--width-delta-min 5) + +;; The _MOTIF_WM_HINTS atom (see <Xm/MwmUtil.h> for more details) +;; It's currently only used in 'exwm-manage' module +(defvar exwm-manage--_MOTIF_WM_HINTS nil "_MOTIF_WM_HINTS atom.") + +(defvar exwm-manage--desktop nil "The desktop X window.") + +(defvar exwm-manage--frame-outer-id-list nil + "List of window-outer-id's of all frames.") + +(defvar exwm-manage--ping-lock nil + "Non-nil indicates EXWM is pinging a window.") + +(defvar exwm-input--skip-buffer-list-update) +(defvar exwm-input-prefix-keys) +(defvar exwm-workspace--current) +(defvar exwm-workspace--id-struts-alist) +(defvar exwm-workspace--list) +(defvar exwm-workspace--switch-history-outdated) +(defvar exwm-workspace--workareas) +(defvar exwm-workspace-current-index) +(declare-function exwm--update-class "exwm.el" (id &optional force)) +(declare-function exwm--update-hints "exwm.el" (id &optional force)) +(declare-function exwm--update-normal-hints "exwm.el" (id &optional force)) +(declare-function exwm--update-protocols "exwm.el" (id &optional force)) +(declare-function exwm--update-struts "exwm.el" (id)) +(declare-function exwm--update-title "exwm.el" (id)) +(declare-function exwm--update-transient-for "exwm.el" (id &optional force)) +(declare-function exwm--update-desktop "exwm.el" (id &optional force)) +(declare-function exwm--update-window-type "exwm.el" (id &optional force)) +(declare-function exwm-floating--set-floating "exwm-floating.el" (id)) +(declare-function exwm-floating--unset-floating "exwm-floating.el" (id)) +(declare-function exwm-input-grab-keyboard "exwm-input.el") +(declare-function exwm-input-set-local-simulation-keys "exwm-input.el") +(declare-function exwm-layout--fullscreen-p "exwm-layout.el" ()) +(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id)) +(declare-function exwm-workspace--position "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--set-fullscreen "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--update-struts "exwm-workspace.el" ()) +(declare-function exwm-workspace--update-workareas "exwm-workspace.el" ()) + +(defun exwm-manage--update-geometry (id &optional force) + "Update window geometry." + (exwm--log "id=#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm--geometry (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry :drawable id)))) + (setq exwm--geometry + (or reply + ;; Provide a reasonable fallback value. + (make-instance 'xcb:RECTANGLE + :x 0 + :y 0 + :width (/ (x-display-pixel-width) 2) + :height (/ (x-display-pixel-height) 2)))))))) + +(defun exwm-manage--update-ewmh-state (id) + "Update _NET_WM_STATE." + (exwm--log "id=#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless exwm--ewmh-state + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_STATE + :window id)))) + (when reply + (setq exwm--ewmh-state (append (slot-value reply 'value) nil))))))) + +(defun exwm-manage--update-mwm-hints (id &optional force) + "Update _MOTIF_WM_HINTS." + (exwm--log "id=#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and (not exwm--mwm-hints-decorations) (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:-GetProperty + :window id + :property exwm-manage--_MOTIF_WM_HINTS + :type exwm-manage--_MOTIF_WM_HINTS + :long-length 5)))) + (when reply + ;; Check MotifWmHints.decorations. + (with-slots (value) reply + (setq value (append value nil)) + (when (and value + ;; See <Xm/MwmUtil.h> for fields definitions. + (/= 0 (logand + (elt value 0) ;MotifWmHints.flags + 2)) ;MWM_HINTS_DECORATIONS + (= 0 + (elt value 2))) ;MotifWmHints.decorations + (setq exwm--mwm-hints-decorations nil)))))))) + +(defun exwm-manage--set-client-list () + "Set _NET_CLIENT_LIST." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_CLIENT_LIST + :window exwm--root + :data (vconcat (mapcar #'car exwm--id-buffer-alist))))) + +(cl-defun exwm-manage--get-configurations () + "Retrieve configurations for this buffer." + (exwm--log) + (when (derived-mode-p 'exwm-mode) + (dolist (i exwm-manage-configurations) + (save-current-buffer + (when (with-demoted-errors "Problematic configuration: %S" + (eval (car i) t)) + (cl-return-from exwm-manage--get-configurations (cdr i))))))) + +(defun exwm-manage--manage-window (id) + "Manage window ID." + (exwm--log "Try to manage #x%x" id) + (catch 'return + ;; Ensure it's alive + (when (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask (exwm--get-client-event-mask))) + (throw 'return 'dead)) + ;; Add this X window to save-set. + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeSaveSet + :mode xcb:SetMode:Insert + :window id)) + (with-current-buffer (let ((exwm-input--skip-buffer-list-update t)) + (generate-new-buffer "*EXWM*")) + ;; Keep the oldest X window first. + (setq exwm--id-buffer-alist + (nconc exwm--id-buffer-alist `((,id . ,(current-buffer))))) + (exwm-mode) + (setq exwm--id id + exwm--frame exwm-workspace--current) + (exwm--update-window-type id) + (exwm--update-class id) + (exwm--update-transient-for id) + (exwm--update-normal-hints id) + (exwm--update-hints id) + (exwm-manage--update-geometry id) + (exwm-manage--update-mwm-hints id) + (exwm--update-title id) + (exwm--update-protocols id) + (setq exwm--configurations (exwm-manage--get-configurations)) + ;; OverrideRedirect is not checked here. + (when (and + ;; The user has specified to manage it. + (not (plist-get exwm--configurations 'managed)) + (or + ;; The user has specified not to manage it. + (plist-member exwm--configurations 'managed) + ;; This is not a type of X window we can manage. + (and exwm-window-type + (not (cl-intersection + exwm-window-type + (list xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY + xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG + xcb:Atom:_NET_WM_WINDOW_TYPE_NORMAL)))) + ;; Check the _MOTIF_WM_HINTS property to not manage floating X + ;; windows without decoration. + (and (not exwm--mwm-hints-decorations) + (not exwm--hints-input) + ;; Floating windows only + (or exwm-transient-for exwm--fixed-size + (memq xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY + exwm-window-type) + (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG + exwm-window-type))))) + (exwm--log "No need to manage #x%x" id) + ;; Update struts. + (when (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK exwm-window-type) + (exwm--update-struts id)) + ;; Remove all events + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask + (if (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK + exwm-window-type) + ;; Listen for PropertyChange (struts) and + ;; UnmapNotify/DestroyNotify event of the dock. + (exwm--get-client-event-mask) + xcb:EventMask:NoEvent))) + ;; The window needs to be mapped + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window id)) + (with-slots (x y width height) exwm--geometry + ;; Center window of type _NET_WM_WINDOW_TYPE_SPLASH + (when (memq xcb:Atom:_NET_WM_WINDOW_TYPE_SPLASH exwm-window-type) + (let* ((workarea (elt exwm-workspace--workareas + (exwm-workspace--position exwm--frame))) + (x* (aref workarea 0)) + (y* (aref workarea 1)) + (width* (aref workarea 2)) + (height* (aref workarea 3))) + (exwm--set-geometry id + (+ x* (/ (- width* width) 2)) + (+ y* (/ (- height* height) 2)) + nil + nil)))) + ;; Check for desktop. + (when (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DESKTOP exwm-window-type) + ;; There should be only one desktop X window. + (setq exwm-manage--desktop id) + ;; Put it at bottom. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window id + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:Below))) + (xcb:flush exwm--connection) + (setq exwm--id-buffer-alist (assq-delete-all id exwm--id-buffer-alist)) + (let ((kill-buffer-query-functions nil) + (exwm-input--skip-buffer-list-update t)) + (kill-buffer (current-buffer))) + (throw 'return 'ignored)) + (let ((index (plist-get exwm--configurations 'workspace))) + (when (and index (< index (length exwm-workspace--list))) + (setq exwm--frame (elt exwm-workspace--list index)))) + ;; Manage the window + (exwm--log "Manage #x%x" id) + (xcb:+request exwm--connection ;remove border + (make-instance 'xcb:ConfigureWindow + :window id :value-mask xcb:ConfigWindow:BorderWidth + :border-width 0)) + (dolist (button ;grab buttons to set focus / move / resize + (list xcb:ButtonIndex:1 xcb:ButtonIndex:2 xcb:ButtonIndex:3)) + (xcb:+request exwm--connection + (make-instance 'xcb:GrabButton + :owner-events 0 :grab-window id + :event-mask xcb:EventMask:ButtonPress + :pointer-mode xcb:GrabMode:Sync + :keyboard-mode xcb:GrabMode:Async + :confine-to xcb:Window:None :cursor xcb:Cursor:None + :button button :modifiers xcb:ModMask:Any))) + (exwm-manage--set-client-list) + (xcb:flush exwm--connection) + (if (plist-member exwm--configurations 'floating) + ;; User has specified whether it should be floating. + (if (plist-get exwm--configurations 'floating) + (exwm-floating--set-floating id) + (with-selected-window (frame-selected-window exwm--frame) + (exwm-floating--unset-floating id))) + ;; Try to determine if it should be floating. + (if (and (not exwm-manage-force-tiling) + (or exwm-transient-for exwm--fixed-size + (memq xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY + exwm-window-type) + (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG + exwm-window-type))) + (exwm-floating--set-floating id) + (with-selected-window (frame-selected-window exwm--frame) + (exwm-floating--unset-floating id)))) + (if (plist-get exwm--configurations 'char-mode) + (exwm-input-release-keyboard id) + (exwm-input-grab-keyboard id)) + (let ((simulation-keys (plist-get exwm--configurations 'simulation-keys)) + (prefix-keys (plist-get exwm--configurations 'prefix-keys))) + (with-current-buffer (exwm--id->buffer id) + (when simulation-keys + (exwm-input-set-local-simulation-keys simulation-keys)) + (when prefix-keys + (setq-local exwm-input-prefix-keys prefix-keys)))) + (setq exwm-workspace--switch-history-outdated t) + (exwm--update-desktop id) + (exwm-manage--update-ewmh-state id) + (with-current-buffer (exwm--id->buffer id) + (when (or (plist-get exwm--configurations 'fullscreen) + (exwm-layout--fullscreen-p)) + (setq exwm--ewmh-state (delq xcb:Atom:_NET_WM_STATE_FULLSCREEN + exwm--ewmh-state)) + (exwm-layout-set-fullscreen id)) + (run-hooks 'exwm-manage-finish-hook))))) + +(defun exwm-manage--unmanage-window (id &optional withdraw-only) + "Unmanage window ID. + +If WITHDRAW-ONLY is non-nil, the X window will be properly placed back to the +root window. Set WITHDRAW-ONLY to 'quit if this functions is used when window +manager is shutting down." + (let ((buffer (exwm--id->buffer id))) + (exwm--log "Unmanage #x%x (buffer: %s, widthdraw: %s)" + id buffer withdraw-only) + (setq exwm--id-buffer-alist (assq-delete-all id exwm--id-buffer-alist)) + ;; Update workspaces when a dock is destroyed. + (when (and (null withdraw-only) + (assq id exwm-workspace--id-struts-alist)) + (setq exwm-workspace--id-struts-alist + (assq-delete-all id exwm-workspace--id-struts-alist)) + (exwm-workspace--update-struts) + (exwm-workspace--update-workareas) + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + ;; Unmap the X window. + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window id)) + ;; + (setq exwm-workspace--switch-history-outdated t) + ;; + (when withdraw-only + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:NoEvent)) + ;; Delete WM_STATE property + (xcb:+request exwm--connection + (make-instance 'xcb:DeleteProperty + :window id :property xcb:Atom:WM_STATE)) + (cond + ((eq withdraw-only 'quit) + ;; Remap the window when exiting. + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window id))) + (t + ;; Remove _NET_WM_DESKTOP. + (xcb:+request exwm--connection + (make-instance 'xcb:DeleteProperty + :window id + :property xcb:Atom:_NET_WM_DESKTOP))))) + (when exwm--floating-frame + ;; Unmap the floating frame before destroying its container. + (let ((window (frame-parameter exwm--floating-frame 'exwm-outer-id)) + (container (frame-parameter exwm--floating-frame + 'exwm-container))) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window window)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window window :parent exwm--root :x 0 :y 0)) + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow :window container)))) + (when (exwm-layout--fullscreen-p) + (let ((window (get-buffer-window))) + (when window + (set-window-dedicated-p window nil)))) + (exwm-manage--set-client-list) + (xcb:flush exwm--connection)) + (let ((kill-buffer-func + (lambda (buffer) + (when (buffer-local-value 'exwm--floating-frame buffer) + (select-window + (frame-selected-window exwm-workspace--current))) + (with-current-buffer buffer + (let ((kill-buffer-query-functions nil)) + (kill-buffer buffer)))))) + (exwm--defer 0 kill-buffer-func buffer) + (when (active-minibuffer-window) + (exit-minibuffer)))))) + +(defun exwm-manage--scan () + "Search for existing windows and try to manage them." + (exwm--log) + (let* ((tree (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryTree + :window exwm--root))) + reply) + (dolist (i (slot-value tree 'children)) + (setq reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetWindowAttributes + :window i))) + ;; It's possible the X window has been destroyed. + (when reply + (with-slots (override-redirect map-state) reply + (when (and (= 0 override-redirect) + (= xcb:MapState:Viewable map-state)) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow + :window i)) + (xcb:flush exwm--connection) + (exwm-manage--manage-window i))))))) + +(defun exwm-manage--kill-buffer-query-function () + "Run in `kill-buffer-query-functions'." + (exwm--log "id=#x%x; buffer=%s" exwm--id (current-buffer)) + (catch 'return + (when (or (not exwm--id) + (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--id + :value-mask xcb:CW:EventMask + :event-mask (exwm--get-client-event-mask)))) + ;; The X window is no longer alive so just close the buffer. + (when exwm--floating-frame + (let ((window (frame-parameter exwm--floating-frame 'exwm-outer-id)) + (container (frame-parameter exwm--floating-frame + 'exwm-container))) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window window)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window window + :parent exwm--root + :x 0 :y 0)) + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow + :window container)))) + (xcb:flush exwm--connection) + (throw 'return t)) + (unless (memq xcb:Atom:WM_DELETE_WINDOW exwm--protocols) + ;; The X window does not support WM_DELETE_WINDOW; destroy it. + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow :window exwm--id)) + (xcb:flush exwm--connection) + ;; Wait for DestroyNotify event. + (throw 'return nil)) + (let ((id exwm--id)) + ;; Try to close the X window with WM_DELETE_WINDOW client message. + (xcb:+request exwm--connection + (make-instance 'xcb:icccm:SendEvent + :destination id + :event (xcb:marshal + (make-instance 'xcb:icccm:WM_DELETE_WINDOW + :window id) + exwm--connection))) + (xcb:flush exwm--connection) + ;; + (unless (memq xcb:Atom:_NET_WM_PING exwm--protocols) + ;; For X windows without _NET_WM_PING support, we'd better just + ;; wait for DestroyNotify events. + (throw 'return nil)) + ;; Try to determine if the X window is dead with _NET_WM_PING. + (setq exwm-manage--ping-lock t) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination id + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal + (make-instance 'xcb:ewmh:_NET_WM_PING + :window id + :timestamp 0 + :client-window id) + exwm--connection))) + (xcb:flush exwm--connection) + (with-timeout (exwm-manage-ping-timeout + (if (y-or-n-p (format "'%s' is not responding. \ +Would you like to kill it? " + (buffer-name))) + (progn (exwm-manage--kill-client id) + ;; Kill the unresponsive X window and + ;; wait for DestroyNotify event. + (throw 'return nil)) + ;; Give up. + (throw 'return nil))) + (while (and exwm-manage--ping-lock + (exwm--id->buffer id)) ;may have been destroyed. + (accept-process-output nil 0.1)) + ;; Give up. + (throw 'return nil))))) + +(defun exwm-manage--kill-client (&optional id) + "Kill an X client." + (unless id (setq id (exwm--buffer->id (current-buffer)))) + (exwm--log "id=#x%x" id) + (let* ((response (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_PID :window id))) + (pid (and response (slot-value response 'value))) + (request (make-instance 'xcb:KillClient :resource id))) + (if (not pid) + (xcb:+request exwm--connection request) + ;; What if the PID is fake/wrong? + (signal-process pid 'SIGKILL) + ;; Ensure it's dead + (run-with-timer exwm-manage-ping-timeout nil + (lambda () + (xcb:+request exwm--connection request)))) + (xcb:flush exwm--connection))) + +(defun exwm-manage--add-frame (frame) + "Run in `after-make-frame-functions'." + (exwm--log "frame=%s" frame) + (when (display-graphic-p frame) + (push (string-to-number (frame-parameter frame 'outer-window-id)) + exwm-manage--frame-outer-id-list))) + +(defun exwm-manage--remove-frame (frame) + "Run in `delete-frame-functions'." + (exwm--log "frame=%s" frame) + (when (display-graphic-p frame) + (setq exwm-manage--frame-outer-id-list + (delq (string-to-number (frame-parameter frame 'outer-window-id)) + exwm-manage--frame-outer-id-list)))) + +(defun exwm-manage--on-ConfigureRequest (data _synthetic) + "Handle ConfigureRequest event." + (exwm--log) + (let ((obj (make-instance 'xcb:ConfigureRequest)) + buffer edges width-delta height-delta) + (xcb:unmarshal obj data) + (with-slots (window x y width height + border-width sibling stack-mode value-mask) + obj + (exwm--log "#x%x (#x%x) @%dx%d%+d%+d; \ +border-width: %d; sibling: #x%x; stack-mode: %d" + window value-mask width height x y + border-width sibling stack-mode) + (if (and (setq buffer (exwm--id->buffer window)) + (with-current-buffer buffer + (or (exwm-layout--fullscreen-p) + ;; Make sure it's a floating X window wanting to resize + ;; itself. + (or (not exwm--floating-frame) + (progn + (setq edges + (window-inside-pixel-edges + (get-buffer-window buffer t)) + width-delta (- width (- (elt edges 2) + (elt edges 0))) + height-delta (- height (- (elt edges 3) + (elt edges 1)))) + ;; We cannot do resizing precisely for now. + (and (if (= 0 (logand value-mask + xcb:ConfigWindow:Width)) + t + (< (abs width-delta) + exwm-manage--width-delta-min)) + (if (= 0 (logand value-mask + xcb:ConfigWindow:Height)) + t + (< (abs height-delta) + exwm-manage--height-delta-min)))))))) + ;; Send client message for managed windows + (with-current-buffer buffer + (setq edges + (if (exwm-layout--fullscreen-p) + (with-slots (x y width height) + (exwm-workspace--get-geometry exwm--frame) + (list x y width height)) + (window-inside-absolute-pixel-edges + (get-buffer-window buffer t)))) + (exwm--log "Reply with ConfigureNotify (edges): %s" edges) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 :destination window + :event-mask xcb:EventMask:StructureNotify + :event (xcb:marshal + (make-instance + 'xcb:ConfigureNotify + :event window :window window + :above-sibling xcb:Window:None + :x (elt edges 0) :y (elt edges 1) + :width (- (elt edges 2) (elt edges 0)) + :height (- (elt edges 3) (elt edges 1)) + :border-width 0 :override-redirect 0) + exwm--connection)))) + (if buffer + (with-current-buffer buffer + (exwm--log "ConfigureWindow (resize floating X window)") + (exwm--set-geometry (frame-parameter exwm--floating-frame + 'exwm-outer-id) + nil + nil + (+ (frame-pixel-width exwm--floating-frame) + width-delta) + (+ (frame-pixel-height exwm--floating-frame) + height-delta))) + (exwm--log "ConfigureWindow (preserve geometry)") + ;; Configure the unmanaged window. + ;; But Emacs frames should be excluded. Generally we don't + ;; receive ConfigureRequest events from Emacs frames since we + ;; have set OverrideRedirect on them, but this is not true for + ;; Lucid build (as of 25.1). + (unless (memq window exwm-manage--frame-outer-id-list) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask value-mask + :x x :y y :width width :height height + :border-width border-width + :sibling sibling + :stack-mode stack-mode))))))) + (xcb:flush exwm--connection)) + +(defun exwm-manage--on-MapRequest (data _synthetic) + "Handle MapRequest event." + (let ((obj (make-instance 'xcb:MapRequest))) + (xcb:unmarshal obj data) + (with-slots (parent window) obj + (exwm--log "id=#x%x parent=#x%x" window parent) + (if (assoc window exwm--id-buffer-alist) + (with-current-buffer (exwm--id->buffer window) + (if (exwm-layout--iconic-state-p) + ;; State change: iconic => normal. + (when (eq exwm--frame exwm-workspace--current) + (pop-to-buffer-same-window (current-buffer))) + (exwm--log "#x%x is already managed" window))) + (if (/= exwm--root parent) + (progn (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window window)) + (xcb:flush exwm--connection)) + (exwm--log "#x%x" window) + (exwm-manage--manage-window window)))))) + +(defun exwm-manage--on-UnmapNotify (data _synthetic) + "Handle UnmapNotify event." + (let ((obj (make-instance 'xcb:UnmapNotify))) + (xcb:unmarshal obj data) + (with-slots (window) obj + (exwm--log "id=#x%x" window) + (exwm-manage--unmanage-window window t)))) + +(defun exwm-manage--on-MapNotify (data _synthetic) + "Handle MapNotify event." + (let ((obj (make-instance 'xcb:MapNotify))) + (xcb:unmarshal obj data) + (with-slots (window) obj + (when (assoc window exwm--id-buffer-alist) + (exwm--log "id=#x%x" window) + ;; With this we ensure that a "window hierarchy change" happens after + ;; mapping the window, as some servers (XQuartz) do not generate it. + (with-current-buffer (exwm--id->buffer window) + (if exwm--floating-frame + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:Above)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask (logior xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling exwm--guide-window + :stack-mode xcb:StackMode:Above)))) + (xcb:flush exwm--connection))))) + +(defun exwm-manage--on-DestroyNotify (data synthetic) + "Handle DestroyNotify event." + (unless synthetic + (exwm--log) + (let ((obj (make-instance 'xcb:DestroyNotify))) + (xcb:unmarshal obj data) + (exwm--log "#x%x" (slot-value obj 'window)) + (exwm-manage--unmanage-window (slot-value obj 'window))))) + +(defun exwm-manage--init () + "Initialize manage module." + ;; Intern _MOTIF_WM_HINTS + (exwm--log) + (setq exwm-manage--_MOTIF_WM_HINTS (exwm--intern-atom "_MOTIF_WM_HINTS")) + (add-hook 'after-make-frame-functions #'exwm-manage--add-frame) + (add-hook 'delete-frame-functions #'exwm-manage--remove-frame) + (xcb:+event exwm--connection 'xcb:ConfigureRequest + #'exwm-manage--on-ConfigureRequest) + (xcb:+event exwm--connection 'xcb:MapRequest #'exwm-manage--on-MapRequest) + (xcb:+event exwm--connection 'xcb:UnmapNotify #'exwm-manage--on-UnmapNotify) + (xcb:+event exwm--connection 'xcb:MapNotify #'exwm-manage--on-MapNotify) + (xcb:+event exwm--connection 'xcb:DestroyNotify + #'exwm-manage--on-DestroyNotify)) + +(defun exwm-manage--exit () + "Exit the manage module." + (exwm--log) + (dolist (pair exwm--id-buffer-alist) + (exwm-manage--unmanage-window (car pair) 'quit)) + (remove-hook 'after-make-frame-functions #'exwm-manage--add-frame) + (remove-hook 'delete-frame-functions #'exwm-manage--remove-frame) + (setq exwm-manage--_MOTIF_WM_HINTS nil)) + + + +(provide 'exwm-manage) + +;;; exwm-manage.el ends here diff --git a/third_party/emacs/exwm/exwm-randr.el b/third_party/emacs/exwm/exwm-randr.el new file mode 100644 index 000000000000..7acceb1324de --- /dev/null +++ b/third_party/emacs/exwm/exwm-randr.el @@ -0,0 +1,375 @@ +;;; exwm-randr.el --- RandR Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module adds RandR support for EXWM. Currently it requires external +;; tools such as xrandr(1) to properly configure RandR first. This +;; dependency may be removed in the future, but more work is needed before +;; that. + +;; To use this module, load, enable it and configure +;; `exwm-randr-workspace-monitor-plist' and `exwm-randr-screen-change-hook' +;; as follows: +;; +;; (require 'exwm-randr) +;; (setq exwm-randr-workspace-monitor-plist '(0 "VGA1")) +;; (add-hook 'exwm-randr-screen-change-hook +;; (lambda () +;; (start-process-shell-command +;; "xrandr" nil "xrandr --output VGA1 --left-of LVDS1 --auto"))) +;; (exwm-randr-enable) +;; +;; With above lines, workspace 0 should be assigned to the output named "VGA1", +;; staying at the left of other workspaces on the output "LVDS1". Please refer +;; to xrandr(1) for the configuration of RandR. + +;; References: +;; + RandR (http://www.x.org/archive/X11R7.7/doc/randrproto/randrproto.txt) + +;;; Code: + +(require 'xcb-randr) + +(require 'exwm-core) +(require 'exwm-workspace) + +(defgroup exwm-randr nil + "RandR." + :version "25.3" + :group 'exwm) + +(defcustom exwm-randr-refresh-hook nil + "Normal hook run when the RandR module just refreshed." + :type 'hook) + +(defcustom exwm-randr-screen-change-hook nil + "Normal hook run when screen changes." + :type 'hook) + +(defcustom exwm-randr-workspace-monitor-plist nil + "Plist mapping workspaces to monitors. + +In RandR 1.5 a monitor is a rectangle region decoupled from the physical +size of screens, and can be identified with `xrandr --listmonitors' (name of +the primary monitor is prefixed with an `*'). When no monitor is created it +automatically fallback to RandR 1.2 output which represents the physical +screen size. RandR 1.5 monitors can be created with `xrandr --setmonitor'. +For example, to split an output (`LVDS-1') of size 1280x800 into two +side-by-side monitors one could invoke (the digits after `/' are size in mm) + + xrandr --setmonitor *LVDS-1-L 640/135x800/163+0+0 LVDS-1 + xrandr --setmonitor LVDS-1-R 640/135x800/163+640+0 none + +If a monitor is not active, the workspaces mapped to it are displayed on the +primary monitor until it becomes active (if ever). Unspecified workspaces +are all mapped to the primary monitor. For example, with the following +setting workspace other than 1 and 3 would always be displayed on the +primary monitor where workspace 1 and 3 would be displayed on their +corresponding monitors whenever the monitors are active. + + \\='(1 \"HDMI-1\" 3 \"DP-1\")" + :type '(plist :key-type integer :value-type string)) + +(with-no-warnings + (define-obsolete-variable-alias 'exwm-randr-workspace-output-plist + 'exwm-randr-workspace-monitor-plist "27.1")) + +(defvar exwm-randr--last-timestamp 0 "Used for debouncing events.") + +(defvar exwm-randr--prev-screen-change-seqnum nil + "The most recent ScreenChangeNotify sequence number.") + +(defvar exwm-randr--compatibility-mode nil + "Non-nil when the server does not support RandR 1.5 protocol.") + +(defun exwm-randr--get-monitors () + "Get RandR 1.5 monitors." + (exwm--log) + (let (monitor-name geometry monitor-geometry-alist primary-monitor) + (with-slots (timestamp monitors) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:GetMonitors + :window exwm--root + :get-active 1)) + (when (> timestamp exwm-randr--last-timestamp) + (setq exwm-randr--last-timestamp timestamp)) + (dolist (monitor monitors) + (with-slots (name primary x y width height) monitor + (setq monitor-name (x-get-atom-name name) + geometry (make-instance 'xcb:RECTANGLE + :x x + :y y + :width width + :height height) + monitor-geometry-alist (cons (cons monitor-name geometry) + monitor-geometry-alist)) + (exwm--log "%s: %sx%s+%s+%s" monitor-name x y width height) + ;; Save primary monitor when available (fallback to the first one). + (when (or (/= 0 primary) + (not primary-monitor)) + (setq primary-monitor monitor-name))))) + (exwm--log "Primary monitor: %s" primary-monitor) + (list primary-monitor monitor-geometry-alist + (exwm-randr--get-monitor-alias primary-monitor + monitor-geometry-alist)))) + +(defun exwm-randr--get-outputs () + "Get RandR 1.2 outputs. + +Only used when RandR 1.5 is not supported by the server." + (exwm--log) + (let (output-name geometry output-geometry-alist primary-output) + (with-slots (config-timestamp outputs) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:GetScreenResourcesCurrent + :window exwm--root)) + (when (> config-timestamp exwm-randr--last-timestamp) + (setq exwm-randr--last-timestamp config-timestamp)) + (dolist (output outputs) + (with-slots (crtc connection name) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:GetOutputInfo + :output output + :config-timestamp config-timestamp)) + (when (and (= connection xcb:randr:Connection:Connected) + (/= crtc 0)) + (with-slots (x y width height) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:GetCrtcInfo + :crtc crtc + :config-timestamp config-timestamp)) + (setq output-name (decode-coding-string + (apply #'unibyte-string name) 'utf-8) + geometry (make-instance 'xcb:RECTANGLE + :x x + :y y + :width width + :height height) + output-geometry-alist (cons (cons output-name geometry) + output-geometry-alist)) + (exwm--log "%s: %sx%s+%s+%s" output-name x y width height) + ;; The primary output is the first one. + (unless primary-output + (setq primary-output output-name))))))) + (exwm--log "Primary output: %s" primary-output) + (list primary-output output-geometry-alist + (exwm-randr--get-monitor-alias primary-output + output-geometry-alist)))) + +(defun exwm-randr--get-monitor-alias (primary-monitor monitor-geometry-alist) + "Generate monitor aliases using PRIMARY-MONITOR MONITOR-GEOMETRY-ALIST. + +In a mirroring setup some monitors overlap and should be treated as one." + (let (monitor-position-alist monitor-alias-alist monitor-name geometry) + (setq monitor-position-alist (with-slots (x y) + (cdr (assoc primary-monitor + monitor-geometry-alist)) + (list (cons primary-monitor (vector x y))))) + (setq monitor-alias-alist (list (cons primary-monitor primary-monitor))) + (dolist (pair monitor-geometry-alist) + (setq monitor-name (car pair) + geometry (cdr pair)) + (unless (assoc monitor-name monitor-alias-alist) + (let* ((position (vector (slot-value geometry 'x) + (slot-value geometry 'y))) + (alias (car (rassoc position monitor-position-alist)))) + (if alias + (setq monitor-alias-alist (cons (cons monitor-name alias) + monitor-alias-alist)) + (setq monitor-position-alist (cons (cons monitor-name position) + monitor-position-alist) + monitor-alias-alist (cons (cons monitor-name monitor-name) + monitor-alias-alist)))))) + monitor-alias-alist)) + +;;;###autoload +(defun exwm-randr-refresh () + "Refresh workspaces according to the updated RandR info." + (interactive) + (exwm--log) + (let* ((result (if exwm-randr--compatibility-mode + (exwm-randr--get-outputs) + (exwm-randr--get-monitors))) + (primary-monitor (elt result 0)) + (monitor-geometry-alist (elt result 1)) + (monitor-alias-alist (elt result 2)) + container-monitor-alist container-frame-alist) + (when (and primary-monitor monitor-geometry-alist) + (when exwm-workspace--fullscreen-frame-count + ;; Not all workspaces are fullscreen; reset this counter. + (setq exwm-workspace--fullscreen-frame-count 0)) + (dotimes (i (exwm-workspace--count)) + (let* ((monitor (plist-get exwm-randr-workspace-monitor-plist i)) + (geometry (cdr (assoc monitor monitor-geometry-alist))) + (frame (elt exwm-workspace--list i)) + (container (frame-parameter frame 'exwm-container))) + (if geometry + ;; Unify monitor names in case it's a mirroring setup. + (setq monitor (cdr (assoc monitor monitor-alias-alist))) + ;; Missing monitors fallback to the primary one. + (setq monitor primary-monitor + geometry (cdr (assoc primary-monitor + monitor-geometry-alist)))) + (setq container-monitor-alist (nconc + `((,container . ,(intern monitor))) + container-monitor-alist) + container-frame-alist (nconc `((,container . ,frame)) + container-frame-alist)) + (set-frame-parameter frame 'exwm-randr-monitor monitor) + (set-frame-parameter frame 'exwm-geometry geometry))) + ;; Update workareas. + (exwm-workspace--update-workareas) + ;; Resize workspace. + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f)) + (xcb:flush exwm--connection) + ;; Raise the minibuffer if it's active. + (when (and (active-minibuffer-window) + (exwm-workspace--minibuffer-own-frame-p)) + (exwm-workspace--show-minibuffer)) + ;; Set _NET_DESKTOP_GEOMETRY. + (exwm-workspace--set-desktop-geometry) + ;; Update active/inactive workspaces. + (dolist (w exwm-workspace--list) + (exwm-workspace--set-active w nil)) + ;; Mark the workspace on the top of each monitor as active. + (dolist (xwin + (reverse + (slot-value (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryTree + :window exwm--root)) + 'children))) + (let ((monitor (cdr (assq xwin container-monitor-alist)))) + (when monitor + (setq container-monitor-alist + (rassq-delete-all monitor container-monitor-alist)) + (exwm-workspace--set-active (cdr (assq xwin container-frame-alist)) + t)))) + (xcb:flush exwm--connection) + (run-hooks 'exwm-randr-refresh-hook)))) + +(define-obsolete-function-alias 'exwm-randr--refresh #'exwm-randr-refresh + "27.1") + +(defun exwm-randr--on-ScreenChangeNotify (data _synthetic) + "Handle `ScreenChangeNotify' event. + +Run `exwm-randr-screen-change-hook' (usually user scripts to configure RandR)." + (exwm--log) + (let ((evt (make-instance 'xcb:randr:ScreenChangeNotify))) + (xcb:unmarshal evt data) + (let ((seqnum (slot-value evt '~sequence))) + (unless (equal seqnum exwm-randr--prev-screen-change-seqnum) + (setq exwm-randr--prev-screen-change-seqnum seqnum) + (run-hooks 'exwm-randr-screen-change-hook))))) + +(defun exwm-randr--on-Notify (data _synthetic) + "Handle `CrtcChangeNotify' and `OutputChangeNotify' events. + +Refresh when any CRTC/output changes." + (exwm--log) + (let ((evt (make-instance 'xcb:randr:Notify)) + notify) + (xcb:unmarshal evt data) + (with-slots (subCode u) evt + (cl-case subCode + (xcb:randr:Notify:CrtcChange + (setq notify (slot-value u 'cc))) + (xcb:randr:Notify:OutputChange + (setq notify (slot-value u 'oc)))) + (when notify + (with-slots (timestamp) notify + (when (> timestamp exwm-randr--last-timestamp) + (exwm-randr-refresh) + (setq exwm-randr--last-timestamp timestamp))))))) + +(defun exwm-randr--on-ConfigureNotify (data _synthetic) + "Handle `ConfigureNotify' event. + +Refresh when any RandR 1.5 monitor changes." + (exwm--log) + (let ((evt (make-instance 'xcb:ConfigureNotify))) + (xcb:unmarshal evt data) + (with-slots (window) evt + (when (eq window exwm--root) + (exwm-randr-refresh))))) + +(defun exwm-randr--init () + "Initialize RandR extension and EXWM RandR module." + (exwm--log) + (when (= 0 (slot-value (xcb:get-extension-data exwm--connection 'xcb:randr) + 'present)) + (error "[EXWM] RandR extension is not supported by the server")) + (with-slots (major-version minor-version) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:QueryVersion + :major-version 1 :minor-version 5)) + (cond ((and (= major-version 1) (= minor-version 5)) + (setq exwm-randr--compatibility-mode nil)) + ((and (= major-version 1) (>= minor-version 2)) + (setq exwm-randr--compatibility-mode t)) + (t + (error "[EXWM] The server only support RandR version up to %d.%d" + major-version minor-version))) + ;; External monitor(s) may already be connected. + (run-hooks 'exwm-randr-screen-change-hook) + (exwm-randr-refresh) + ;; Listen for `ScreenChangeNotify' to notify external tools to + ;; configure RandR and `CrtcChangeNotify/OutputChangeNotify' to + ;; refresh the workspace layout. + (xcb:+event exwm--connection 'xcb:randr:ScreenChangeNotify + #'exwm-randr--on-ScreenChangeNotify) + (xcb:+event exwm--connection 'xcb:randr:Notify + #'exwm-randr--on-Notify) + (xcb:+event exwm--connection 'xcb:ConfigureNotify + #'exwm-randr--on-ConfigureNotify) + (xcb:+request exwm--connection + (make-instance 'xcb:randr:SelectInput + :window exwm--root + :enable (logior + xcb:randr:NotifyMask:ScreenChange + xcb:randr:NotifyMask:CrtcChange + xcb:randr:NotifyMask:OutputChange))) + (xcb:flush exwm--connection) + (add-hook 'exwm-workspace-list-change-hook #'exwm-randr-refresh)) + ;; Prevent frame parameters introduced by this module from being + ;; saved/restored. + (dolist (i '(exwm-randr-monitor)) + (unless (assq i frameset-filter-alist) + (push (cons i :never) frameset-filter-alist)))) + +(defun exwm-randr--exit () + "Exit the RandR module." + (exwm--log) + (remove-hook 'exwm-workspace-list-change-hook #'exwm-randr-refresh)) + +(defun exwm-randr-enable () + "Enable RandR support for EXWM." + (exwm--log) + (add-hook 'exwm-init-hook #'exwm-randr--init) + (add-hook 'exwm-exit-hook #'exwm-randr--exit)) + + + +(provide 'exwm-randr) + +;;; exwm-randr.el ends here diff --git a/third_party/emacs/exwm/exwm-systemtray.el b/third_party/emacs/exwm/exwm-systemtray.el new file mode 100644 index 000000000000..20dc5226cf6f --- /dev/null +++ b/third_party/emacs/exwm/exwm-systemtray.el @@ -0,0 +1,587 @@ +;;; exwm-systemtray.el --- System Tray Module for -*- lexical-binding: t -*- +;;; EXWM + +;; Copyright (C) 2016-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module adds system tray support for EXWM. + +;; To use this module, load and enable it as follows: +;; (require 'exwm-systemtray) +;; (exwm-systemtray-enable) + +;;; Code: + +(require 'xcb-icccm) +(require 'xcb-xembed) +(require 'xcb-systemtray) + +(require 'exwm-core) +(require 'exwm-workspace) + +(defclass exwm-systemtray--icon () + ((width :initarg :width) + (height :initarg :height) + (visible :initarg :visible)) + :documentation "Attributes of a system tray icon.") + +(defclass xcb:systemtray:-ClientMessage + (xcb:icccm:--ClientMessage xcb:ClientMessage) + ((format :initform 32) + (type :initform xcb:Atom:MANAGER) + (time :initarg :time :type xcb:TIMESTAMP) ;new slot + (selection :initarg :selection :type xcb:ATOM) ;new slot + (owner :initarg :owner :type xcb:WINDOW)) ;new slot + :documentation "A systemtray client message.") + +(defgroup exwm-systemtray nil + "System tray." + :version "25.3" + :group 'exwm) + +(defcustom exwm-systemtray-height nil + "System tray height. + +You shall use the default value if using auto-hide minibuffer." + :type 'integer) + +(defcustom exwm-systemtray-icon-gap 2 + "Gap between icons." + :type 'integer) + +(defvar exwm-systemtray--embedder-window nil "The embedder window.") + +(defcustom exwm-systemtray-background-color nil + "Background color of systemtray. + +This should be a color, or nil for transparent background." + :type '(choice (const :tag "Transparent" nil) + (color)) + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (set-default symbol value) + ;; Change the background color for embedder. + (when (and exwm--connection + exwm-systemtray--embedder-window) + (let ((background-pixel (exwm--color->pixel value))) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm-systemtray--embedder-window + :value-mask (logior xcb:CW:BackPixmap + (if background-pixel + xcb:CW:BackPixel 0)) + :background-pixmap + xcb:BackPixmap:ParentRelative + :background-pixel background-pixel)) + ;; Unmap & map to take effect immediately. + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow + :window exwm-systemtray--embedder-window)) + (xcb:flush exwm--connection))))) + +;; GTK icons require at least 16 pixels to show normally. +(defconst exwm-systemtray--icon-min-size 16 "Minimum icon size.") + +(defvar exwm-systemtray--connection nil "The X connection.") + +(defvar exwm-systemtray--list nil "The icon list.") + +(defvar exwm-systemtray--selection-owner-window nil + "The selection owner window.") + +(defvar xcb:Atom:_NET_SYSTEM_TRAY_S0) + +(defun exwm-systemtray--embed (icon) + "Embed an icon." + (exwm--log "Try to embed #x%x" icon) + (let ((info (xcb:+request-unchecked+reply exwm-systemtray--connection + (make-instance 'xcb:xembed:get-_XEMBED_INFO + :window icon))) + width* height* visible) + (when info + (exwm--log "Embed #x%x" icon) + (with-slots (width height) + (xcb:+request-unchecked+reply exwm-systemtray--connection + (make-instance 'xcb:GetGeometry :drawable icon)) + (setq height* exwm-systemtray-height + width* (round (* width (/ (float height*) height)))) + (when (< width* exwm-systemtray--icon-min-size) + (setq width* exwm-systemtray--icon-min-size + height* (round (* height (/ (float width*) width))))) + (exwm--log "Resize from %dx%d to %dx%d" + width height width* height*)) + ;; Add this icon to save-set. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ChangeSaveSet + :mode xcb:SetMode:Insert + :window icon)) + ;; Reparent to the embedder. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ReparentWindow + :window icon + :parent exwm-systemtray--embedder-window + :x 0 + ;; Vertically centered. + :y (/ (- exwm-systemtray-height height*) 2))) + ;; Resize the icon. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window icon + :value-mask (logior xcb:ConfigWindow:Width + xcb:ConfigWindow:Height + xcb:ConfigWindow:BorderWidth) + :width width* + :height height* + :border-width 0)) + ;; Set event mask. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ChangeWindowAttributes + :window icon + :value-mask xcb:CW:EventMask + :event-mask (logior xcb:EventMask:ResizeRedirect + xcb:EventMask:KeyPress + xcb:EventMask:PropertyChange))) + ;; Grab all keys and forward them to Emacs frame. + (unless (exwm-workspace--minibuffer-own-frame-p) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:GrabKey + :owner-events 0 + :grab-window icon + :modifiers xcb:ModMask:Any + :key xcb:Grab:Any + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async))) + (setq visible (slot-value info 'flags)) + (if visible + (setq visible + (/= 0 (logand (slot-value info 'flags) xcb:xembed:MAPPED))) + ;; Default to visible. + (setq visible t)) + (when visible + (exwm--log "Map the window") + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow :window icon))) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:xembed:SendEvent + :destination icon + :event + (xcb:marshal + (make-instance 'xcb:xembed:EMBEDDED-NOTIFY + :window icon + :time xcb:Time:CurrentTime + :embedder + exwm-systemtray--embedder-window + :version 0) + exwm-systemtray--connection))) + (push `(,icon . ,(make-instance 'exwm-systemtray--icon + :width width* + :height height* + :visible visible)) + exwm-systemtray--list) + (exwm-systemtray--refresh)))) + +(defun exwm-systemtray--unembed (icon) + "Unembed an icon." + (exwm--log "Unembed #x%x" icon) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow :window icon)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ReparentWindow + :window icon + :parent exwm--root + :x 0 :y 0)) + (setq exwm-systemtray--list + (assq-delete-all icon exwm-systemtray--list)) + (exwm-systemtray--refresh)) + +(defun exwm-systemtray--refresh () + "Refresh the system tray." + (exwm--log) + ;; Make sure to redraw the embedder. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (let ((x exwm-systemtray-icon-gap) + map) + (dolist (pair exwm-systemtray--list) + (when (slot-value (cdr pair) 'visible) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window (car pair) + :value-mask xcb:ConfigWindow:X + :x x)) + (setq x (+ x (slot-value (cdr pair) 'width) + exwm-systemtray-icon-gap)) + (setq map t))) + (let ((workarea (elt exwm-workspace--workareas + exwm-workspace-current-index))) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window exwm-systemtray--embedder-window + :value-mask (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Width) + :x (- (aref workarea 2) x) + :width x))) + (when map + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow + :window exwm-systemtray--embedder-window)))) + (xcb:flush exwm-systemtray--connection)) + +(defun exwm-systemtray--on-DestroyNotify (data _synthetic) + "Unembed icons on DestroyNotify." + (exwm--log) + (let ((obj (make-instance 'xcb:DestroyNotify))) + (xcb:unmarshal obj data) + (with-slots (window) obj + (when (assoc window exwm-systemtray--list) + (exwm-systemtray--unembed window))))) + +(defun exwm-systemtray--on-ReparentNotify (data _synthetic) + "Unembed icons on ReparentNotify." + (exwm--log) + (let ((obj (make-instance 'xcb:ReparentNotify))) + (xcb:unmarshal obj data) + (with-slots (window parent) obj + (when (and (/= parent exwm-systemtray--embedder-window) + (assoc window exwm-systemtray--list)) + (exwm-systemtray--unembed window))))) + +(defun exwm-systemtray--on-ResizeRequest (data _synthetic) + "Resize the tray icon on ResizeRequest." + (exwm--log) + (let ((obj (make-instance 'xcb:ResizeRequest)) + attr) + (xcb:unmarshal obj data) + (with-slots (window width height) obj + (when (setq attr (cdr (assoc window exwm-systemtray--list))) + (with-slots ((width* width) + (height* height)) + attr + (setq height* exwm-systemtray-height + width* (round (* width (/ (float height*) height)))) + (when (< width* exwm-systemtray--icon-min-size) + (setq width* exwm-systemtray--icon-min-size + height* (round (* height (/ (float width*) width))))) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height) + ;; Vertically centered. + :y (/ (- exwm-systemtray-height height*) 2) + :width width* + :height height*))) + (exwm-systemtray--refresh))))) + +(defun exwm-systemtray--on-PropertyNotify (data _synthetic) + "Map/Unmap the tray icon on PropertyNotify." + (exwm--log) + (let ((obj (make-instance 'xcb:PropertyNotify)) + attr info visible) + (xcb:unmarshal obj data) + (with-slots (window atom state) obj + (when (and (eq state xcb:Property:NewValue) + (eq atom xcb:Atom:_XEMBED_INFO) + (setq attr (cdr (assoc window exwm-systemtray--list)))) + (setq info (xcb:+request-unchecked+reply exwm-systemtray--connection + (make-instance 'xcb:xembed:get-_XEMBED_INFO + :window window))) + (when info + (setq visible (/= 0 (logand (slot-value info 'flags) + xcb:xembed:MAPPED))) + (exwm--log "#x%x visible? %s" window visible) + (if visible + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow :window window)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow :window window))) + (setf (slot-value attr 'visible) visible) + (exwm-systemtray--refresh)))))) + +(defun exwm-systemtray--on-ClientMessage (data _synthetic) + "Handle client messages." + (let ((obj (make-instance 'xcb:ClientMessage)) + opcode data32) + (xcb:unmarshal obj data) + (with-slots (window type data) obj + (when (eq type xcb:Atom:_NET_SYSTEM_TRAY_OPCODE) + (setq data32 (slot-value data 'data32) + opcode (elt data32 1)) + (exwm--log "opcode: %s" opcode) + (cond ((= opcode xcb:systemtray:opcode:REQUEST-DOCK) + (unless (assoc (elt data32 2) exwm-systemtray--list) + (exwm-systemtray--embed (elt data32 2)))) + ;; Not implemented (rarely used nowadays). + ((or (= opcode xcb:systemtray:opcode:BEGIN-MESSAGE) + (= opcode xcb:systemtray:opcode:CANCEL-MESSAGE))) + (t + (exwm--log "Unknown opcode message: %s" obj))))))) + +(defun exwm-systemtray--on-KeyPress (data _synthetic) + "Forward all KeyPress events to Emacs frame." + (exwm--log) + ;; This function is only executed when there's no autohide minibuffer, + ;; a workspace frame has the input focus and the pointer is over a + ;; tray icon. + (let ((dest (frame-parameter (selected-frame) 'exwm-outer-id)) + (obj (make-instance 'xcb:KeyPress))) + (xcb:unmarshal obj data) + (setf (slot-value obj 'event) dest) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination dest + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal obj exwm-systemtray--connection)))) + (xcb:flush exwm-systemtray--connection)) + +(defun exwm-systemtray--on-workspace-switch () + "Reparent/Refresh the system tray in `exwm-workspace-switch-hook'." + (exwm--log) + (unless (exwm-workspace--minibuffer-own-frame-p) + (exwm-workspace--update-offsets) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ReparentWindow + :window exwm-systemtray--embedder-window + :parent (string-to-number + (frame-parameter exwm-workspace--current + 'window-id)) + :x 0 + :y (- (elt (elt exwm-workspace--workareas + exwm-workspace-current-index) + 3) + exwm-workspace--frame-y-offset + exwm-systemtray-height)))) + (exwm-systemtray--refresh)) + +(defun exwm-systemtray--refresh-all () + "Reposition/Refresh the system tray." + (exwm--log) + (unless (exwm-workspace--minibuffer-own-frame-p) + (exwm-workspace--update-offsets) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window exwm-systemtray--embedder-window + :value-mask xcb:ConfigWindow:Y + :y (- (elt (elt exwm-workspace--workareas + exwm-workspace-current-index) + 3) + exwm-workspace--frame-y-offset + exwm-systemtray-height)))) + (exwm-systemtray--refresh)) + +(cl-defun exwm-systemtray--init () + "Initialize system tray module." + (exwm--log) + (cl-assert (not exwm-systemtray--connection)) + (cl-assert (not exwm-systemtray--list)) + (cl-assert (not exwm-systemtray--selection-owner-window)) + (cl-assert (not exwm-systemtray--embedder-window)) + (unless exwm-systemtray-height + (setq exwm-systemtray-height (max exwm-systemtray--icon-min-size + (line-pixel-height)))) + ;; Create a new connection. + (setq exwm-systemtray--connection (xcb:connect)) + (set-process-query-on-exit-flag (slot-value exwm-systemtray--connection + 'process) + nil) + ;; Initialize XELB modules. + (xcb:xembed:init exwm-systemtray--connection t) + (xcb:systemtray:init exwm-systemtray--connection t) + ;; Acquire the manager selection _NET_SYSTEM_TRAY_S0. + (with-slots (owner) + (xcb:+request-unchecked+reply exwm-systemtray--connection + (make-instance 'xcb:GetSelectionOwner + :selection xcb:Atom:_NET_SYSTEM_TRAY_S0)) + (when (/= owner xcb:Window:None) + (xcb:disconnect exwm-systemtray--connection) + (setq exwm-systemtray--connection nil) + (warn "[EXWM] Other system tray detected") + (cl-return-from exwm-systemtray--init))) + (let ((id (xcb:generate-id exwm-systemtray--connection))) + (setq exwm-systemtray--selection-owner-window id) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid id + :parent exwm--root + :x 0 + :y 0 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOnly + :visual 0 + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + ;; Get the selection ownership. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:SetSelectionOwner + :owner id + :selection xcb:Atom:_NET_SYSTEM_TRAY_S0 + :time xcb:Time:CurrentTime)) + ;; Send a client message to announce the selection. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination exwm--root + :event-mask xcb:EventMask:StructureNotify + :event (xcb:marshal + (make-instance 'xcb:systemtray:-ClientMessage + :window exwm--root + :time xcb:Time:CurrentTime + :selection + xcb:Atom:_NET_SYSTEM_TRAY_S0 + :owner id) + exwm-systemtray--connection))) + ;; Set _NET_WM_NAME. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window id + :data "EXWM: exwm-systemtray--selection-owner-window")) + ;; Set the _NET_SYSTEM_TRAY_ORIENTATION property. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:xembed:set-_NET_SYSTEM_TRAY_ORIENTATION + :window id + :data xcb:systemtray:ORIENTATION:HORZ))) + ;; Create the embedder. + (let ((id (xcb:generate-id exwm-systemtray--connection)) + (background-pixel (exwm--color->pixel exwm-systemtray-background-color)) + frame parent depth y) + (setq exwm-systemtray--embedder-window id) + (if (exwm-workspace--minibuffer-own-frame-p) + (setq frame exwm-workspace--minibuffer + y (if (>= (line-pixel-height) exwm-systemtray-height) + ;; Bottom aligned. + (- (line-pixel-height) exwm-systemtray-height) + ;; Vertically centered. + (/ (- (line-pixel-height) exwm-systemtray-height) 2))) + (exwm-workspace--update-offsets) + (setq frame exwm-workspace--current + ;; Bottom aligned. + y (- (elt (elt exwm-workspace--workareas + exwm-workspace-current-index) + 3) + exwm-workspace--frame-y-offset + exwm-systemtray-height))) + (setq parent (string-to-number (frame-parameter frame 'window-id)) + depth (slot-value (xcb:+request-unchecked+reply + exwm-systemtray--connection + (make-instance 'xcb:GetGeometry + :drawable parent)) + 'depth)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:CreateWindow + :depth depth + :wid id + :parent parent + :x 0 + :y y + :width 1 + :height exwm-systemtray-height + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask (logior xcb:CW:BackPixmap + (if background-pixel + xcb:CW:BackPixel 0) + xcb:CW:EventMask) + :background-pixmap xcb:BackPixmap:ParentRelative + :background-pixel background-pixel + :event-mask xcb:EventMask:SubstructureNotify)) + ;; Set _NET_WM_NAME. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window id + :data "EXWM: exwm-systemtray--embedder-window"))) + (xcb:flush exwm-systemtray--connection) + ;; Attach event listeners. + (xcb:+event exwm-systemtray--connection 'xcb:DestroyNotify + #'exwm-systemtray--on-DestroyNotify) + (xcb:+event exwm-systemtray--connection 'xcb:ReparentNotify + #'exwm-systemtray--on-ReparentNotify) + (xcb:+event exwm-systemtray--connection 'xcb:ResizeRequest + #'exwm-systemtray--on-ResizeRequest) + (xcb:+event exwm-systemtray--connection 'xcb:PropertyNotify + #'exwm-systemtray--on-PropertyNotify) + (xcb:+event exwm-systemtray--connection 'xcb:ClientMessage + #'exwm-systemtray--on-ClientMessage) + (unless (exwm-workspace--minibuffer-own-frame-p) + (xcb:+event exwm-systemtray--connection 'xcb:KeyPress + #'exwm-systemtray--on-KeyPress)) + ;; Add hook to move/reparent the embedder. + (add-hook 'exwm-workspace-switch-hook #'exwm-systemtray--on-workspace-switch) + (add-hook 'exwm-workspace--update-workareas-hook + #'exwm-systemtray--refresh-all) + (add-hook 'menu-bar-mode-hook #'exwm-systemtray--refresh-all) + (add-hook 'tool-bar-mode-hook #'exwm-systemtray--refresh-all) + (when (boundp 'exwm-randr-refresh-hook) + (add-hook 'exwm-randr-refresh-hook #'exwm-systemtray--refresh-all)) + ;; The struts can be updated already. + (when exwm-workspace--workareas + (exwm-systemtray--refresh-all))) + +(defun exwm-systemtray--exit () + "Exit the systemtray module." + (exwm--log) + (when exwm-systemtray--connection + ;; Hide & reparent out the embedder before disconnection to prevent + ;; embedded icons from being reparented to an Emacs frame (which is the + ;; parent of the embedder). + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ReparentWindow + :window exwm-systemtray--embedder-window + :parent exwm--root + :x 0 + :y 0)) + (xcb:disconnect exwm-systemtray--connection) + (setq exwm-systemtray--connection nil + exwm-systemtray--list nil + exwm-systemtray--selection-owner-window nil + exwm-systemtray--embedder-window nil) + (remove-hook 'exwm-workspace-switch-hook + #'exwm-systemtray--on-workspace-switch) + (remove-hook 'exwm-workspace--update-workareas-hook + #'exwm-systemtray--refresh-all) + (remove-hook 'menu-bar-mode-hook #'exwm-systemtray--refresh-all) + (remove-hook 'tool-bar-mode-hook #'exwm-systemtray--refresh-all) + (when (boundp 'exwm-randr-refresh-hook) + (remove-hook 'exwm-randr-refresh-hook #'exwm-systemtray--refresh-all)))) + +(defun exwm-systemtray-enable () + "Enable system tray support for EXWM." + (exwm--log) + (add-hook 'exwm-init-hook #'exwm-systemtray--init) + (add-hook 'exwm-exit-hook #'exwm-systemtray--exit)) + + + +(provide 'exwm-systemtray) + +;;; exwm-systemtray.el ends here diff --git a/third_party/emacs/exwm/exwm-workspace.el b/third_party/emacs/exwm/exwm-workspace.el new file mode 100644 index 000000000000..cff17f3a113a --- /dev/null +++ b/third_party/emacs/exwm/exwm-workspace.el @@ -0,0 +1,1750 @@ +;;; exwm-workspace.el --- Workspace Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module adds workspace support for EXWM. + +;;; Code: + +(require 'server) + +(require 'exwm-core) + +(defgroup exwm-workspace nil + "Workspace." + :version "25.3" + :group 'exwm) + +(defcustom exwm-workspace-switch-hook nil + "Normal hook run after switching workspace." + :type 'hook) + +(defcustom exwm-workspace-list-change-hook nil + "Normal hook run when the workspace list is changed (workspace added, +deleted, moved, etc)." + :type 'hook) + +(defcustom exwm-workspace-show-all-buffers nil + "Non-nil to show buffers on other workspaces." + :type 'boolean) + +(defcustom exwm-workspace-warp-cursor nil + "Non-nil to warp cursor automatically after workspace switch." + :type 'boolean) + +(defcustom exwm-workspace-number 1 + "Initial number of workspaces." + :type 'integer) + +(defcustom exwm-workspace-index-map #'number-to-string + "Function for mapping a workspace index to a string for display. + +By default `number-to-string' is applied which yields 0 1 2 ... ." + :type 'function) + +(defcustom exwm-workspace-minibuffer-position nil + "Position of the minibuffer frame. + +A restart is required for this change to take effect." + :type '(choice (const :tag "Bottom (fixed)" nil) + (const :tag "Bottom (auto-hide)" bottom) + (const :tag "Top (auto-hide)" top))) + +(defcustom exwm-workspace-display-echo-area-timeout 1 + "Timeout for displaying echo area." + :type 'integer) + +(defcustom exwm-workspace-switch-create-limit 10 + "Number of workspaces `exwm-workspace-switch-create' allowed to create +each time." + :type 'integer) + +(defvar exwm-workspace-current-index 0 "Index of current active workspace.") + +(defvar exwm-workspace--attached-minibuffer-height 0 + "Height (in pixel) of the attached minibuffer. + +If the minibuffer is detached, this value is 0.") + +(defvar exwm-workspace--client nil + "The 'client' frame parameter of emacsclient frames.") + +(defvar exwm-workspace--create-silently nil + "When non-nil workspaces are created in the background (not switched to). + +Please manually run the hook `exwm-workspace-list-change-hook' afterwards.") + +(defvar exwm-workspace--current nil "Current active workspace.") + +(defvar exwm-workspace--display-echo-area-timer nil + "Timer for auto-hiding echo area.") + +(defvar exwm-workspace--id-struts-alist nil "Alist of X window and struts.") + +(defvar exwm-workspace--fullscreen-frame-count 0 + "Count the fullscreen workspace frames.") + +(defvar exwm-workspace--list nil "List of all workspaces (Emacs frames).") + +(defvar exwm-workspace--minibuffer nil + "The minibuffer frame shared among all frames.") + +(defvar exwm-workspace--original-handle-focus-in + (symbol-function #'handle-focus-in)) +(defvar exwm-workspace--original-handle-focus-out + (symbol-function #'handle-focus-out)) + +(defvar exwm-workspace--prompt-add-allowed nil + "Non-nil to allow adding workspace from the prompt.") + +(defvar exwm-workspace--prompt-delete-allowed nil + "Non-nil to allow deleting workspace from the prompt.") + +(defvar exwm-workspace--struts nil "Areas occupied by struts.") + +(defvar exwm-workspace--switch-history nil + "History for `read-from-minibuffer' to interactively switch workspace.") + +(defvar exwm-workspace--switch-history-outdated nil + "Non-nil to indicate `exwm-workspace--switch-history' is outdated.") + +(defvar exwm-workspace--timer nil "Timer used to track echo area changes.") + +(defvar exwm-workspace--update-workareas-hook nil + "Normal hook run when workareas get updated.") + +(defvar exwm-workspace--workareas nil "Workareas (struts excluded).") + +(defvar exwm-workspace--frame-y-offset 0 + "Offset between Emacs inner & outer frame in Y.") +(defvar exwm-workspace--window-y-offset 0 + "Offset between Emacs first window & outer frame in Y.") + +(defvar exwm-input--during-command) +(defvar exwm-input--event-hook) +(defvar exwm-layout-show-all-buffers) +(defvar exwm-manage--desktop) +(declare-function exwm-input--on-buffer-list-update "exwm-input.el" ()) +(declare-function exwm-layout--fullscreen-p "exwm-layout.el" ()) +(declare-function exwm-layout--hide "exwm-layout.el" (id)) +(declare-function exwm-layout--other-buffer-predicate "exwm-layout.el" + (buffer)) +(declare-function exwm-layout--refresh "exwm-layout.el") +(declare-function exwm-layout--show "exwm-layout.el" (id &optional window)) + +(defsubst exwm-workspace--position (frame) + "Retrieve index of given FRAME in workspace list. + +NIL if FRAME is not a workspace" + (cl-position frame exwm-workspace--list)) + +(defsubst exwm-workspace--count () + "Retrieve total number of workspaces." + (length exwm-workspace--list)) + +(defsubst exwm-workspace--workspace-p (frame) + "Return t if FRAME is a workspace." + (memq frame exwm-workspace--list)) + +(defsubst exwm-workspace--client-p (&optional frame) + "Return non-nil if FRAME is an emacsclient frame." + (or (frame-parameter frame 'client) + (not (display-graphic-p frame)))) + +(defvar exwm-workspace--switch-map nil + "Keymap used for interactively selecting workspace.") + +(defun exwm-workspace--init-switch-map () + (let ((map (make-sparse-keymap))) + (define-key map [t] (lambda () (interactive))) + (define-key map "+" #'exwm-workspace--prompt-add) + (define-key map "-" #'exwm-workspace--prompt-delete) + (dotimes (i 10) + (define-key map (int-to-string i) + #'exwm-workspace--switch-map-nth-prefix)) + (unless (eq exwm-workspace-index-map #'number-to-string) + ;; Add extra (and possibly override) keys for selecting workspace. + (dotimes (i 10) + (let ((key (funcall exwm-workspace-index-map i))) + (when (and (stringp key) + (= (length key) 1) + (<= 0 (elt key 0) 127)) + (define-key map key + (lambda () + (interactive) + (exwm-workspace--switch-map-select-nth i))))))) + (define-key map "\C-a" (lambda () (interactive) (goto-history-element 1))) + (define-key map "\C-e" (lambda () + (interactive) + (goto-history-element (exwm-workspace--count)))) + (define-key map "\C-g" #'abort-recursive-edit) + (define-key map "\C-]" #'abort-recursive-edit) + (define-key map "\C-j" #'exit-minibuffer) + ;; (define-key map "\C-m" #'exit-minibuffer) ;not working + (define-key map [return] #'exit-minibuffer) + (define-key map " " #'exit-minibuffer) + (define-key map "\C-f" #'previous-history-element) + (define-key map "\C-b" #'next-history-element) + ;; Alternative keys + (define-key map [right] #'previous-history-element) + (define-key map [left] #'next-history-element) + (setq exwm-workspace--switch-map map))) + +(defun exwm-workspace--workspace-from-frame-or-index (frame-or-index) + "Retrieve the workspace frame from FRAME-OR-INDEX." + (cond + ((framep frame-or-index) + (unless (exwm-workspace--position frame-or-index) + (user-error "[EXWM] Frame is not a workspace %S" frame-or-index)) + frame-or-index) + ((integerp frame-or-index) + (unless (and (<= 0 frame-or-index) + (< frame-or-index (exwm-workspace--count))) + (user-error "[EXWM] Workspace index out of range: %d" frame-or-index)) + (elt exwm-workspace--list frame-or-index)) + (t (user-error "[EXWM] Invalid workspace: %s" frame-or-index)))) + +(defun exwm-workspace--prompt-for-workspace (&optional prompt) + "Prompt for a workspace, returning the workspace frame." + (exwm-workspace--update-switch-history) + (let* ((current-idx (exwm-workspace--position exwm-workspace--current)) + (history-add-new-input nil) ;prevent modifying history + (history-idx (read-from-minibuffer + (or prompt "Workspace: ") + (elt exwm-workspace--switch-history current-idx) + exwm-workspace--switch-map nil + `(exwm-workspace--switch-history . ,(1+ current-idx)))) + (workspace-idx (cl-position history-idx exwm-workspace--switch-history + :test #'equal))) + (elt exwm-workspace--list workspace-idx))) + +(defun exwm-workspace--prompt-add () + "Add workspace from the prompt." + (interactive) + (when exwm-workspace--prompt-add-allowed + (let ((exwm-workspace--create-silently t)) + (make-frame) + (run-hooks 'exwm-workspace-list-change-hook)) + (exwm-workspace--update-switch-history) + (goto-history-element minibuffer-history-position))) + +(defun exwm-workspace--prompt-delete () + "Delete workspace from the prompt." + (interactive) + (when (and exwm-workspace--prompt-delete-allowed + (< 1 (exwm-workspace--count))) + (let ((frame (elt exwm-workspace--list (1- minibuffer-history-position)))) + (exwm-workspace--get-remove-frame-next-workspace frame) + (if (eq frame exwm-workspace--current) + ;; Abort the recursive minibuffer if deleting the current workspace. + (progn + (exwm--defer 0 #'delete-frame frame) + (abort-recursive-edit)) + (delete-frame frame) + (exwm-workspace--update-switch-history) + (goto-history-element (min minibuffer-history-position + (exwm-workspace--count))))))) + +(defun exwm-workspace--update-switch-history () + "Update the history for switching workspace to reflect the latest status." + (when exwm-workspace--switch-history-outdated + (setq exwm-workspace--switch-history-outdated nil) + (let* ((num (exwm-workspace--count)) + (sequence (number-sequence 0 (1- num))) + (not-empty (make-vector num nil))) + (dolist (i exwm--id-buffer-alist) + (with-current-buffer (cdr i) + (when exwm--frame + (setf (aref not-empty + (exwm-workspace--position exwm--frame)) + t)))) + (setq exwm-workspace--switch-history + (mapcar + (lambda (i) + (mapconcat + (lambda (j) + (format (if (= i j) "[%s]" " %s ") + (propertize + (apply exwm-workspace-index-map (list j)) + 'face + (cond ((frame-parameter (elt exwm-workspace--list j) + 'exwm-urgency) + '(:foreground "orange")) + ((aref not-empty j) '(:foreground "green")) + (t nil))))) + sequence "")) + sequence))))) + +;;;###autoload +(defun exwm-workspace--get-geometry (frame) + "Return the geometry of frame FRAME." + (or (frame-parameter frame 'exwm-geometry) + (make-instance 'xcb:RECTANGLE + :x 0 + :y 0 + :width (x-display-pixel-width) + :height (x-display-pixel-height)))) + +;;;###autoload +(defun exwm-workspace--current-height () + "Return the height of current workspace." + (let ((geometry (frame-parameter exwm-workspace--current 'exwm-geometry))) + (if geometry + (slot-value geometry 'height) + (x-display-pixel-height)))) + +;;;###autoload +(defun exwm-workspace--minibuffer-own-frame-p () + "Reports whether the minibuffer is displayed in its own frame." + (memq exwm-workspace-minibuffer-position '(top bottom))) + +(defun exwm-workspace--update-struts () + "Update `exwm-workspace--struts'." + (setq exwm-workspace--struts nil) + (let (struts struts*) + (dolist (pair exwm-workspace--id-struts-alist) + (setq struts (cdr pair)) + (when struts + (dotimes (i 4) + (when (/= 0 (aref struts i)) + (setq struts* + (vector (aref [left right top bottom] i) + (aref struts i) + (when (= 12 (length struts)) + (substring struts (+ 4 (* i 2)) (+ 6 (* i 2)))))) + (if (= 0 (mod i 2)) + ;; Make left/top processed first. + (push struts* exwm-workspace--struts) + (setq exwm-workspace--struts + (append exwm-workspace--struts (list struts*)))))))) + (exwm--log "%s" exwm-workspace--struts))) + +(defun exwm-workspace--update-workareas () + "Update `exwm-workspace--workareas'." + (let ((root-width (x-display-pixel-width)) + (root-height (x-display-pixel-height)) + workareas + edge width position + delta) + ;; Calculate workareas with no struts. + (if (frame-parameter (car exwm-workspace--list) 'exwm-geometry) + ;; Use the 'exwm-geometry' frame parameter if possible. + (dolist (f exwm-workspace--list) + (with-slots (x y width height) (frame-parameter f 'exwm-geometry) + (setq workareas (append workareas + (list (vector x y width height)))))) + ;; Fall back to use the screen size. + (let ((workarea (vector 0 0 root-width root-height))) + (setq workareas (make-list (exwm-workspace--count) workarea)))) + ;; Exclude areas occupied by struts. + (dolist (struts exwm-workspace--struts) + (setq edge (aref struts 0) + width (aref struts 1) + position (aref struts 2)) + (dolist (w workareas) + (pcase edge + ;; Left and top are always processed first. + (`left + (setq delta (- (aref w 0) width)) + (when (and (< delta 0) + (or (not position) + (< (max (aref position 0) (aref w 1)) + (min (aref position 1) + (+ (aref w 1) (aref w 3)))))) + (cl-incf (aref w 2) delta) + (setf (aref w 0) width))) + (`right + (setq delta (- root-width (aref w 0) (aref w 2) width)) + (when (and (< delta 0) + (or (not position) + (< (max (aref position 0) (aref w 1)) + (min (aref position 1) + (+ (aref w 1) (aref w 3)))))) + (cl-incf (aref w 2) delta))) + (`top + (setq delta (- (aref w 1) width)) + (when (and (< delta 0) + (or (not position) + (< (max (aref position 0) (aref w 0)) + (min (aref position 1) + (+ (aref w 0) (aref w 2)))))) + (cl-incf (aref w 3) delta) + (setf (aref w 1) width))) + (`bottom + (setq delta (- root-height (aref w 1) (aref w 3) width)) + (when (and (< delta 0) + (or (not position) + (< (max (aref position 0) (aref w 0)) + (min (aref position 1) + (+ (aref w 0) (aref w 2)))))) + (cl-incf (aref w 3) delta)))))) + ;; Save the result. + (setq exwm-workspace--workareas workareas) + (xcb:flush exwm--connection)) + (exwm--log "%s" exwm-workspace--workareas) + (run-hooks 'exwm-workspace--update-workareas-hook)) + +(defun exwm-workspace--update-offsets () + "Update `exwm-workspace--frame-y-offset'/`exwm-workspace--window-y-offset'." + (exwm--log) + (if (not (and exwm-workspace--list + (or menu-bar-mode tool-bar-mode))) + (setq exwm-workspace--frame-y-offset 0 + exwm-workspace--window-y-offset 0) + (redisplay t) + (let* ((frame (elt exwm-workspace--list 0)) + (edges (window-inside-absolute-pixel-edges (frame-first-window + frame)))) + (with-slots (y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable (frame-parameter frame + 'exwm-container))) + (with-slots ((y* y)) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable (frame-parameter frame + 'exwm-outer-id))) + (with-slots ((y** y)) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable (frame-parameter frame 'exwm-id))) + (setq exwm-workspace--frame-y-offset (- y** y*) + exwm-workspace--window-y-offset (- (elt edges 1) y)))))))) + +(defun exwm-workspace--set-active (frame active) + "Make frame FRAME active on its monitor." + (exwm--log "active=%s; frame=%s" frame active) + (set-frame-parameter frame 'exwm-active active) + (if active + (exwm-workspace--set-fullscreen frame) + (exwm--set-geometry (frame-parameter frame 'exwm-container) nil nil 1 1)) + (exwm-layout--refresh frame) + (xcb:flush exwm--connection)) + +(defun exwm-workspace--active-p (frame) + "Return non-nil if FRAME is active" + (frame-parameter frame 'exwm-active)) + +(defun exwm-workspace--set-fullscreen (frame) + "Make frame FRAME fullscreen according to `exwm-workspace--workareas'." + (exwm--log "frame=%s" frame) + (let ((workarea (elt exwm-workspace--workareas + (exwm-workspace--position frame))) + (id (frame-parameter frame 'exwm-outer-id)) + (container (frame-parameter frame 'exwm-container)) + x y width height) + (setq x (aref workarea 0) + y (aref workarea 1) + width (aref workarea 2) + height (aref workarea 3)) + (exwm--log "x=%s; y=%s; w=%s; h=%s" x y width height) + (when (and (eq frame exwm-workspace--current) + (exwm-workspace--minibuffer-own-frame-p)) + (exwm-workspace--resize-minibuffer-frame)) + (if (exwm-workspace--active-p frame) + (exwm--set-geometry container x y width height) + (exwm--set-geometry container x y 1 1)) + (exwm--set-geometry id nil nil width height) + (xcb:flush exwm--connection)) + ;; This is only used for workspace initialization. + (when exwm-workspace--fullscreen-frame-count + (cl-incf exwm-workspace--fullscreen-frame-count))) + +(defun exwm-workspace--resize-minibuffer-frame () + "Resize minibuffer (and its container) to fit the size of workspace." + (cl-assert (exwm-workspace--minibuffer-own-frame-p)) + (let ((workarea (elt exwm-workspace--workareas exwm-workspace-current-index)) + (container (frame-parameter exwm-workspace--minibuffer + 'exwm-container)) + y width) + (setq y (if (eq exwm-workspace-minibuffer-position 'top) + (- (aref workarea 1) + exwm-workspace--attached-minibuffer-height) + ;; Reset the frame size. + (set-frame-height exwm-workspace--minibuffer 1) + (redisplay) ;FIXME. + (+ (aref workarea 1) (aref workarea 3) + (- (frame-pixel-height exwm-workspace--minibuffer)) + exwm-workspace--attached-minibuffer-height)) + width (aref workarea 2)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container + :value-mask (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + (if exwm-manage--desktop + xcb:ConfigWindow:Sibling + 0) + xcb:ConfigWindow:StackMode) + :x (aref workarea 0) + :y y + :width width + :sibling exwm-manage--desktop + :stack-mode (if exwm-manage--desktop + xcb:StackMode:Above + xcb:StackMode:Below))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm-workspace--minibuffer + 'exwm-outer-id) + :value-mask xcb:ConfigWindow:Width + :width width)) + (exwm--log "y: %s, width: %s" y width))) + +(defun exwm-workspace--switch-map-nth-prefix (&optional prefix-digits) + "Allow selecting a workspace by number. + +PREFIX-DIGITS is a list of the digits introduced so far." + (interactive) + (let* ((k (aref (substring (this-command-keys-vector) -1) 0)) + (d (- k ?0)) + ;; Convert prefix-digits to number. For example, '(2 1) to 120. + (o 1) + (pn (apply #'+ (mapcar (lambda (x) + (setq o (* 10 o)) + (* o x)) + prefix-digits))) + (n (+ pn d)) + prefix-length index-max index-length) + (if (or (= n 0) + (> n + (setq index-max (1- (exwm-workspace--count)))) + (>= (setq prefix-length (length prefix-digits)) + (setq index-length (floor (log index-max 10)))) + ;; Check if it's still possible to do a match. + (> (* n (expt 10 (- index-length prefix-length))) + index-max)) + (exwm-workspace--switch-map-select-nth n) + ;; Go ahead if there are enough digits to select any workspace. + (set-transient-map + (let ((map (make-sparse-keymap)) + (cmd (let ((digits (cons d prefix-digits))) + (lambda () + (interactive) + (exwm-workspace--switch-map-nth-prefix digits))))) + (dotimes (i 10) + (define-key map (int-to-string i) cmd)) + ;; Accept + (define-key map [return] + (lambda () + (interactive) + (exwm-workspace--switch-map-select-nth n))) + map))))) + +(defun exwm-workspace--switch-map-select-nth (n) + "Select Nth workspace." + (interactive) + (goto-history-element (1+ n)) + (exit-minibuffer)) + +;;;###autoload +(defun exwm-workspace-switch (frame-or-index &optional force) + "Switch to workspace INDEX (0-based). + +Query for the index if not specified when called interactively. Passing a +workspace frame as the first option or making use of the rest options are +for internal use only." + (interactive + (list + (cond + ((null current-prefix-arg) + (unless (and (derived-mode-p 'exwm-mode) + ;; The prompt is invisible in fullscreen mode. + (exwm-layout--fullscreen-p)) + (let ((exwm-workspace--prompt-add-allowed t) + (exwm-workspace--prompt-delete-allowed t)) + (exwm-workspace--prompt-for-workspace "Switch to [+/-]: ")))) + ((and (integerp current-prefix-arg) + (<= 0 current-prefix-arg (exwm-workspace--count))) + current-prefix-arg) + (t 0)))) + (exwm--log) + (let* ((frame (exwm-workspace--workspace-from-frame-or-index frame-or-index)) + (old-frame exwm-workspace--current) + (index (exwm-workspace--position frame)) + (window (frame-parameter frame 'exwm-selected-window))) + (when (or force (not (eq frame exwm-workspace--current))) + (unless (window-live-p window) + (setq window (frame-selected-window frame))) + (when (and (not (eq frame old-frame)) + (frame-live-p old-frame)) + (with-selected-frame old-frame + (funcall exwm-workspace--original-handle-focus-out + (list 'focus-out frame)))) + ;; Raise this frame. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter frame 'exwm-container) + :value-mask (logior xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling exwm--guide-window + :stack-mode xcb:StackMode:Below)) + (setq exwm-workspace--current frame + exwm-workspace-current-index index) + (unless (exwm-workspace--workspace-p (selected-frame)) + ;; Save the floating frame window selected on the previous workspace. + (set-frame-parameter (buffer-local-value 'exwm--frame (window-buffer)) + 'exwm-selected-window (selected-window))) + ;; Show/Hide X windows. + (let ((monitor-old (frame-parameter old-frame 'exwm-randr-monitor)) + (monitor-new (frame-parameter frame 'exwm-randr-monitor)) + (active-old (exwm-workspace--active-p old-frame)) + (active-new (exwm-workspace--active-p frame)) + workspaces-to-hide) + (cond + ((not active-old) + (exwm-workspace--set-active frame t)) + ((equal monitor-old monitor-new) + (exwm-workspace--set-active frame t) + (unless (eq frame old-frame) + (exwm-workspace--set-active old-frame nil) + (setq workspaces-to-hide (list old-frame)))) + (active-new) + (t + (dolist (w exwm-workspace--list) + (when (and (exwm-workspace--active-p w) + (equal monitor-new + (frame-parameter w 'exwm-randr-monitor))) + (exwm-workspace--set-active w nil) + (setq workspaces-to-hide (append workspaces-to-hide (list w))))) + (exwm-workspace--set-active frame t))) + (dolist (i exwm--id-buffer-alist) + (with-current-buffer (cdr i) + (if (memq exwm--frame workspaces-to-hide) + (exwm-layout--hide exwm--id) + (when (eq frame exwm--frame) + (let ((window (get-buffer-window nil t))) + (when window + (exwm-layout--show exwm--id window)))))))) + (select-window window) + (x-focus-frame (window-frame window)) ;The real input focus. + (set-frame-parameter frame 'exwm-selected-window nil) + (if (exwm-workspace--minibuffer-own-frame-p) + ;; Resize the minibuffer frame. + (exwm-workspace--resize-minibuffer-frame) + ;; Set a default minibuffer frame. + (setq default-minibuffer-frame frame)) + ;; Hide windows in other workspaces by preprending a space + (unless exwm-workspace-show-all-buffers + (dolist (i exwm--id-buffer-alist) + (with-current-buffer (cdr i) + (let ((name (replace-regexp-in-string "^\\s-*" "" + (buffer-name)))) + (exwm-workspace-rename-buffer (if (eq frame exwm--frame) + name + (concat " " name))))))) + ;; Update demands attention flag + (set-frame-parameter frame 'exwm-urgency nil) + ;; Update switch workspace history + (setq exwm-workspace--switch-history-outdated t) + ;; Set _NET_CURRENT_DESKTOP + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_CURRENT_DESKTOP + :window exwm--root :data index)) + (xcb:flush exwm--connection)) + (when exwm-workspace-warp-cursor + (with-slots (win-x win-y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryPointer + :window (frame-parameter frame + 'exwm-outer-id))) + (when (or (< win-x 0) + (< win-y 0) + (> win-x (frame-pixel-width frame)) + (> win-y (frame-pixel-height frame))) + (xcb:+request exwm--connection + (make-instance 'xcb:WarpPointer + :src-window xcb:Window:None + :dst-window (frame-parameter frame + 'exwm-outer-id) + :src-x 0 + :src-y 0 + :src-width 0 + :src-height 0 + :dst-x (/ (frame-pixel-width frame) 2) + :dst-y (/ (frame-pixel-height frame) 2))) + (xcb:flush exwm--connection)))) + (funcall exwm-workspace--original-handle-focus-in (list 'focus-in frame)) + (run-hooks 'exwm-workspace-switch-hook))) + +;;;###autoload +(defun exwm-workspace-switch-create (frame-or-index) + "Switch to workspace INDEX or creating it first if it does not exist yet. + +Passing a workspace frame as the first option is for internal use only." + (interactive + (list + (cond + ((integerp current-prefix-arg) + current-prefix-arg) + (t 0)))) + (unless frame-or-index + (setq frame-or-index 0)) + (exwm--log "%s" frame-or-index) + (if (or (framep frame-or-index) + (< frame-or-index (exwm-workspace--count))) + (exwm-workspace-switch frame-or-index) + (let ((exwm-workspace--create-silently t)) + (dotimes (_ (min exwm-workspace-switch-create-limit + (1+ (- frame-or-index + (exwm-workspace--count))))) + (make-frame)) + (run-hooks 'exwm-workspace-list-change-hook)) + (exwm-workspace-switch frame-or-index))) + +;;;###autoload +(defun exwm-workspace-swap (workspace1 workspace2) + "Interchange position of WORKSPACE1 with that of WORKSPACE2." + (interactive + (unless (and (derived-mode-p 'exwm-mode) + ;; The prompt is invisible in fullscreen mode. + (exwm-layout--fullscreen-p)) + (let (w1 w2) + (let ((exwm-workspace--prompt-add-allowed t) + (exwm-workspace--prompt-delete-allowed t)) + (setq w1 (exwm-workspace--prompt-for-workspace + "Pick a workspace [+/-]: "))) + (setq w2 (exwm-workspace--prompt-for-workspace + (format "Swap workspace %d with: " + (exwm-workspace--position w1)))) + (list w1 w2)))) + (exwm--log) + (let ((pos1 (exwm-workspace--position workspace1)) + (pos2 (exwm-workspace--position workspace2))) + (if (or (not pos1) (not pos2) (= pos1 pos2)) + (user-error "[EXWM] Cannot swap %s and %s" workspace1 workspace2) + (setf (elt exwm-workspace--list pos1) workspace2) + (setf (elt exwm-workspace--list pos2) workspace1) + ;; Update the _NET_WM_DESKTOP property of each X window affected. + (dolist (pair exwm--id-buffer-alist) + (when (memq (buffer-local-value 'exwm--frame (cdr pair)) + (list workspace1 workspace2)) + (exwm-workspace--set-desktop (car pair)))) + (xcb:flush exwm--connection) + (when (memq exwm-workspace--current (list workspace1 workspace2)) + ;; With the current workspace involved, lots of stuffs need refresh. + (set-frame-parameter exwm-workspace--current 'exwm-selected-window + (selected-window)) + (exwm-workspace-switch exwm-workspace--current t)) + (run-hooks 'exwm-workspace-list-change-hook)))) + +;;;###autoload +(defun exwm-workspace-move (workspace nth) + "Move WORKSPACE to the NTH position. + +When called interactively, prompt for a workspace and move current one just +before it." + (interactive + (cond + ((null current-prefix-arg) + (unless (and (derived-mode-p 'exwm-mode) + ;; The prompt is invisible in fullscreen mode. + (exwm-layout--fullscreen-p)) + (list exwm-workspace--current + (exwm-workspace--position + (exwm-workspace--prompt-for-workspace "Move workspace to: "))))) + ((and (integerp current-prefix-arg) + (<= 0 current-prefix-arg (exwm-workspace--count))) + (list exwm-workspace--current current-prefix-arg)) + (t (list exwm-workspace--current 0)))) + (exwm--log) + (let ((pos (exwm-workspace--position workspace)) + flag start end index) + (if (= nth pos) + (user-error "[EXWM] Cannot move to same position") + ;; Set if the current workspace is involved. + (setq flag (or (eq workspace exwm-workspace--current) + (eq (elt exwm-workspace--list nth) + exwm-workspace--current))) + ;; Do the move. + (with-no-warnings ;For Emacs 24. + (pop (nthcdr pos exwm-workspace--list))) + (push workspace (nthcdr nth exwm-workspace--list)) + ;; Update the _NET_WM_DESKTOP property of each X window affected. + (setq start (min pos nth) + end (max pos nth)) + (dolist (pair exwm--id-buffer-alist) + (setq index (exwm-workspace--position + (buffer-local-value 'exwm--frame (cdr pair)))) + (unless (or (< index start) (> index end)) + (exwm-workspace--set-desktop (car pair)))) + (when flag + ;; With the current workspace involved, lots of stuffs need refresh. + (set-frame-parameter exwm-workspace--current 'exwm-selected-window + (selected-window)) + (exwm-workspace-switch exwm-workspace--current t)) + (run-hooks 'exwm-workspace-list-change-hook)))) + +;;;###autoload +(defun exwm-workspace-add (&optional index) + "Add a workspace as the INDEX-th workspace, or the last one if INDEX is nil. + +INDEX must not exceed the current number of workspaces." + (interactive) + (exwm--log "%s" index) + (if (and index + ;; No need to move if it's the last one. + (< index (exwm-workspace--count))) + (exwm-workspace-move (make-frame) index) + (make-frame))) + +;;;###autoload +(defun exwm-workspace-delete (&optional frame-or-index) + "Delete the workspace FRAME-OR-INDEX." + (interactive) + (exwm--log "%s" frame-or-index) + (when (< 1 (exwm-workspace--count)) + (let ((frame (if frame-or-index + (exwm-workspace--workspace-from-frame-or-index + frame-or-index) + exwm-workspace--current))) + (exwm-workspace--get-remove-frame-next-workspace frame) + (delete-frame frame)))) + +(defun exwm-workspace--set-desktop (id) + "Set _NET_WM_DESKTOP for X window ID." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (let ((desktop (exwm-workspace--position exwm--frame))) + (setq exwm--desktop desktop) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_DESKTOP + :window id + :data desktop))))) + +;;;###autoload +(cl-defun exwm-workspace-move-window (frame-or-index &optional id) + "Move window ID to workspace FRAME-OR-INDEX." + (interactive (list + (cond + ((null current-prefix-arg) + (let ((exwm-workspace--prompt-add-allowed t) + (exwm-workspace--prompt-delete-allowed t)) + (exwm-workspace--prompt-for-workspace "Move to [+/-]: "))) + ((and (integerp current-prefix-arg) + (<= 0 current-prefix-arg (exwm-workspace--count))) + current-prefix-arg) + (t 0)))) + (let ((frame (exwm-workspace--workspace-from-frame-or-index frame-or-index)) + old-frame container) + (unless id (setq id (exwm--buffer->id (window-buffer)))) + (unless id + (cl-return-from exwm-workspace-move-window)) + (exwm--log "Moving #x%x to %s" id frame-or-index) + (with-current-buffer (exwm--id->buffer id) + (unless (eq exwm--frame frame) + (unless exwm-workspace-show-all-buffers + (let ((name (replace-regexp-in-string "^\\s-*" "" (buffer-name)))) + (exwm-workspace-rename-buffer + (if (eq frame exwm-workspace--current) + name + (concat " " name))))) + (setq old-frame exwm--frame + exwm--frame frame) + (if (not exwm--floating-frame) + ;; Tiling. + (if (get-buffer-window nil frame) + (when (eq frame exwm-workspace--current) + (exwm-layout--refresh frame)) + (set-window-buffer (get-buffer-window nil t) + (other-buffer nil t)) + (unless (eq frame exwm-workspace--current) + ;; Clear the 'exwm-selected-window' frame parameter. + (set-frame-parameter frame 'exwm-selected-window nil)) + (set-window-buffer (frame-selected-window frame) + (exwm--id->buffer id)) + (if (eq frame exwm-workspace--current) + (select-window (frame-selected-window frame)) + (unless (exwm-workspace--active-p frame) + (exwm-layout--hide id)))) + ;; Floating. + (setq container (frame-parameter exwm--floating-frame + 'exwm-container)) + (unless (equal (frame-parameter old-frame 'exwm-randr-monitor) + (frame-parameter frame 'exwm-randr-monitor)) + (with-slots (x y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container)) + (with-slots ((x1 x) + (y1 y)) + (exwm-workspace--get-geometry old-frame) + (with-slots ((x2 x) + (y2 y)) + (exwm-workspace--get-geometry frame) + (setq x (+ x (- x2 x1)) + y (+ y (- y2 y1))))) + (exwm--set-geometry id x y nil nil) + (exwm--set-geometry container x y nil nil))) + (if (exwm-workspace--minibuffer-own-frame-p) + (if (eq frame exwm-workspace--current) + (select-window (frame-root-window exwm--floating-frame)) + (select-window (frame-selected-window exwm-workspace--current)) + (unless (exwm-workspace--active-p frame) + (exwm-layout--hide id))) + ;; The frame needs to be recreated since it won't use the + ;; minibuffer on the new workspace. + ;; The code is mostly copied from `exwm-floating--set-floating'. + (let* ((old-frame exwm--floating-frame) + (new-frame + (with-current-buffer + (or (get-buffer "*scratch*") + (progn + (set-buffer-major-mode + (get-buffer-create "*scratch*")) + (get-buffer "*scratch*"))) + (make-frame + `((minibuffer . ,(minibuffer-window frame)) + (left . ,(* window-min-width -100)) + (top . ,(* window-min-height -100)) + (width . ,window-min-width) + (height . ,window-min-height) + (unsplittable . t))))) + (outer-id (string-to-number + (frame-parameter new-frame + 'outer-window-id))) + (window-id (string-to-number + (frame-parameter new-frame 'window-id))) + (window (frame-root-window new-frame))) + (set-frame-parameter new-frame 'exwm-outer-id outer-id) + (set-frame-parameter new-frame 'exwm-id window-id) + (set-frame-parameter new-frame 'exwm-container container) + (make-frame-invisible new-frame) + (set-frame-size new-frame + (frame-pixel-width old-frame) + (frame-pixel-height old-frame) + t) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id + :parent container + :x 0 :y 0)) + (xcb:flush exwm--connection) + (with-current-buffer (exwm--id->buffer id) + (setq window-size-fixed nil + exwm--floating-frame new-frame) + (set-window-dedicated-p (frame-root-window old-frame) nil) + (remove-hook 'window-configuration-change-hook + #'exwm-layout--refresh) + (set-window-buffer window (current-buffer)) + (add-hook 'window-configuration-change-hook + #'exwm-layout--refresh) + (set-window-dedicated-p window t)) + ;; Select a tiling window and delete the old frame. + (select-window (frame-selected-window exwm-workspace--current)) + (delete-frame old-frame) + ;; The rest is the same. + (make-frame-visible new-frame) + (exwm--set-geometry outer-id 0 0 nil nil) + (xcb:flush exwm--connection) + (redisplay) + (if (eq frame exwm-workspace--current) + (with-current-buffer (exwm--id->buffer id) + (select-window (frame-root-window exwm--floating-frame))) + (unless (exwm-workspace--active-p frame) + (exwm-layout--hide id))))) + ;; Update the 'exwm-selected-window' frame parameter. + (when (not (eq frame exwm-workspace--current)) + (with-current-buffer (exwm--id->buffer id) + (set-frame-parameter frame 'exwm-selected-window + (frame-root-window + exwm--floating-frame))))) + ;; Set _NET_WM_DESKTOP. + (exwm-workspace--set-desktop id) + (xcb:flush exwm--connection))) + (setq exwm-workspace--switch-history-outdated t))) + +;;;###autoload +(defun exwm-workspace-switch-to-buffer (buffer-or-name) + "Make the current Emacs window display another buffer." + (interactive + (let ((inhibit-quit t)) + ;; Show all buffers + (unless exwm-workspace-show-all-buffers + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when (= ?\s (aref (buffer-name) 0)) + (let ((buffer-list-update-hook + (remq #'exwm-input--on-buffer-list-update + buffer-list-update-hook))) + (rename-buffer (substring (buffer-name) 1))))))) + (prog1 + (with-local-quit + (list (get-buffer (read-buffer-to-switch "Switch to buffer: ")))) + ;; Hide buffers on other workspaces + (unless exwm-workspace-show-all-buffers + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (unless (or (eq exwm--frame exwm-workspace--current) + (= ?\s (aref (buffer-name) 0))) + (let ((buffer-list-update-hook + (remq #'exwm-input--on-buffer-list-update + buffer-list-update-hook))) + (rename-buffer (concat " " (buffer-name))))))))))) + (exwm--log) + (when buffer-or-name + (with-current-buffer buffer-or-name + (if (derived-mode-p 'exwm-mode) + ;; EXWM buffer. + (if (eq exwm--frame exwm-workspace--current) + ;; On the current workspace. + (if (not exwm--floating-frame) + (switch-to-buffer buffer-or-name) + ;; Select the floating frame. + (select-frame-set-input-focus exwm--floating-frame) + (select-window (frame-root-window exwm--floating-frame))) + ;; On another workspace. + (if exwm-layout-show-all-buffers + (exwm-workspace-move-window exwm-workspace--current + exwm--id) + (let ((window (get-buffer-window buffer-or-name exwm--frame))) + (if window + (set-frame-parameter exwm--frame + 'exwm-selected-window window) + (set-window-buffer (frame-selected-window exwm--frame) + buffer-or-name))) + (exwm-workspace-switch exwm--frame))) + ;; Ordinary buffer. + (switch-to-buffer buffer-or-name))))) + +(defun exwm-workspace-rename-buffer (newname) + "Rename a buffer." + (let ((hidden (= ?\s (aref newname 0))) + (basename (replace-regexp-in-string "<[0-9]+>$" "" newname)) + (counter 1) + tmp) + (when hidden (setq basename (substring basename 1))) + (setq newname basename) + (while (and (setq tmp (or (get-buffer newname) + (get-buffer (concat " " newname)))) + (not (eq tmp (current-buffer)))) + (setq newname (format "%s<%d>" basename (cl-incf counter)))) + (let ((buffer-list-update-hook + (remq #'exwm-input--on-buffer-list-update + buffer-list-update-hook))) + (rename-buffer (concat (and hidden " ") newname))))) + +(defun exwm-workspace--x-create-frame (orig-fun params) + "Set override-redirect on the frame created by `x-create-frame'." + (exwm--log) + (let ((frame (funcall orig-fun params))) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window (string-to-number + (frame-parameter frame 'outer-window-id)) + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + (xcb:flush exwm--connection) + frame)) + +(defsubst exwm-workspace--minibuffer-attached-p () + "Return non-nil if the minibuffer is attached. + +Please check `exwm-workspace--minibuffer-own-frame-p' first." + (assq (frame-parameter exwm-workspace--minibuffer 'exwm-container) + exwm-workspace--id-struts-alist)) + +;;;###autoload +(defun exwm-workspace-attach-minibuffer () + "Attach the minibuffer so that it always shows." + (interactive) + (exwm--log) + (when (and (exwm-workspace--minibuffer-own-frame-p) + (not (exwm-workspace--minibuffer-attached-p))) + ;; Reset the frame size. + (set-frame-height exwm-workspace--minibuffer 1) + (redisplay) ;FIXME. + (setq exwm-workspace--attached-minibuffer-height + (frame-pixel-height exwm-workspace--minibuffer)) + (exwm-workspace--show-minibuffer) + (let ((container (frame-parameter exwm-workspace--minibuffer + 'exwm-container))) + (push (cons container + (if (eq exwm-workspace-minibuffer-position 'top) + (vector 0 0 exwm-workspace--attached-minibuffer-height 0) + (vector 0 0 0 exwm-workspace--attached-minibuffer-height))) + exwm-workspace--id-struts-alist) + (exwm-workspace--update-struts) + (exwm-workspace--update-workareas) + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f))))) + +;;;###autoload +(defun exwm-workspace-detach-minibuffer () + "Detach the minibuffer so that it automatically hides." + (interactive) + (exwm--log) + (when (and (exwm-workspace--minibuffer-own-frame-p) + (exwm-workspace--minibuffer-attached-p)) + (setq exwm-workspace--attached-minibuffer-height 0) + (let ((container (frame-parameter exwm-workspace--minibuffer + 'exwm-container))) + (setq exwm-workspace--id-struts-alist + (assq-delete-all container exwm-workspace--id-struts-alist)) + (exwm-workspace--update-struts) + (exwm-workspace--update-workareas) + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f)) + (exwm-workspace--hide-minibuffer)))) + +;;;###autoload +(defun exwm-workspace-toggle-minibuffer () + "Attach the minibuffer if it's detached, or detach it if it's attached." + (interactive) + (exwm--log) + (when (exwm-workspace--minibuffer-own-frame-p) + (if (exwm-workspace--minibuffer-attached-p) + (exwm-workspace-detach-minibuffer) + (exwm-workspace-attach-minibuffer)))) + +(defun exwm-workspace--update-minibuffer-height (&optional echo-area) + "Update the minibuffer frame height." + (unless (exwm-workspace--client-p) + (let ((height + (with-current-buffer + (window-buffer (minibuffer-window exwm-workspace--minibuffer)) + (max 1 + (if echo-area + (let ((width (frame-width exwm-workspace--minibuffer)) + (result 0)) + (mapc (lambda (i) + (setq result + (+ result + (ceiling (1+ (length i)) width)))) + (split-string (or (current-message) "") "\n")) + result) + (count-screen-lines)))))) + (when (and (integerp max-mini-window-height) + (> height max-mini-window-height)) + (setq height max-mini-window-height)) + (exwm--log "%s" height) + (set-frame-height exwm-workspace--minibuffer height)))) + +(defun exwm-workspace--on-ConfigureNotify (data _synthetic) + "Adjust the container to fit the minibuffer frame." + (let ((obj (make-instance 'xcb:ConfigureNotify)) + workarea y) + (xcb:unmarshal obj data) + (with-slots (window height) obj + (when (eq (frame-parameter exwm-workspace--minibuffer 'exwm-outer-id) + window) + (exwm--log) + (when (and (floatp max-mini-window-height) + (> height (* max-mini-window-height + (exwm-workspace--current-height)))) + (setq height (floor + (* max-mini-window-height + (exwm-workspace--current-height)))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask xcb:ConfigWindow:Height + :height height))) + (when (/= (exwm-workspace--count) (length exwm-workspace--workareas)) + ;; There is a chance the workareas are not updated timely. + (exwm-workspace--update-workareas)) + (setq workarea (elt exwm-workspace--workareas + exwm-workspace-current-index) + y (if (eq exwm-workspace-minibuffer-position 'top) + (- (aref workarea 1) + exwm-workspace--attached-minibuffer-height) + (+ (aref workarea 1) (aref workarea 3) (- height) + exwm-workspace--attached-minibuffer-height))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + :value-mask (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Height) + :y y + :height height)) + (xcb:flush exwm--connection))))) + +(defun exwm-workspace--display-buffer (buffer alist) + "Display BUFFER as if the current workspace is selected." + ;; Only when the floating minibuffer frame is selected. + ;; This also protect this functions from being recursively called. + (when (eq (selected-frame) exwm-workspace--minibuffer) + (with-selected-frame exwm-workspace--current + (display-buffer buffer alist)))) + +(defun exwm-workspace--show-minibuffer () + "Show the minibuffer frame." + (exwm--log) + ;; Cancel pending timer. + (when exwm-workspace--display-echo-area-timer + (cancel-timer exwm-workspace--display-echo-area-timer) + (setq exwm-workspace--display-echo-area-timer nil)) + ;; Show the minibuffer frame. + (unless (exwm-workspace--minibuffer-attached-p) + (exwm--set-geometry (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + nil nil + (frame-pixel-width exwm-workspace--minibuffer) + (frame-pixel-height exwm-workspace--minibuffer))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:Above)) + (xcb:flush exwm--connection)) + +(defun exwm-workspace--hide-minibuffer () + "Hide the minibuffer frame." + (exwm--log) + ;; Hide the minibuffer frame. + (if (exwm-workspace--minibuffer-attached-p) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + :value-mask (logior (if exwm-manage--desktop + xcb:ConfigWindow:Sibling + 0) + xcb:ConfigWindow:StackMode) + :sibling exwm-manage--desktop + :stack-mode (if exwm-manage--desktop + xcb:StackMode:Above + xcb:StackMode:Below))) + (exwm--set-geometry (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + nil nil 1 1)) + (xcb:flush exwm--connection)) + +(defun exwm-workspace--on-minibuffer-setup () + "Run in minibuffer-setup-hook to show the minibuffer and its container." + (exwm--log) + (when (and (= 1 (minibuffer-depth)) + (not (exwm-workspace--client-p))) + (add-hook 'post-command-hook #'exwm-workspace--update-minibuffer-height) + (exwm-workspace--show-minibuffer)) + ;; FIXME: This is a temporary fix for the *Completions* buffer not + ;; being correctly fitted by its displaying window. As with + ;; `exwm-workspace--display-buffer', the problem is caused by + ;; the fact that the minibuffer (rather than the workspace) + ;; frame is the 'selected frame'. `get-buffer-window' will + ;; fail to retrieve the correct window. It's likely there are + ;; other related issues. + ;; This is not required by Emacs 24. + (when (fboundp 'window-preserve-size) + (let ((window (get-buffer-window "*Completions*" + exwm-workspace--current))) + (when window + (fit-window-to-buffer window) + (window-preserve-size window))))) + +(defun exwm-workspace--on-minibuffer-exit () + "Run in minibuffer-exit-hook to hide the minibuffer container." + (exwm--log) + (when (and (= 1 (minibuffer-depth)) + (not (exwm-workspace--client-p))) + (remove-hook 'post-command-hook #'exwm-workspace--update-minibuffer-height) + (exwm-workspace--hide-minibuffer))) + +(defun exwm-workspace--on-echo-area-dirty () + "Run when new message arrives to show the echo area and its container." + (when (and (not (active-minibuffer-window)) + (not (exwm-workspace--client-p)) + (or (current-message) + cursor-in-echo-area)) + (exwm-workspace--update-minibuffer-height t) + (exwm-workspace--show-minibuffer) + (unless (or (not exwm-workspace-display-echo-area-timeout) + exwm-input--during-command ;e.g. read-event + input-method-use-echo-area) + (setq exwm-workspace--display-echo-area-timer + (run-with-timer exwm-workspace-display-echo-area-timeout nil + #'exwm-workspace--echo-area-maybe-clear))))) + +(defun exwm-workspace--echo-area-maybe-clear () + "Eventually clear the echo area container." + (exwm--log) + (if (not (current-message)) + (exwm-workspace--on-echo-area-clear) + ;; Reschedule. + (cancel-timer exwm-workspace--display-echo-area-timer) + (setq exwm-workspace--display-echo-area-timer + (run-with-timer exwm-workspace-display-echo-area-timeout nil + #'exwm-workspace--echo-area-maybe-clear)))) + +(defun exwm-workspace--on-echo-area-clear () + "Run in echo-area-clear-hook to hide echo area container." + (unless (exwm-workspace--client-p) + (unless (active-minibuffer-window) + (exwm-workspace--hide-minibuffer)) + (when exwm-workspace--display-echo-area-timer + (cancel-timer exwm-workspace--display-echo-area-timer) + (setq exwm-workspace--display-echo-area-timer nil)))) + +(defun exwm-workspace--set-desktop-geometry () + "Set _NET_DESKTOP_GEOMETRY." + (exwm--log) + ;; We don't support large desktop so it's the same with screen size. + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_DESKTOP_GEOMETRY + :window exwm--root + :width (x-display-pixel-width) + :height (x-display-pixel-height)))) + +(defun exwm-workspace--add-frame-as-workspace (frame) + "Configure frame FRAME to be treated as a workspace." + (exwm--log "%s" frame) + (setq exwm-workspace--list (nconc exwm-workspace--list (list frame))) + (let ((outer-id (string-to-number (frame-parameter frame + 'outer-window-id))) + (window-id (string-to-number (frame-parameter frame 'window-id))) + (container (xcb:generate-id exwm--connection))) + ;; Save window IDs + (set-frame-parameter frame 'exwm-outer-id outer-id) + (set-frame-parameter frame 'exwm-id window-id) + (set-frame-parameter frame 'exwm-container container) + ;; In case it's created by emacsclient. + (set-frame-parameter frame 'client nil) + ;; Copy RandR frame parameters from the first workspace to + ;; prevent potential problems. The values do not matter here as + ;; they'll be updated by the RandR module later. + (let ((w (car exwm-workspace--list))) + (dolist (param '(exwm-randr-monitor + exwm-geometry)) + (set-frame-parameter frame param (frame-parameter w param)))) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid container + :parent exwm--root + :x -1 + :y -1 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask (logior xcb:CW:BackPixmap + xcb:CW:OverrideRedirect) + :background-pixmap xcb:BackPixmap:ParentRelative + :override-redirect 1)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:Below)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window container + :data + (format "EXWM workspace %d frame container" + (exwm-workspace--position frame)))) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id :parent container :x 0 :y 0)) + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window container))) + (xcb:flush exwm--connection) + ;; Delay making the workspace fullscreen until Emacs becomes idle + (exwm--defer 0 #'set-frame-parameter frame 'fullscreen 'fullboth) + ;; Update EWMH properties. + (exwm-workspace--update-ewmh-props) + (if exwm-workspace--create-silently + (setq exwm-workspace--switch-history-outdated t) + (let ((original-index exwm-workspace-current-index)) + (exwm-workspace-switch frame t) + (message "Created %s as workspace %d; switched from %d" + frame exwm-workspace-current-index original-index)) + (run-hooks 'exwm-workspace-list-change-hook))) + +(defun exwm-workspace--get-remove-frame-next-workspace (frame) + "Return the next workspace if workspace FRAME is removed. + +All X windows currently on workspace FRAME will be automatically moved to +the next workspace." + (let* ((index (exwm-workspace--position frame)) + (lastp (= index (1- (exwm-workspace--count)))) + (nextw (elt exwm-workspace--list (+ index (if lastp -1 +1))))) + ;; Clients need to be moved to some other workspace before this being + ;; removed. + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when (eq exwm--frame frame) + (exwm-workspace-move-window nextw exwm--id)))) + nextw)) + +(defun exwm-workspace--remove-frame-as-workspace (frame) + "Stop treating frame FRAME as a workspace." + ;; TODO: restore all frame parameters (e.g. exwm-workspace, buffer-predicate, + ;; etc) + (exwm--log "Removing frame `%s' as workspace" frame) + (let* ((index (exwm-workspace--position frame)) + (nextw (exwm-workspace--get-remove-frame-next-workspace frame))) + ;; Need to remove the workspace from the list in order for + ;; the correct calculation of indexes. + (setq exwm-workspace--list (delete frame exwm-workspace--list)) + ;; Update the _NET_WM_DESKTOP property of each X window affected. + (dolist (pair exwm--id-buffer-alist) + (when (<= (1- index) + (exwm-workspace--position (buffer-local-value 'exwm--frame + (cdr pair)))) + (exwm-workspace--set-desktop (car pair)))) + ;; If the current workspace is deleted, switch to next one. + (when (eq frame exwm-workspace--current) + (exwm-workspace-switch nextw))) + ;; Reparent out the frame. + (let ((outer-id (frame-parameter frame 'exwm-outer-id))) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow + :window outer-id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id + :parent exwm--root + :x 0 + :y 0)) + ;; Reset the override-redirect. + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window outer-id + :value-mask xcb:CW:OverrideRedirect + :override-redirect 0)) + ;; Remove fullscreen state. + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_STATE + :window outer-id + :data nil)) + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow + :window outer-id))) + ;; Destroy the container. + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow + :window (frame-parameter frame 'exwm-container))) + (xcb:flush exwm--connection) + ;; Update EWMH properties. + (exwm-workspace--update-ewmh-props) + ;; Update switch history. + (setq exwm-workspace--switch-history-outdated t) + (run-hooks 'exwm-workspace-list-change-hook)) + +(defun exwm-workspace--on-delete-frame (frame) + "Hook run upon `delete-frame' that tears down FRAME's configuration as a workspace." + (cond + ((not (exwm-workspace--workspace-p frame)) + (exwm--log "Frame `%s' is not a workspace" frame)) + (t + (when (= 1 (exwm-workspace--count)) + ;; The user managed to delete the last workspace, so create a new one. + (exwm--log "Last workspace deleted; create a new one") + ;; TODO: this makes sense in the hook. But we need a function that takes + ;; care of converting a workspace into a regular unmanaged frame. + (let ((exwm-workspace--create-silently t)) + (make-frame))) + (exwm-workspace--remove-frame-as-workspace frame)))) + +(defun exwm-workspace--on-after-make-frame (frame) + "Hook run upon `make-frame' that configures FRAME as a workspace." + (cond + ((exwm-workspace--workspace-p frame) + (exwm--log "Frame `%s' is already a workspace" frame)) + ((not (display-graphic-p frame)) + (exwm--log "Frame `%s' is not graphical" frame)) + ((not (string-equal + (replace-regexp-in-string "\\.0$" "" + (slot-value exwm--connection 'display)) + (replace-regexp-in-string "\\.0$" "" + (frame-parameter frame 'display)))) + (exwm--log "Frame `%s' is on a different DISPLAY (%S instead of %S)" + frame + (frame-parameter frame 'display) + (slot-value exwm--connection 'display))) + ((frame-parameter frame 'unsplittable) + ;; We create floating frames with the "unsplittable" parameter set. + ;; Though it may not be a floating frame, we won't treat an + ;; unsplittable frame as a workspace anyway. + (exwm--log "Frame `%s' is floating" frame)) + (t + (exwm--log "Adding frame `%s' as workspace" frame) + (exwm-workspace--add-frame-as-workspace frame)))) + +(defun exwm-workspace--update-ewmh-props () + "Update EWMH properties to match the workspace list." + (exwm--log) + (let ((num-workspaces (exwm-workspace--count))) + ;; Avoid setting 0 desktops. + (when (= 0 num-workspaces) + (setq num-workspaces 1)) + ;; Set _NET_NUMBER_OF_DESKTOPS. + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_NUMBER_OF_DESKTOPS + :window exwm--root :data num-workspaces)) + ;; Set _NET_DESKTOP_GEOMETRY. + (exwm-workspace--set-desktop-geometry) + ;; Update workareas. + (exwm-workspace--update-workareas)) + (xcb:flush exwm--connection)) + +(defun exwm-workspace--modify-all-x-frames-parameters (new-x-parameters) + "Modifies `window-system-default-frame-alist' for the X Window System. +NEW-X-PARAMETERS is an alist of frame parameters, merged into current +`window-system-default-frame-alist' for the X Window System. The parameters are +applied to all subsequently created X frames." + (exwm--log) + ;; The parameters are modified in place; take current + ;; ones or insert a new X-specific list. + (let ((x-parameters (or (assq 'x window-system-default-frame-alist) + (let ((new-x-parameters '(x))) + (push new-x-parameters + window-system-default-frame-alist) + new-x-parameters)))) + (setf (cdr x-parameters) + (append new-x-parameters (cdr x-parameters))))) + +(defun exwm-workspace--handle-focus-in (_orig-func _event) + "Replacement for `handle-focus-in'." + (interactive "e")) + +(defun exwm-workspace--handle-focus-out (_orig-func _event) + "Replacement for `handle-focus-out'." + (interactive "e")) + +(defun exwm-workspace--init-minibuffer-frame () + (exwm--log) + ;; Initialize workspaces without minibuffers. + (setq exwm-workspace--minibuffer + (make-frame '((window-system . x) (minibuffer . only) + (left . 10000) (right . 10000) + (width . 1) (height . 1) + (client . nil)))) + ;; This is the only usable minibuffer frame. + (setq default-minibuffer-frame exwm-workspace--minibuffer) + (exwm-workspace--modify-all-x-frames-parameters + '((minibuffer . nil))) + (let ((outer-id (string-to-number + (frame-parameter exwm-workspace--minibuffer + 'outer-window-id))) + (window-id (string-to-number + (frame-parameter exwm-workspace--minibuffer + 'window-id))) + (container (xcb:generate-id exwm--connection))) + (set-frame-parameter exwm-workspace--minibuffer + 'exwm-outer-id outer-id) + (set-frame-parameter exwm-workspace--minibuffer 'exwm-id window-id) + (set-frame-parameter exwm-workspace--minibuffer 'exwm-container + container) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid container + :parent exwm--root + :x 0 + :y 0 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask (logior xcb:CW:BackPixmap + xcb:CW:OverrideRedirect) + :background-pixmap xcb:BackPixmap:ParentRelative + :override-redirect 1)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window container + :data "EXWM minibuffer container")) + ;; Reparent the minibuffer frame to the container. + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id :parent container :x 0 :y 0)) + ;; Map the container. + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow + :window container)) + ;; Attach event listener for monitoring the frame + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window outer-id + :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:StructureNotify)) + (xcb:+event exwm--connection 'xcb:ConfigureNotify + #'exwm-workspace--on-ConfigureNotify)) + ;; Show/hide minibuffer / echo area when they're active/inactive. + (add-hook 'minibuffer-setup-hook #'exwm-workspace--on-minibuffer-setup) + (add-hook 'minibuffer-exit-hook #'exwm-workspace--on-minibuffer-exit) + (setq exwm-workspace--timer + (run-with-idle-timer 0 t #'exwm-workspace--on-echo-area-dirty)) + (add-hook 'echo-area-clear-hook #'exwm-workspace--on-echo-area-clear) + ;; The default behavior of `display-buffer' (indirectly called by + ;; `minibuffer-completion-help') is not correct here. + (cl-pushnew '(exwm-workspace--display-buffer) display-buffer-alist + :test #'equal)) + +(defun exwm-workspace--exit-minibuffer-frame () + (exwm--log) + ;; Only on minibuffer-frame. + (remove-hook 'minibuffer-setup-hook #'exwm-workspace--on-minibuffer-setup) + (remove-hook 'minibuffer-exit-hook #'exwm-workspace--on-minibuffer-exit) + (remove-hook 'echo-area-clear-hook #'exwm-workspace--on-echo-area-clear) + (when exwm-workspace--timer + (cancel-timer exwm-workspace--timer) + (setq exwm-workspace--timer nil)) + (setq display-buffer-alist + (cl-delete '(exwm-workspace--display-buffer) display-buffer-alist + :test #'equal)) + (setq default-minibuffer-frame nil) + (let ((id (frame-parameter exwm-workspace--minibuffer 'exwm-outer-id))) + (when (and exwm-workspace--minibuffer id) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window id + :parent exwm--root + :x 0 + :y 0))) + (setq exwm-workspace--minibuffer nil))) + +(defun exwm-workspace--init () + "Initialize workspace module." + (exwm--log) + (exwm-workspace--init-switch-map) + ;; Prevent unexpected exit + (setq exwm-workspace--fullscreen-frame-count 0) + (exwm-workspace--modify-all-x-frames-parameters + '((internal-border-width . 0))) + (let ((initial-workspaces (frame-list))) + (if (not (exwm-workspace--minibuffer-own-frame-p)) + ;; Initialize workspaces with minibuffers. + (when (< 1 (length initial-workspaces)) + ;; Exclude the initial frame. + (dolist (i initial-workspaces) + (unless (frame-parameter i 'window-id) + (setq initial-workspaces (delq i initial-workspaces)))) + (setq exwm-workspace--client + (frame-parameter (car initial-workspaces) 'client)) + (let ((f (car initial-workspaces))) + ;; Remove the possible internal border. + (set-frame-parameter f 'internal-border-width 0) + ;; Prevent user from deleting the first frame by accident. + (set-frame-parameter f 'client nil))) + (exwm-workspace--init-minibuffer-frame) + ;; Remove/hide existing frames. + (dolist (f initial-workspaces) + (if (frame-parameter f 'client) + (progn + (unless exwm-workspace--client + (setq exwm-workspace--client (frame-parameter f 'client))) + (make-frame-invisible f)) + (when (eq 'x (framep f)) ;do not delete the initial frame. + (delete-frame f)))) + ;; Recreate one frame with the external minibuffer set. + (setq initial-workspaces (list (make-frame '((window-system . x) + (client . nil)))))) + ;; Prevent `other-buffer' from selecting already displayed EXWM buffers. + (modify-all-frames-parameters + '((buffer-predicate . exwm-layout--other-buffer-predicate))) + ;; Create remaining workspaces. + (dotimes (_ (- exwm-workspace-number (length initial-workspaces))) + (nconc initial-workspaces (list (make-frame '((window-system . x) + (client . nil)))))) + ;; Configure workspaces + (let ((exwm-workspace--create-silently t)) + (dolist (i initial-workspaces) + (exwm-workspace--add-frame-as-workspace i)))) + (xcb:flush exwm--connection) + ;; We have to advice `x-create-frame' or every call to it would hang EXWM + (advice-add 'x-create-frame :around #'exwm-workspace--x-create-frame) + ;; We have to manually handle focus-in and focus-out events for Emacs + ;; frames. + (advice-add 'handle-focus-in :around #'exwm-workspace--handle-focus-in) + (advice-add 'handle-focus-out :around #'exwm-workspace--handle-focus-out) + ;; Make new frames create new workspaces. + (add-hook 'after-make-frame-functions + #'exwm-workspace--on-after-make-frame) + (add-hook 'delete-frame-functions #'exwm-workspace--on-delete-frame) + (when (exwm-workspace--minibuffer-own-frame-p) + (add-hook 'exwm-input--event-hook + #'exwm-workspace--on-echo-area-clear)) + ;; Switch to the first workspace + (exwm-workspace-switch 0 t) + ;; Prevent frame parameters introduced by this module from being + ;; saved/restored. + (dolist (i '(exwm-active exwm-outer-id exwm-id exwm-container exwm-geometry + exwm-selected-window exwm-urgency fullscreen)) + (unless (assq i frameset-filter-alist) + (push (cons i :never) frameset-filter-alist)))) + +(defun exwm-workspace--exit () + "Exit the workspace module." + (exwm--log) + (when (exwm-workspace--minibuffer-own-frame-p) + (exwm-workspace--exit-minibuffer-frame)) + (advice-remove 'x-create-frame #'exwm-workspace--x-create-frame) + (advice-remove 'handle-focus-in #'exwm-workspace--handle-focus-in) + (advice-remove 'handle-focus-out #'exwm-workspace--handle-focus-out) + (remove-hook 'after-make-frame-functions + #'exwm-workspace--on-after-make-frame) + (remove-hook 'delete-frame-functions + #'exwm-workspace--on-delete-frame) + (when (exwm-workspace--minibuffer-own-frame-p) + (remove-hook 'exwm-input--event-hook + #'exwm-workspace--on-echo-area-clear)) + ;; Hide & reparent out all frames (save-set can't be used here since + ;; X windows will be re-mapped). + (setq exwm-workspace--current nil) + (dolist (i exwm-workspace--list) + (exwm-workspace--remove-frame-as-workspace i) + (modify-frame-parameters i '((exwm-selected-window . nil) + (exwm-urgency . nil) + (exwm-outer-id . nil) + (exwm-id . nil) + (exwm-container . nil) + ;; (internal-border-width . nil) ; integerp + ;; (client . nil) + (fullscreen . nil) + (buffer-predicate . nil)))) + ;; Restore the 'client' frame parameter (before `exwm-exit'). + (when exwm-workspace--client + (dolist (f exwm-workspace--list) + (set-frame-parameter f 'client exwm-workspace--client)) + (when (exwm-workspace--minibuffer-own-frame-p) + (set-frame-parameter exwm-workspace--minibuffer 'client + exwm-workspace--client)) + (setq exwm-workspace--client nil))) + +(defun exwm-workspace--post-init () + "The second stage in the initialization of the workspace module." + (exwm--log) + (when exwm-workspace--client + ;; Reset the 'fullscreen' frame parameter to make emacsclinet frames + ;; fullscreen (even without the RandR module enabled). + (dolist (i exwm-workspace--list) + (set-frame-parameter i 'fullscreen nil) + (set-frame-parameter i 'fullscreen 'fullboth))) + ;; Wait until all workspace frames are resized. + (with-timeout (1) + (while (< exwm-workspace--fullscreen-frame-count (exwm-workspace--count)) + (accept-process-output nil 0.1))) + (setq exwm-workspace--fullscreen-frame-count nil)) + + + +(provide 'exwm-workspace) + +;;; exwm-workspace.el ends here diff --git a/third_party/emacs/exwm/exwm-xim.el b/third_party/emacs/exwm/exwm-xim.el new file mode 100644 index 000000000000..acf718e27fd3 --- /dev/null +++ b/third_party/emacs/exwm/exwm-xim.el @@ -0,0 +1,800 @@ +;;; exwm-xim.el --- XIM Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module adds XIM support for EXWM and allows sending characters +;; generated by any Emacs's builtin input method (info node `Input Methods') +;; to X windows. + +;; This module is essentially an X input method server utilizing Emacs as +;; its backend. It talks with X windows through the XIM protocol. The XIM +;; protocol is quite flexible by itself, stating that an implementation can +;; create network connections of various types as well as make use of an +;; existing X connection for communication, and that an IM server may +;; support multiple transport versions, various input styles and several +;; event flow modals, etc. Here we only make choices that are most popular +;; among other IM servers and more importantly, practical for Emacs to act +;; as an IM server: +;; +;; + Packets are transported on top of an X connection like most IMEs. +;; + Only transport version 0.0 (i.e. only-CM & Property-with-CM) is +;; supported (same as "IM Server Developers Kit", adopted by most IMEs). +;; + Only support static event flow, on-demand-synchronous method. +;; + Only "root-window" input style is supported. + +;; To use this module, first load and enable it as follows: +;; +;; (require 'exwm-xim) +;; (exwm-xim-enable) +;; +;; A keybinding for `toggle-input-method' is probably required to turn on & +;; off an input method (default to `default-input-method'). It's bound to +;; 'C-\' by default and can be made reachable when working with X windows: +;; +;; (push ?\C-\\ exwm-input-prefix-keys) +;; +;; It's also required (and error-prone) to setup environment variables to +;; make applications actually use this input method. Typically the +;; following lines should be inserted into '~/.xinitrc'. +;; +;; export XMODIFIERS=@im=exwm-xim +;; export GTK_IM_MODULE=xim +;; export QT_IM_MODULE=xim +;; export CLUTTER_IM_MODULE=xim + +;; References: +;; + XIM (http://www.x.org/releases/X11R7.6/doc/libX11/specs/XIM/xim.html) +;; + IMdkit (http://xorg.freedesktop.org/archive/unsupported/lib/IMdkit/) +;; + UIM (https://github.com/uim/uim) + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +(require 'xcb-keysyms) +(require 'xcb-xim) + +(require 'exwm-core) +(require 'exwm-input) + +(defconst exwm-xim--locales + "@locale=\ +aa,af,ak,am,an,anp,ar,as,ast,ayc,az,be,bem,ber,bg,bhb,bho,bn,bo,br,brx,bs,byn,\ +ca,ce,cmn,crh,cs,csb,cv,cy,da,de,doi,dv,dz,el,en,es,et,eu,fa,ff,fi,fil,fo,fr,\ +fur,fy,ga,gd,gez,gl,gu,gv,ha,hak,he,hi,hne,hr,hsb,ht,hu,hy,ia,id,ig,ik,is,it,\ +iu,iw,ja,ka,kk,kl,km,kn,ko,kok,ks,ku,kw,ky,lb,lg,li,li,lij,lo,lt,lv,lzh,mag,\ +mai,mg,mhr,mi,mk,ml,mn,mni,mr,ms,mt,my,nan,nb,nds,ne,nhn,niu,nl,nn,nr,nso,oc,\ +om,or,os,pa,pa,pap,pl,ps,pt,quz,raj,ro,ru,rw,sa,sat,sc,sd,se,shs,si,sid,sk,sl,\ +so,sq,sr,ss,st,sv,sw,szl,ta,tcy,te,tg,th,the,ti,tig,tk,tl,tn,tr,ts,tt,ug,uk,\ +unm,ur,uz,ve,vi,wa,wae,wal,wo,xh,yi,yo,yue,zh,zu,\ +C,no" + "All supported locales (stolen from glibc).") + +(defconst exwm-xim--default-error + (make-instance 'xim:error + :im-id 0 + :ic-id 0 + :flag xim:error-flag:invalid-both + :error-code xim:error-code:bad-something + :length 0 + :type 0 + :detail nil) + "Default error returned to clients.") + +(defconst exwm-xim--default-im-attrs + (list (make-instance 'xim:XIMATTR + :id 0 + :type xim:ATTRIBUTE-VALUE-TYPE:xim-styles + :length (length xlib:XNQueryInputStyle) + :attribute xlib:XNQueryInputStyle)) + "Default IM attrs returned to clients.") + +(defconst exwm-xim--default-ic-attrs + (list (make-instance 'xim:XICATTR + :id 0 + :type xim:ATTRIBUTE-VALUE-TYPE:long-data + :length (length xlib:XNInputStyle) + :attribute xlib:XNInputStyle) + (make-instance 'xim:XICATTR + :id 1 + :type xim:ATTRIBUTE-VALUE-TYPE:window + :length (length xlib:XNClientWindow) + :attribute xlib:XNClientWindow) + ;; Required by e.g. xterm. + (make-instance 'xim:XICATTR + :id 2 + :type xim:ATTRIBUTE-VALUE-TYPE:window + :length (length xlib:XNFocusWindow) + :attribute xlib:XNFocusWindow)) + "Default IC attrs returned to clients.") + +(defconst exwm-xim--default-styles + (make-instance 'xim:XIMStyles + :number nil + :styles (list (logior xlib:XIMPreeditNothing + xlib:XIMStatusNothing))) + "Default styles: root-window, i.e. no preediting or status display support.") + +(defconst exwm-xim--default-attributes + (list (make-instance 'xim:XIMATTRIBUTE + :id 0 + :length nil + :value exwm-xim--default-styles)) + "Default IM/IC attributes returned to clients.") + +(defvar exwm-xim--conn nil + "The X connection for initiating other XIM connections.") +(defvar exwm-xim--event-xwin nil + "X window for initiating new XIM connections.") +(defvar exwm-xim--server-client-plist '(nil nil) + "Plist mapping server window to [X connection, client window, byte-order].") +(defvar exwm-xim--client-server-plist '(nil nil) + "Plist mapping client window to server window.") +(defvar exwm-xim--property-index 0 "For generating a unique property name.") +(defvar exwm-xim--im-id 0 "Last IM ID.") +(defvar exwm-xim--ic-id 0 "Last IC ID.") + +;; X11 atoms. +(defvar exwm-xim--@server nil) +(defvar exwm-xim--LOCALES nil) +(defvar exwm-xim--TRANSPORT nil) +(defvar exwm-xim--XIM_SERVERS nil) +(defvar exwm-xim--_XIM_PROTOCOL nil) +(defvar exwm-xim--_XIM_XCONNECT nil) + +(defun exwm-xim--on-SelectionRequest (data _synthetic) + "Handle SelectionRequest events on IMS window. + +Such events would be received when clients query for LOCALES or TRANSPORT." + (exwm--log) + (let ((evt (make-instance 'xcb:SelectionRequest)) + value fake-event) + (xcb:unmarshal evt data) + (with-slots (time requestor selection target property) evt + (setq value (cond ((= target exwm-xim--LOCALES) + ;; Return supported locales. + exwm-xim--locales) + ((= target exwm-xim--TRANSPORT) + ;; Use XIM over an X connection. + "@transport=X/"))) + (when value + ;; Change the property. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Replace + :window requestor + :property property + :type target + :format 8 + :data-len (length value) + :data value)) + ;; Send a SelectionNotify event. + (setq fake-event (make-instance 'xcb:SelectionNotify + :time time + :requestor requestor + :selection selection + :target target + :property property)) + (xcb:+request exwm-xim--conn + (make-instance 'xcb:SendEvent + :propagate 0 + :destination requestor + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal fake-event exwm-xim--conn))) + (xcb:flush exwm-xim--conn))))) + +(cl-defun exwm-xim--on-ClientMessage-0 (data _synthetic) + "Handle ClientMessage event on IMS window (new connection). + +Such events would be received when clients request for _XIM_XCONNECT. +A new X connection and server window would be created to communicate with +this client." + (exwm--log) + (let ((evt (make-instance 'xcb:ClientMessage)) + conn client-xwin server-xwin) + (xcb:unmarshal evt data) + (with-slots (window type data) evt + (unless (= type exwm-xim--_XIM_XCONNECT) + ;; Only handle _XIM_XCONNECT. + (exwm--log "Ignore ClientMessage %s" type) + (cl-return-from exwm-xim--on-ClientMessage-0)) + (setq client-xwin (elt (slot-value data 'data32) 0) + ;; Create a new X connection and a new server window. + conn (xcb:connect) + server-xwin (xcb:generate-id conn)) + (set-process-query-on-exit-flag (slot-value conn 'process) nil) + ;; Store this client. + (plist-put exwm-xim--server-client-plist server-xwin + `[,conn ,client-xwin nil]) + (plist-put exwm-xim--client-server-plist client-xwin server-xwin) + ;; Select DestroyNotify events on this client window. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:ChangeWindowAttributes + :window client-xwin + :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:StructureNotify)) + (xcb:flush exwm-xim--conn) + ;; Handle ClientMessage events from this new connection. + (xcb:+event conn 'xcb:ClientMessage #'exwm-xim--on-ClientMessage) + ;; Create a communication window. + (xcb:+request conn + (make-instance 'xcb:CreateWindow + :depth 0 + :wid server-xwin + :parent exwm--root + :x 0 + :y 0 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + (xcb:flush conn) + ;; Send connection establishment ClientMessage. + (setf window client-xwin + (slot-value data 'data32) `(,server-xwin 0 0 0 0)) + (slot-makeunbound data 'data8) + (slot-makeunbound data 'data16) + (xcb:+request exwm-xim--conn + (make-instance 'xcb:SendEvent + :propagate 0 + :destination client-xwin + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal evt exwm-xim--conn))) + (xcb:flush exwm-xim--conn)))) + +(cl-defun exwm-xim--on-ClientMessage (data _synthetic) + "Handle ClientMessage event on IMS communication window (request). + +Such events would be received when clients request for _XIM_PROTOCOL. +The actual XIM request is in client message data or a property." + (exwm--log) + (let ((evt (make-instance 'xcb:ClientMessage)) + conn client-xwin server-xwin) + (xcb:unmarshal evt data) + (with-slots (format window type data) evt + (unless (= type exwm-xim--_XIM_PROTOCOL) + (exwm--log "Ignore ClientMessage %s" type) + (cl-return-from exwm-xim--on-ClientMessage)) + (setq server-xwin window + conn (plist-get exwm-xim--server-client-plist server-xwin) + client-xwin (elt conn 1) + conn (elt conn 0)) + (cond ((= format 8) + ;; Data. + (exwm-xim--on-request (vconcat (slot-value data 'data8)) + conn client-xwin server-xwin)) + ((= format 32) + ;; Atom. + (with-slots (data32) data + (with-slots (value) + (xcb:+request-unchecked+reply conn + (make-instance 'xcb:GetProperty + :delete 1 + :window server-xwin + :property (elt data32 1) + :type xcb:GetPropertyType:Any + :long-offset 0 + :long-length (elt data32 0))) + (when (> (length value) 0) + (exwm-xim--on-request value conn client-xwin + server-xwin))))))))) + +(defun exwm-xim--on-request (data conn client-xwin server-xwin) + "Handle an XIM reuqest." + (exwm--log) + (let ((opcode (elt data 0)) + ;; Let-bind `xim:lsb' to make pack/unpack functions work correctly. + (xim:lsb (elt (plist-get exwm-xim--server-client-plist server-xwin) 2)) + req replies) + (cond ((= opcode xim:opcode:error) + (exwm--log "ERROR: %s" data)) + ((= opcode xim:opcode:connect) + (exwm--log "CONNECT") + (setq xim:lsb (= (elt data 4) xim:connect-byte-order:lsb-first)) + ;; Store byte-order. + (setf (elt (plist-get exwm-xim--server-client-plist server-xwin) 2) + xim:lsb) + (setq req (make-instance 'xim:connect)) + (xcb:unmarshal req data) + (if (and (= (slot-value req 'major-version) 1) + (= (slot-value req 'minor-version) 0) + ;; Do not support authentication. + (= (slot-value req 'number) 0)) + ;; Accept the connection. + (push (make-instance 'xim:connect-reply) replies) + ;; Deny it. + (push exwm-xim--default-error replies))) + ((memq opcode (list xim:opcode:auth-required + xim:opcode:auth-reply + xim:opcode:auth-next + xim:opcode:auth-ng)) + (exwm--log "AUTH: %d" opcode) + ;; Deny any attempt to make authentication. + (push exwm-xim--default-error replies)) + ((= opcode xim:opcode:disconnect) + (exwm--log "DISCONNECT") + ;; Gracefully disconnect from the client. + (exwm-xim--make-request (make-instance 'xim:disconnect-reply) + conn client-xwin) + ;; Destroy the communication window & connection. + (xcb:+request conn + (make-instance 'xcb:DestroyWindow + :window server-xwin)) + (xcb:disconnect conn) + ;; Clean up cache. + (cl-remf exwm-xim--server-client-plist server-xwin) + (cl-remf exwm-xim--client-server-plist client-xwin)) + ((= opcode xim:opcode:open) + (exwm--log "OPEN") + ;; Note: We make no check here. + (setq exwm-xim--im-id (if (< exwm-xim--im-id #xffff) + (1+ exwm-xim--im-id) + 1)) + (setq replies + (list + (make-instance 'xim:open-reply + :im-id exwm-xim--im-id + :im-attrs-length nil + :im-attrs exwm-xim--default-im-attrs + :ic-attrs-length nil + :ic-attrs exwm-xim--default-ic-attrs) + (make-instance 'xim:set-event-mask + :im-id exwm-xim--im-id + :ic-id 0 + ;; Static event flow. + :forward-event-mask xcb:EventMask:KeyPress + ;; on-demand-synchronous method. + :synchronous-event-mask + xcb:EventMask:NoEvent)))) + ((= opcode xim:opcode:close) + (exwm--log "CLOSE") + (setq req (make-instance 'xim:close)) + (xcb:unmarshal req data) + (push (make-instance 'xim:close-reply + :im-id (slot-value req 'im-id)) + replies)) + ((= opcode xim:opcode:trigger-notify) + (exwm--log "TRIGGER-NOTIFY") + ;; Only static event flow modal is supported. + (push exwm-xim--default-error replies)) + ((= opcode xim:opcode:encoding-negotiation) + (exwm--log "ENCODING-NEGOTIATION") + (setq req (make-instance 'xim:encoding-negotiation)) + (xcb:unmarshal req data) + (let ((index (cl-position "COMPOUND_TEXT" + (mapcar (lambda (i) (slot-value i 'name)) + (slot-value req 'names)) + :test #'equal))) + (unless index + ;; Fallback to portable character encoding (a subset of ASCII). + (setq index -1)) + (push (make-instance 'xim:encoding-negotiation-reply + :im-id (slot-value req 'im-id) + :category + xim:encoding-negotiation-reply-category:name + :index index) + replies))) + ((= opcode xim:opcode:query-extension) + (exwm--log "QUERY-EXTENSION") + (setq req (make-instance 'xim:query-extension)) + (xcb:unmarshal req data) + (push (make-instance 'xim:query-extension-reply + :im-id (slot-value req 'im-id) + ;; No extension support. + :length 0 + :extensions nil) + replies)) + ((= opcode xim:opcode:set-im-values) + (exwm--log "SET-IM-VALUES") + ;; There's only one possible input method attribute. + (setq req (make-instance 'xim:set-im-values)) + (xcb:unmarshal req data) + (push (make-instance 'xim:set-im-values-reply + :im-id (slot-value req 'im-id)) + replies)) + ((= opcode xim:opcode:get-im-values) + (exwm--log "GET-IM-VALUES") + (setq req (make-instance 'xim:get-im-values)) + (let (im-attributes-id) + (xcb:unmarshal req data) + (setq im-attributes-id (slot-value req 'im-attributes-id)) + (if (cl-notevery (lambda (i) (= i 0)) im-attributes-id) + ;; Only support one IM attributes. + (push (make-instance 'xim:error + :im-id (slot-value req 'im-id) + :ic-id 0 + :flag xim:error-flag:invalid-ic-id + :error-code xim:error-code:bad-something + :length 0 + :type 0 + :detail nil) + replies) + (push + (make-instance 'xim:get-im-values-reply + :im-id (slot-value req 'im-id) + :length nil + :im-attributes exwm-xim--default-attributes) + replies)))) + ((= opcode xim:opcode:create-ic) + (exwm--log "CREATE-IC") + (setq req (make-instance 'xim:create-ic)) + (xcb:unmarshal req data) + ;; Note: The ic-attributes slot is ignored. + (setq exwm-xim--ic-id (if (< exwm-xim--ic-id #xffff) + (1+ exwm-xim--ic-id) + 1)) + (push (make-instance 'xim:create-ic-reply + :im-id (slot-value req 'im-id) + :ic-id exwm-xim--ic-id) + replies)) + ((= opcode xim:opcode:destroy-ic) + (exwm--log "DESTROY-IC") + (setq req (make-instance 'xim:destroy-ic)) + (xcb:unmarshal req data) + (push (make-instance 'xim:destroy-ic-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id)) + replies)) + ((= opcode xim:opcode:set-ic-values) + (exwm--log "SET-IC-VALUES") + (setq req (make-instance 'xim:set-ic-values)) + (xcb:unmarshal req data) + ;; We don't distinguish between input contexts. + (push (make-instance 'xim:set-ic-values-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id)) + replies)) + ((= opcode xim:opcode:get-ic-values) + (exwm--log "GET-IC-VALUES") + (setq req (make-instance 'xim:get-ic-values)) + (xcb:unmarshal req data) + (push (make-instance 'xim:get-ic-values-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id) + :length nil + :ic-attributes exwm-xim--default-attributes) + replies)) + ((= opcode xim:opcode:set-ic-focus) + (exwm--log "SET-IC-FOCUS") + ;; All input contexts are the same. + ) + ((= opcode xim:opcode:unset-ic-focus) + (exwm--log "UNSET-IC-FOCUS") + ;; All input contexts are the same. + ) + ((= opcode xim:opcode:forward-event) + (exwm--log "FORWARD-EVENT") + (setq req (make-instance 'xim:forward-event)) + (xcb:unmarshal req data) + (exwm-xim--handle-forward-event-request req xim:lsb conn + client-xwin)) + ((= opcode xim:opcode:sync) + (exwm--log "SYNC") + (setq req (make-instance 'xim:sync)) + (xcb:unmarshal req data) + (push (make-instance 'xim:sync-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id)) + replies)) + ((= opcode xim:opcode:sync-reply) + (exwm--log "SYNC-REPLY")) + ((= opcode xim:opcode:reset-ic) + (exwm--log "RESET-IC") + ;; No context-specific data saved. + (setq req (make-instance 'xim:reset-ic)) + (xcb:unmarshal req data) + (push (make-instance 'xim:reset-ic-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id) + :length 0 + :string "") + replies)) + ((memq opcode (list xim:opcode:str-conversion-reply + xim:opcode:preedit-start-reply + xim:opcode:preedit-caret-reply)) + (exwm--log "PREEDIT: %d" opcode) + ;; No preedit support. + (push exwm-xim--default-error replies)) + (t + (exwm--log "Bad protocol") + (push exwm-xim--default-error replies))) + ;; Actually send the replies. + (when replies + (mapc (lambda (reply) + (exwm-xim--make-request reply conn client-xwin)) + replies) + (xcb:flush conn)))) + +(defun exwm-xim--handle-forward-event-request (req lsb conn client-xwin) + (let ((im-func (with-current-buffer (window-buffer) + input-method-function)) + key-event keysym keysyms event result) + ;; Note: The flag slot is ignored. + ;; Do conversion in client's byte-order. + (let ((xcb:lsb lsb)) + (setq key-event (make-instance 'xcb:KeyPress)) + (xcb:unmarshal key-event (slot-value req 'event))) + (with-slots (detail state) key-event + (setq keysym (xcb:keysyms:keycode->keysym exwm-xim--conn detail + state)) + (when (/= (car keysym) 0) + (setq event (xcb:keysyms:keysym->event + exwm-xim--conn + (car keysym) + (logand state (lognot (cdr keysym))))))) + (while (or (slot-value req 'event) unread-command-events) + (unless (slot-value req 'event) + (setq event (pop unread-command-events)) + ;; Handle events in (t . EVENT) format. + (when (and (consp event) + (eq (car event) t)) + (setq event (cdr event)))) + (if (or (not im-func) + ;; `list' is the default method. + (eq im-func #'list) + (not event) + ;; Select only printable keys. + (not (integerp event)) (> #x20 event) (< #x7e event)) + ;; Either there is no active input method, or invalid key + ;; is detected. + (with-slots ((raw-event event) + im-id ic-id serial-number) + req + (if raw-event + (setq event raw-event) + (setq keysyms (xcb:keysyms:event->keysyms exwm-xim--conn event)) + (with-slots (detail state) key-event + (setf detail (xcb:keysyms:keysym->keycode exwm-xim--conn + (caar keysyms)) + state (cdar keysyms))) + (setq event (let ((xcb:lsb lsb)) + (xcb:marshal key-event conn)))) + (when event + (exwm-xim--make-request + (make-instance 'xim:forward-event + :im-id im-id + :ic-id ic-id + :flag xim:commit-flag:synchronous + :serial-number serial-number + :event event) + conn client-xwin))) + (when (eq exwm--selected-input-mode 'char-mode) + ;; Grab keyboard temporarily for char-mode. + (exwm-input--grab-keyboard)) + (unwind-protect + (with-temp-buffer + ;; Always show key strokes. + (let ((input-method-use-echo-area t) + (exwm-input-line-mode-passthrough t)) + (setq result (funcall im-func event)) + ;; Clear echo area for the input method. + (message nil) + ;; This also works for portable character encoding. + (setq result + (encode-coding-string (concat result) + 'compound-text-with-extensions)) + (exwm-xim--make-request + (make-instance 'xim:commit-x-lookup-chars + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id) + :flag (logior xim:commit-flag:synchronous + xim:commit-flag:x-lookup-chars) + :length (length result) + :string result) + conn client-xwin))) + (when (eq exwm--selected-input-mode 'char-mode) + (exwm-input--release-keyboard)))) + (xcb:flush conn) + (setf event nil + (slot-value req 'event) nil)))) + +(defun exwm-xim--make-request (req conn client-xwin) + "Make an XIM request REQ via connection CONN. + +CLIENT-XWIN would receive a ClientMessage event either telling the client +the request data or where to fetch the data." + (exwm--log) + (let ((data (xcb:marshal req)) + property format client-message-data client-message) + (if (<= (length data) 20) + ;; Send short requests directly with client messages. + (setq format 8 + ;; Pad to 20 bytes. + data (append data (make-list (- 20 (length data)) 0)) + client-message-data (make-instance 'xcb:ClientMessageData + :data8 data)) + ;; Send long requests with properties. + (setq property (exwm--intern-atom (format "_EXWM_XIM_%x" + exwm-xim--property-index))) + (cl-incf exwm-xim--property-index) + (xcb:+request conn + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Append + :window client-xwin + :property property + :type xcb:Atom:STRING + :format 8 + :data-len (length data) + :data data)) + ;; Also send a client message to notify the client about this property. + (setq format 32 + client-message-data (make-instance 'xcb:ClientMessageData + :data32 `(,(length data) + ,property + ;; Pad to 20 bytes. + 0 0 0)))) + ;; Send the client message. + (setq client-message (make-instance 'xcb:ClientMessage + :format format + :window client-xwin + :type exwm-xim--_XIM_PROTOCOL + :data client-message-data)) + (xcb:+request conn + (make-instance 'xcb:SendEvent + :propagate 0 + :destination client-xwin + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal client-message conn))))) + +(defun exwm-xim--on-DestroyNotify (data synthetic) + "Do cleanups on receiving DestroyNotify event. + +Such event would be received when the client window is destroyed." + (exwm--log) + (unless synthetic + (let ((evt (make-instance 'xcb:DestroyNotify)) + conn client-xwin server-xwin) + (xcb:unmarshal evt data) + (setq client-xwin (slot-value evt 'window) + server-xwin (plist-get exwm-xim--client-server-plist client-xwin)) + (when server-xwin + (setq conn (aref (plist-get exwm-xim--server-client-plist server-xwin) + 0)) + (cl-remf exwm-xim--server-client-plist server-xwin) + (cl-remf exwm-xim--client-server-plist client-xwin) + ;; Destroy the communication window & connection. + (xcb:+request conn + (make-instance 'xcb:DestroyWindow + :window server-xwin)) + (xcb:disconnect conn))))) + +(cl-defun exwm-xim--init () + "Initialize the XIM module." + (exwm--log) + (when exwm-xim--conn + (cl-return-from exwm-xim--init)) + ;; Initialize atoms. + (setq exwm-xim--@server (exwm--intern-atom "@server=exwm-xim") + exwm-xim--LOCALES (exwm--intern-atom "LOCALES") + exwm-xim--TRANSPORT (exwm--intern-atom "TRANSPORT") + exwm-xim--XIM_SERVERS (exwm--intern-atom "XIM_SERVERS") + exwm-xim--_XIM_PROTOCOL (exwm--intern-atom "_XIM_PROTOCOL") + exwm-xim--_XIM_XCONNECT (exwm--intern-atom "_XIM_XCONNECT")) + ;; Create a new connection and event window. + (setq exwm-xim--conn (xcb:connect) + exwm-xim--event-xwin (xcb:generate-id exwm-xim--conn)) + (set-process-query-on-exit-flag (slot-value exwm-xim--conn 'process) nil) + ;; Initialize xcb:keysyms module. + (xcb:keysyms:init exwm-xim--conn) + ;; Listen to SelectionRequest event for connection establishment. + (xcb:+event exwm-xim--conn 'xcb:SelectionRequest + #'exwm-xim--on-SelectionRequest) + ;; Listen to ClientMessage event on IMS window for new XIM connection. + (xcb:+event exwm-xim--conn 'xcb:ClientMessage #'exwm-xim--on-ClientMessage-0) + ;; Listen to DestroyNotify event to do cleanups. + (xcb:+event exwm-xim--conn 'xcb:DestroyNotify #'exwm-xim--on-DestroyNotify) + ;; Create the event window. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:CreateWindow + :depth 0 + :wid exwm-xim--event-xwin + :parent exwm--root + :x 0 + :y 0 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + ;; Set the selection owner. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:SetSelectionOwner + :owner exwm-xim--event-xwin + :selection exwm-xim--@server + :time xcb:Time:CurrentTime)) + ;; Set XIM_SERVERS property on the root window. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Prepend + :window exwm--root + :property exwm-xim--XIM_SERVERS + :type xcb:Atom:ATOM + :format 32 + :data-len 1 + :data (funcall (if xcb:lsb + #'xcb:-pack-u4-lsb + #'xcb:-pack-u4) + exwm-xim--@server))) + (xcb:flush exwm-xim--conn)) + +(cl-defun exwm-xim--exit () + "Exit the XIM module." + (exwm--log) + ;; Close IMS communication connections. + (mapc (lambda (i) + (when (vectorp i) + (xcb:disconnect (elt i 0)))) + exwm-xim--server-client-plist) + ;; Close the IMS connection. + (unless exwm-xim--conn + (cl-return-from exwm-xim--exit)) + ;; Remove exwm-xim from XIM_SERVERS. + (let ((reply (xcb:+request-unchecked+reply exwm-xim--conn + (make-instance 'xcb:GetProperty + :delete 1 + :window exwm--root + :property exwm-xim--XIM_SERVERS + :type xcb:Atom:ATOM + :long-offset 0 + :long-length 1000))) + unpacked-reply pack unpack) + (unless reply + (cl-return-from exwm-xim--exit)) + (setq reply (slot-value reply 'value)) + (unless (> (length reply) 4) + (cl-return-from exwm-xim--exit)) + (setq reply (vconcat reply) + pack (if xcb:lsb #'xcb:-pack-u4-lsb #'xcb:-pack-u4) + unpack (if xcb:lsb #'xcb:-unpack-u4-lsb #'xcb:-unpack-u4)) + (dotimes (i (/ (length reply) 4)) + (push (funcall unpack reply (* i 4)) unpacked-reply)) + (setq unpacked-reply (delq exwm-xim--@server unpacked-reply) + reply (mapcar pack unpacked-reply)) + (xcb:+request exwm-xim--conn + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Replace + :window exwm--root + :property exwm-xim--XIM_SERVERS + :type xcb:Atom:ATOM + :format 32 + :data-len (length reply) + :data reply)) + (xcb:flush exwm-xim--conn)) + (xcb:disconnect exwm-xim--conn) + (setq exwm-xim--conn nil)) + +(defun exwm-xim-enable () + "Enable XIM support for EXWM." + (exwm--log) + (add-hook 'exwm-init-hook #'exwm-xim--init) + (add-hook 'exwm-exit-hook #'exwm-xim--exit)) + + + +(provide 'exwm-xim) + +;;; exwm-xim.el ends here diff --git a/third_party/emacs/exwm/exwm.el b/third_party/emacs/exwm/exwm.el new file mode 100644 index 000000000000..fc96ac75098c --- /dev/null +++ b/third_party/emacs/exwm/exwm.el @@ -0,0 +1,1019 @@ +;;; exwm.el --- Emacs X Window Manager -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> +;; Maintainer: Chris Feng <chris.w.feng@gmail.com> +;; Version: 0.24 +;; Package-Requires: ((xelb "0.18")) +;; Keywords: unix +;; URL: https://github.com/ch11ng/exwm + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Overview +;; -------- +;; EXWM (Emacs X Window Manager) is a full-featured tiling X window manager +;; for Emacs built on top of [XELB](https://github.com/ch11ng/xelb). +;; It features: +;; + Fully keyboard-driven operations +;; + Hybrid layout modes (tiling & stacking) +;; + Dynamic workspace support +;; + ICCCM/EWMH compliance +;; + (Optional) RandR (multi-monitor) support +;; + (Optional) Built-in system tray + +;; Installation & configuration +;; ---------------------------- +;; Here are the minimal steps to get EXWM working: +;; 1. Install XELB and EXWM, and make sure they are in `load-path'. +;; 2. In '~/.emacs', add following lines (please modify accordingly): +;; +;; (require 'exwm) +;; (require 'exwm-config) +;; (exwm-config-example) +;; +;; 3. Link or copy the file 'xinitrc' to '~/.xinitrc'. +;; 4. Launch EXWM in a console (e.g. tty1) with +;; +;; xinit -- vt01 +;; +;; You should additionally hide the menu-bar, tool-bar, etc to increase the +;; usable space. Please check the wiki (https://github.com/ch11ng/exwm/wiki) +;; for more detailed instructions on installation, configuration, usage, etc. + +;; References: +;; + dwm (http://dwm.suckless.org/) +;; + i3 wm (https://i3wm.org/) +;; + Also see references within each required library. + +;;; Code: + +(require 'server) +(require 'exwm-core) +(require 'exwm-workspace) +(require 'exwm-layout) +(require 'exwm-floating) +(require 'exwm-manage) +(require 'exwm-input) + +(defgroup exwm nil + "Emacs X Window Manager." + :tag "EXWM" + :version "25.3" + :group 'applications + :prefix "exwm-") + +(defcustom exwm-init-hook nil + "Normal hook run when EXWM has just finished initialization." + :type 'hook) + +(defcustom exwm-exit-hook nil + "Normal hook run just before EXWM exits." + :type 'hook) + +(defcustom exwm-update-class-hook nil + "Normal hook run when window class is updated." + :type 'hook) + +(defcustom exwm-update-title-hook nil + "Normal hook run when window title is updated." + :type 'hook) + +(defcustom exwm-blocking-subrs '(x-file-dialog x-popup-dialog x-select-font) + "Subrs (primitives) that would normally block EXWM." + :type '(repeat function)) + +(defcustom exwm-replace 'ask + "Whether to replace existing window manager." + :type '(radio (const :tag "Ask" ask) + (const :tag "Replace by default" t) + (const :tag "Do not replace" nil))) + +(defconst exwm--server-name "server-exwm" + "Name of the subordinate Emacs server.") + +(defvar exwm--server-process nil "Process of the subordinate Emacs server.") + +(defun exwm-reset () + "Reset the state of the selected window (non-fullscreen, line-mode, etc)." + (interactive) + (exwm--log) + (with-current-buffer (window-buffer) + (when (derived-mode-p 'exwm-mode) + (when (exwm-layout--fullscreen-p) + (exwm-layout-unset-fullscreen)) + ;; Force refresh + (exwm-layout--refresh) + (call-interactively #'exwm-input-grab-keyboard)))) + +;;;###autoload +(defun exwm-restart () + "Restart EXWM." + (interactive) + (exwm--log) + (when (exwm--confirm-kill-emacs "[EXWM] Restart? " 'no-check) + (let* ((attr (process-attributes (emacs-pid))) + (args (cdr (assq 'args attr))) + (ppid (cdr (assq 'ppid attr))) + (pargs (cdr (assq 'args (process-attributes ppid))))) + (cond + ((= ppid 1) + ;; The parent is the init process. This probably means this + ;; instance is an emacsclient. Anyway, start a control instance + ;; to manage the subsequent ones. + (call-process (car command-line-args)) + (kill-emacs)) + ((string= args pargs) + ;; This is a subordinate instance. Return a magic number to + ;; inform the parent (control instance) to start another one. + (kill-emacs ?R)) + (t + ;; This is the control instance. Keep starting subordinate + ;; instances until told to exit. + ;; Run `server-force-stop' if it exists. + (run-hooks 'kill-emacs-hook) + (with-temp-buffer + (while (= ?R (shell-command-on-region (point) (point) args)))) + (kill-emacs)))))) + +(defun exwm--update-desktop (xwin) + "Update _NET_WM_DESKTOP." + (exwm--log "#x%x" xwin) + (with-current-buffer (exwm--id->buffer xwin) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_DESKTOP + :window xwin))) + desktop) + (when reply + (setq desktop (slot-value reply 'value)) + (cond + ((eq desktop 4294967295.) + (unless (or (not exwm--floating-frame) + (eq exwm--frame exwm-workspace--current) + (and exwm--desktop + (= desktop exwm--desktop))) + (exwm-layout--show xwin (frame-root-window exwm--floating-frame))) + (setq exwm--desktop desktop)) + ((and desktop + (< desktop (exwm-workspace--count)) + (if exwm--desktop + (/= desktop exwm--desktop) + (/= desktop (exwm-workspace--position exwm--frame)))) + (exwm-workspace-move-window desktop xwin)) + (t + (exwm-workspace--set-desktop xwin))))))) + +(defun exwm--update-window-type (id &optional force) + "Update _NET_WM_WINDOW_TYPE." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm-window-type (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_WINDOW_TYPE + :window id)))) + (when reply ;nil when destroyed + (setq exwm-window-type (append (slot-value reply 'value) nil))))))) + +(defun exwm--update-class (id &optional force) + "Update WM_CLASS." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm-instance-name exwm-class-name (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_CLASS :window id)))) + (when reply ;nil when destroyed + (setq exwm-instance-name (slot-value reply 'instance-name) + exwm-class-name (slot-value reply 'class-name)) + (when (and exwm-instance-name exwm-class-name) + (run-hooks 'exwm-update-class-hook))))))) + +(defun exwm--update-utf8-title (id &optional force) + "Update _NET_WM_NAME." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (when (or force (not exwm-title)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_NAME :window id)))) + (when reply ;nil when destroyed + (setq exwm-title (slot-value reply 'value)) + (when exwm-title + (setq exwm--title-is-utf8 t) + (run-hooks 'exwm-update-title-hook))))))) + +(defun exwm--update-ctext-title (id &optional force) + "Update WM_NAME." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (or exwm--title-is-utf8 + (and exwm-title (not force))) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_NAME :window id)))) + (when reply ;nil when destroyed + (setq exwm-title (slot-value reply 'value)) + (when exwm-title + (run-hooks 'exwm-update-title-hook))))))) + +(defun exwm--update-title (id) + "Update _NET_WM_NAME or WM_NAME." + (exwm--log "#x%x" id) + (exwm--update-utf8-title id) + (exwm--update-ctext-title id)) + +(defun exwm--update-transient-for (id &optional force) + "Update WM_TRANSIENT_FOR." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm-transient-for (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_TRANSIENT_FOR + :window id)))) + (when reply ;nil when destroyed + (setq exwm-transient-for (slot-value reply 'value))))))) + +(defun exwm--update-normal-hints (id &optional force) + "Update WM_NORMAL_HINTS." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and (not force) + (or exwm--normal-hints-x exwm--normal-hints-y + exwm--normal-hints-width exwm--normal-hints-height + exwm--normal-hints-min-width exwm--normal-hints-min-height + exwm--normal-hints-max-width exwm--normal-hints-max-height + ;; FIXME: other fields + )) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_NORMAL_HINTS + :window id)))) + (when (and reply (slot-value reply 'flags)) ;nil when destroyed + (with-slots (flags x y width height min-width min-height max-width + max-height base-width base-height ;; win-gravity + ) + reply + (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:USPosition)) + (setq exwm--normal-hints-x x exwm--normal-hints-y y)) + (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:USSize)) + (setq exwm--normal-hints-width width + exwm--normal-hints-height height)) + (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:PMinSize)) + (setq exwm--normal-hints-min-width min-width + exwm--normal-hints-min-height min-height)) + (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:PMaxSize)) + (setq exwm--normal-hints-max-width max-width + exwm--normal-hints-max-height max-height)) + (unless (or exwm--normal-hints-min-width + (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:PBaseSize))) + (setq exwm--normal-hints-min-width base-width + exwm--normal-hints-min-height base-height)) + ;; (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:PWinGravity)) + ;; (setq exwm--normal-hints-win-gravity win-gravity)) + (setq exwm--fixed-size + (and exwm--normal-hints-min-width + exwm--normal-hints-min-height + exwm--normal-hints-max-width + exwm--normal-hints-max-height + (/= 0 exwm--normal-hints-min-width) + (/= 0 exwm--normal-hints-min-height) + (= exwm--normal-hints-min-width + exwm--normal-hints-max-width) + (= exwm--normal-hints-min-height + exwm--normal-hints-max-height))))))))) + +(defun exwm--update-hints (id &optional force) + "Update WM_HINTS." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and (not force) exwm--hints-input exwm--hints-urgency) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_HINTS :window id)))) + (when (and reply (slot-value reply 'flags)) ;nil when destroyed + (with-slots (flags input initial-state) reply + (when flags + (unless (= 0 (logand flags xcb:icccm:WM_HINTS:InputHint)) + (setq exwm--hints-input (when input (= 1 input)))) + (unless (= 0 (logand flags xcb:icccm:WM_HINTS:StateHint)) + (setq exwm-state initial-state)) + (unless (= 0 (logand flags xcb:icccm:WM_HINTS:UrgencyHint)) + (setq exwm--hints-urgency t)))) + (when (and exwm--hints-urgency + (not (eq exwm--frame exwm-workspace--current))) + (unless (frame-parameter exwm--frame 'exwm-urgency) + (set-frame-parameter exwm--frame 'exwm-urgency t) + (setq exwm-workspace--switch-history-outdated t)))))))) + +(defun exwm--update-protocols (id &optional force) + "Update WM_PROTOCOLS." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm--protocols (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_PROTOCOLS + :window id)))) + (when reply ;nil when destroyed + (setq exwm--protocols (append (slot-value reply 'value) nil))))))) + +(defun exwm--update-struts-legacy (id) + "Update _NET_WM_STRUT." + (exwm--log "#x%x" id) + (let ((pair (assq id exwm-workspace--id-struts-alist)) + reply struts) + (unless (and pair (< 4 (length (cdr pair)))) + (setq reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_STRUT + :window id))) + (when reply + (setq struts (slot-value reply 'value)) + (if pair + (setcdr pair struts) + (push (cons id struts) exwm-workspace--id-struts-alist)) + (exwm-workspace--update-struts)) + ;; Update workareas. + (exwm-workspace--update-workareas) + ;; Update workspaces. + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f))))) + +(defun exwm--update-struts-partial (id) + "Update _NET_WM_STRUT_PARTIAL." + (exwm--log "#x%x" id) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_STRUT_PARTIAL + :window id))) + struts pair) + (when reply + (setq struts (slot-value reply 'value) + pair (assq id exwm-workspace--id-struts-alist)) + (if pair + (setcdr pair struts) + (push (cons id struts) exwm-workspace--id-struts-alist)) + (exwm-workspace--update-struts)) + ;; Update workareas. + (exwm-workspace--update-workareas) + ;; Update workspaces. + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f)))) + +(defun exwm--update-struts (id) + "Update _NET_WM_STRUT_PARTIAL or _NET_WM_STRUT." + (exwm--log "#x%x" id) + (exwm--update-struts-partial id) + (exwm--update-struts-legacy id)) + +(defun exwm--on-PropertyNotify (data _synthetic) + "Handle PropertyNotify event." + (let ((obj (make-instance 'xcb:PropertyNotify)) + atom id buffer) + (xcb:unmarshal obj data) + (setq id (slot-value obj 'window) + atom (slot-value obj 'atom)) + (exwm--log "atom=%s(%s)" (x-get-atom-name atom exwm-workspace--current) atom) + (setq buffer (exwm--id->buffer id)) + (if (not (buffer-live-p buffer)) + ;; Properties of unmanaged X windows. + (cond ((= atom xcb:Atom:_NET_WM_STRUT) + (exwm--update-struts-legacy id)) + ((= atom xcb:Atom:_NET_WM_STRUT_PARTIAL) + (exwm--update-struts-partial id))) + (with-current-buffer buffer + (cond ((= atom xcb:Atom:_NET_WM_WINDOW_TYPE) + (exwm--update-window-type id t)) + ((= atom xcb:Atom:WM_CLASS) + (exwm--update-class id t)) + ((= atom xcb:Atom:_NET_WM_NAME) + (exwm--update-utf8-title id t)) + ((= atom xcb:Atom:WM_NAME) + (exwm--update-ctext-title id t)) + ((= atom xcb:Atom:WM_TRANSIENT_FOR) + (exwm--update-transient-for id t)) + ((= atom xcb:Atom:WM_NORMAL_HINTS) + (exwm--update-normal-hints id t)) + ((= atom xcb:Atom:WM_HINTS) + (exwm--update-hints id t)) + ((= atom xcb:Atom:WM_PROTOCOLS) + (exwm--update-protocols id t)) + ((= atom xcb:Atom:_NET_WM_USER_TIME)) ;ignored + (t + (exwm--log "Unhandled: %s(%d)" + (x-get-atom-name atom exwm-workspace--current) + atom))))))) + +(defun exwm--on-ClientMessage (raw-data _synthetic) + "Handle ClientMessage event." + (let ((obj (make-instance 'xcb:ClientMessage)) + type id data) + (xcb:unmarshal obj raw-data) + (setq type (slot-value obj 'type) + id (slot-value obj 'window) + data (slot-value (slot-value obj 'data) 'data32)) + (exwm--log "atom=%s(%s)" (x-get-atom-name type exwm-workspace--current) + type) + (cond + ;; _NET_NUMBER_OF_DESKTOPS. + ((= type xcb:Atom:_NET_NUMBER_OF_DESKTOPS) + (let ((current (exwm-workspace--count)) + (requested (elt data 0))) + ;; Only allow increasing/decreasing the workspace number by 1. + (cond + ((< current requested) + (make-frame)) + ((and (> current requested) + (> current 1)) + (let ((frame (car (last exwm-workspace--list)))) + (exwm-workspace--get-remove-frame-next-workspace frame) + (delete-frame frame)))))) + ;; _NET_CURRENT_DESKTOP. + ((= type xcb:Atom:_NET_CURRENT_DESKTOP) + (exwm-workspace-switch (elt data 0))) + ;; _NET_ACTIVE_WINDOW. + ((= type xcb:Atom:_NET_ACTIVE_WINDOW) + (let ((buffer (exwm--id->buffer id)) + iconic window) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (eq exwm--frame exwm-workspace--current) + (if exwm--floating-frame + (select-frame exwm--floating-frame) + (setq iconic (exwm-layout--iconic-state-p)) + (when iconic + ;; State change: iconic => normal. + (set-window-buffer (frame-selected-window exwm--frame) + (current-buffer))) + ;; Focus transfer. + (setq window (get-buffer-window nil t)) + (when (or iconic + (not (eq window (selected-window)))) + (select-window window)))))))) + ;; _NET_CLOSE_WINDOW. + ((= type xcb:Atom:_NET_CLOSE_WINDOW) + (let ((buffer (exwm--id->buffer id))) + (when (buffer-live-p buffer) + (exwm--defer 0 #'kill-buffer buffer)))) + ;; _NET_WM_MOVERESIZE + ((= type xcb:Atom:_NET_WM_MOVERESIZE) + (let ((direction (elt data 2)) + (buffer (exwm--id->buffer id))) + (unless (and buffer + (not (buffer-local-value 'exwm--floating-frame buffer))) + (cond ((= direction + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_KEYBOARD) + ;; FIXME + ) + ((= direction + xcb:ewmh:_NET_WM_MOVERESIZE_MOVE_KEYBOARD) + ;; FIXME + ) + ((= direction xcb:ewmh:_NET_WM_MOVERESIZE_CANCEL) + (exwm-floating--stop-moveresize)) + ;; In case it's a workspace frame. + ((and (not buffer) + (catch 'break + (dolist (f exwm-workspace--list) + (when (or (eq id (frame-parameter f 'exwm-outer-id)) + (eq id (frame-parameter f 'exwm-id))) + (throw 'break t))) + nil))) + (t + ;; In case it's a floating frame, + ;; move the corresponding X window instead. + (unless buffer + (catch 'break + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when + (and exwm--floating-frame + (or (eq id + (frame-parameter exwm--floating-frame + 'exwm-outer-id)) + (eq id + (frame-parameter exwm--floating-frame + 'exwm-id)))) + (setq id exwm--id) + (throw 'break nil)))))) + ;; Start to move it. + (exwm-floating--start-moveresize id direction)))))) + ;; _NET_REQUEST_FRAME_EXTENTS + ((= type xcb:Atom:_NET_REQUEST_FRAME_EXTENTS) + (let ((buffer (exwm--id->buffer id)) + top btm) + (if (or (not buffer) + (not (buffer-local-value 'exwm--floating-frame buffer))) + (setq top 0 + btm 0) + (setq top (window-header-line-height) + btm (window-mode-line-height))) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_FRAME_EXTENTS + :window id + :left 0 + :right 0 + :top top + :bottom btm))) + (xcb:flush exwm--connection)) + ;; _NET_WM_DESKTOP. + ((= type xcb:Atom:_NET_WM_DESKTOP) + (let ((buffer (exwm--id->buffer id))) + (when (buffer-live-p buffer) + (exwm-workspace-move-window (elt data 0) id)))) + ;; _NET_WM_STATE + ((= type xcb:Atom:_NET_WM_STATE) + (let ((action (elt data 0)) + (props (list (elt data 1) (elt data 2))) + (buffer (exwm--id->buffer id)) + props-new) + ;; only support _NET_WM_STATE_FULLSCREEN / _NET_WM_STATE_ADD for frames + (when (and (not buffer) + (memq xcb:Atom:_NET_WM_STATE_FULLSCREEN props) + (= action xcb:ewmh:_NET_WM_STATE_ADD)) + (xcb:+request + exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_STATE + :window id + :data (vector xcb:Atom:_NET_WM_STATE_FULLSCREEN))) + (xcb:flush exwm--connection)) + (when buffer ;ensure it's managed + (with-current-buffer buffer + ;; _NET_WM_STATE_FULLSCREEN + (when (or (memq xcb:Atom:_NET_WM_STATE_FULLSCREEN props) + (memq xcb:Atom:_NET_WM_STATE_ABOVE props)) + (cond ((= action xcb:ewmh:_NET_WM_STATE_ADD) + (unless (exwm-layout--fullscreen-p) + (exwm-layout-set-fullscreen id)) + (push xcb:Atom:_NET_WM_STATE_FULLSCREEN props-new)) + ((= action xcb:ewmh:_NET_WM_STATE_REMOVE) + (when (exwm-layout--fullscreen-p) + (exwm-layout-unset-fullscreen id))) + ((= action xcb:ewmh:_NET_WM_STATE_TOGGLE) + (if (exwm-layout--fullscreen-p) + (exwm-layout-unset-fullscreen id) + (exwm-layout-set-fullscreen id) + (push xcb:Atom:_NET_WM_STATE_FULLSCREEN props-new))))) + ;; _NET_WM_STATE_DEMANDS_ATTENTION + ;; FIXME: check (may require other properties set) + (when (memq xcb:Atom:_NET_WM_STATE_DEMANDS_ATTENTION props) + (when (= action xcb:ewmh:_NET_WM_STATE_ADD) + (unless (eq exwm--frame exwm-workspace--current) + (set-frame-parameter exwm--frame 'exwm-urgency t) + (setq exwm-workspace--switch-history-outdated t))) + ;; xcb:ewmh:_NET_WM_STATE_REMOVE? + ;; xcb:ewmh:_NET_WM_STATE_TOGGLE? + ) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_STATE + :window id :data (vconcat props-new))) + (xcb:flush exwm--connection))))) + ((= type xcb:Atom:WM_PROTOCOLS) + (let ((type (elt data 0))) + (cond ((= type xcb:Atom:_NET_WM_PING) + (setq exwm-manage--ping-lock nil)) + (t (exwm--log "Unhandled WM_PROTOCOLS of type: %d" type))))) + ((= type xcb:Atom:WM_CHANGE_STATE) + (let ((buffer (exwm--id->buffer id))) + (when (and (buffer-live-p buffer) + (= (elt data 0) xcb:icccm:WM_STATE:IconicState)) + (with-current-buffer buffer + (if exwm--floating-frame + (call-interactively #'exwm-floating-hide) + (bury-buffer)))))) + (t + (exwm--log "Unhandled: %s(%d)" + (x-get-atom-name type exwm-workspace--current) type))))) + +(defun exwm--on-SelectionClear (data _synthetic) + "Handle SelectionClear events." + (exwm--log) + (let ((obj (make-instance 'xcb:SelectionClear)) + owner selection) + (xcb:unmarshal obj data) + (setq owner (slot-value obj 'owner) + selection (slot-value obj 'selection)) + (when (and (eq owner exwm--wmsn-window) + (eq selection xcb:Atom:WM_S0)) + (exwm-exit)))) + +(defun exwm--init-icccm-ewmh () + "Initialize ICCCM/EWMH support." + (exwm--log) + ;; Handle PropertyNotify event + (xcb:+event exwm--connection 'xcb:PropertyNotify #'exwm--on-PropertyNotify) + ;; Handle relevant client messages + (xcb:+event exwm--connection 'xcb:ClientMessage #'exwm--on-ClientMessage) + ;; Handle SelectionClear + (xcb:+event exwm--connection 'xcb:SelectionClear #'exwm--on-SelectionClear) + ;; Set _NET_SUPPORTED + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_SUPPORTED + :window exwm--root + :data (vector + ;; Root windows properties. + xcb:Atom:_NET_SUPPORTED + xcb:Atom:_NET_CLIENT_LIST + xcb:Atom:_NET_CLIENT_LIST_STACKING + xcb:Atom:_NET_NUMBER_OF_DESKTOPS + xcb:Atom:_NET_DESKTOP_GEOMETRY + xcb:Atom:_NET_DESKTOP_VIEWPORT + xcb:Atom:_NET_CURRENT_DESKTOP + ;; xcb:Atom:_NET_DESKTOP_NAMES + xcb:Atom:_NET_ACTIVE_WINDOW + ;; xcb:Atom:_NET_WORKAREA + xcb:Atom:_NET_SUPPORTING_WM_CHECK + ;; xcb:Atom:_NET_VIRTUAL_ROOTS + ;; xcb:Atom:_NET_DESKTOP_LAYOUT + ;; xcb:Atom:_NET_SHOWING_DESKTOP + + ;; Other root window messages. + xcb:Atom:_NET_CLOSE_WINDOW + ;; xcb:Atom:_NET_MOVERESIZE_WINDOW + xcb:Atom:_NET_WM_MOVERESIZE + ;; xcb:Atom:_NET_RESTACK_WINDOW + xcb:Atom:_NET_REQUEST_FRAME_EXTENTS + + ;; Application window properties. + xcb:Atom:_NET_WM_NAME + ;; xcb:Atom:_NET_WM_VISIBLE_NAME + ;; xcb:Atom:_NET_WM_ICON_NAME + ;; xcb:Atom:_NET_WM_VISIBLE_ICON_NAME + xcb:Atom:_NET_WM_DESKTOP + ;; + xcb:Atom:_NET_WM_WINDOW_TYPE + ;; xcb:Atom:_NET_WM_WINDOW_TYPE_DESKTOP + xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK + xcb:Atom:_NET_WM_WINDOW_TYPE_TOOLBAR + xcb:Atom:_NET_WM_WINDOW_TYPE_MENU + xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY + xcb:Atom:_NET_WM_WINDOW_TYPE_SPLASH + xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG + xcb:Atom:_NET_WM_WINDOW_TYPE_DROPDOWN_MENU + xcb:Atom:_NET_WM_WINDOW_TYPE_POPUP_MENU + xcb:Atom:_NET_WM_WINDOW_TYPE_TOOLTIP + xcb:Atom:_NET_WM_WINDOW_TYPE_NOTIFICATION + xcb:Atom:_NET_WM_WINDOW_TYPE_COMBO + xcb:Atom:_NET_WM_WINDOW_TYPE_DND + xcb:Atom:_NET_WM_WINDOW_TYPE_NORMAL + ;; + xcb:Atom:_NET_WM_STATE + ;; xcb:Atom:_NET_WM_STATE_MODAL + ;; xcb:Atom:_NET_WM_STATE_STICKY + ;; xcb:Atom:_NET_WM_STATE_MAXIMIZED_VERT + ;; xcb:Atom:_NET_WM_STATE_MAXIMIZED_HORZ + ;; xcb:Atom:_NET_WM_STATE_SHADED + ;; xcb:Atom:_NET_WM_STATE_SKIP_TASKBAR + ;; xcb:Atom:_NET_WM_STATE_SKIP_PAGER + xcb:Atom:_NET_WM_STATE_HIDDEN + xcb:Atom:_NET_WM_STATE_FULLSCREEN + ;; xcb:Atom:_NET_WM_STATE_ABOVE + ;; xcb:Atom:_NET_WM_STATE_BELOW + xcb:Atom:_NET_WM_STATE_DEMANDS_ATTENTION + ;; xcb:Atom:_NET_WM_STATE_FOCUSED + ;; + xcb:Atom:_NET_WM_ALLOWED_ACTIONS + xcb:Atom:_NET_WM_ACTION_MOVE + xcb:Atom:_NET_WM_ACTION_RESIZE + xcb:Atom:_NET_WM_ACTION_MINIMIZE + ;; xcb:Atom:_NET_WM_ACTION_SHADE + ;; xcb:Atom:_NET_WM_ACTION_STICK + ;; xcb:Atom:_NET_WM_ACTION_MAXIMIZE_HORZ + ;; xcb:Atom:_NET_WM_ACTION_MAXIMIZE_VERT + xcb:Atom:_NET_WM_ACTION_FULLSCREEN + xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP + xcb:Atom:_NET_WM_ACTION_CLOSE + ;; xcb:Atom:_NET_WM_ACTION_ABOVE + ;; xcb:Atom:_NET_WM_ACTION_BELOW + ;; + xcb:Atom:_NET_WM_STRUT + xcb:Atom:_NET_WM_STRUT_PARTIAL + ;; xcb:Atom:_NET_WM_ICON_GEOMETRY + ;; xcb:Atom:_NET_WM_ICON + xcb:Atom:_NET_WM_PID + ;; xcb:Atom:_NET_WM_HANDLED_ICONS + ;; xcb:Atom:_NET_WM_USER_TIME + ;; xcb:Atom:_NET_WM_USER_TIME_WINDOW + xcb:Atom:_NET_FRAME_EXTENTS + ;; xcb:Atom:_NET_WM_OPAQUE_REGION + ;; xcb:Atom:_NET_WM_BYPASS_COMPOSITOR + + ;; Window manager protocols. + xcb:Atom:_NET_WM_PING + ;; xcb:Atom:_NET_WM_SYNC_REQUEST + ;; xcb:Atom:_NET_WM_FULLSCREEN_MONITORS + + ;; Other properties. + xcb:Atom:_NET_WM_FULL_PLACEMENT))) + ;; Create a child window for setting _NET_SUPPORTING_WM_CHECK + (let ((new-id (xcb:generate-id exwm--connection))) + (setq exwm--guide-window new-id) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid new-id + :parent exwm--root + :x -1 + :y -1 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOnly + :visual 0 + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + ;; Set _NET_WM_NAME. Must be set to the name of the window manager, as + ;; required by wm-spec. + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window new-id :data "EXWM")) + (dolist (i (list exwm--root new-id)) + ;; Set _NET_SUPPORTING_WM_CHECK + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_SUPPORTING_WM_CHECK + :window i :data new-id)))) + ;; Set _NET_DESKTOP_VIEWPORT (we don't support large desktop). + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_DESKTOP_VIEWPORT + :window exwm--root + :data [0 0])) + (xcb:flush exwm--connection)) + +(defun exwm--wmsn-acquire (replace) + "Acquire the WM_Sn selection. + +REPLACE specifies what to do in case there already is a window +manager. If t, replace it, if nil, abort and ask the user if `ask'." + (exwm--log "%s" replace) + (with-slots (owner) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetSelectionOwner + :selection xcb:Atom:WM_S0)) + (when (/= owner xcb:Window:None) + (when (eq replace 'ask) + (setq replace (yes-or-no-p "Replace existing window manager? "))) + (when (not replace) + (user-error "Other window manager detected"))) + (let ((new-owner (xcb:generate-id exwm--connection))) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid new-owner + :parent exwm--root + :x -1 + :y -1 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:CopyFromParent + :visual 0 + :value-mask 0 + :override-redirect 0)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window new-owner :data "EXWM: exwm--wmsn-window")) + (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:SetSelectionOwner + :selection xcb:Atom:WM_S0 + :owner new-owner + :time xcb:Time:CurrentTime)) + (with-slots (owner) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetSelectionOwner + :selection xcb:Atom:WM_S0)) + (unless (eq owner new-owner) + (error "Could not acquire ownership of WM selection"))) + ;; Wait for the other window manager to terminate. + (when (/= owner xcb:Window:None) + (let (reply) + (cl-dotimes (i exwm--wmsn-acquire-timeout) + (setq reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry :drawable owner))) + (when (not reply) + (cl-return)) + (message "Waiting for other window manager to quit... %ds" i) + (sleep-for 1)) + (when reply + (error "Other window manager did not release selection in time")))) + ;; announce + (let* ((cmd (make-instance 'xcb:ClientMessageData + :data32 (vector xcb:Time:CurrentTime + xcb:Atom:WM_S0 + new-owner + 0 + 0))) + (cm (make-instance 'xcb:ClientMessage + :window exwm--root + :format 32 + :type xcb:Atom:MANAGER + :data cmd)) + (se (make-instance 'xcb:SendEvent + :propagate 0 + :destination exwm--root + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal cm exwm--connection)))) + (xcb:+request exwm--connection se)) + (setq exwm--wmsn-window new-owner)))) + +;;;###autoload +(cl-defun exwm-init (&optional frame) + "Initialize EXWM." + (interactive) + (exwm--log "%s" frame) + (if frame + ;; The frame might not be selected if it's created by emacslicnet. + (select-frame-set-input-focus frame) + (setq frame (selected-frame))) + (when (not (eq 'x (framep frame))) + (message "[EXWM] Not running under X environment") + (cl-return-from exwm-init)) + (when exwm--connection + (exwm--log "EXWM already running") + (cl-return-from exwm-init)) + (condition-case err + (progn + (exwm-enable 'undo) ;never initialize again + (setq exwm--connection (xcb:connect)) + (set-process-query-on-exit-flag (slot-value exwm--connection 'process) + nil) ;prevent query message on exit + (setq exwm--root + (slot-value (car (slot-value + (xcb:get-setup exwm--connection) 'roots)) + 'root)) + ;; Initialize ICCCM/EWMH support + (xcb:icccm:init exwm--connection t) + (xcb:ewmh:init exwm--connection t) + ;; Try to register window manager selection. + (exwm--wmsn-acquire exwm-replace) + (when (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--root + :value-mask xcb:CW:EventMask + :event-mask + xcb:EventMask:SubstructureRedirect)) + (error "Other window manager is running")) + ;; Disable some features not working well with EXWM + (setq use-dialog-box nil + confirm-kill-emacs #'exwm--confirm-kill-emacs) + (exwm--lock) + (exwm--init-icccm-ewmh) + (exwm-layout--init) + (exwm-floating--init) + (exwm-manage--init) + (exwm-workspace--init) + (exwm-input--init) + (exwm--unlock) + (exwm-workspace--post-init) + (exwm-input--post-init) + (run-hooks 'exwm-init-hook) + ;; Manage existing windows + (exwm-manage--scan)) + (user-error) + ((quit error) + (exwm-exit) + ;; Rethrow error + (warn "[EXWM] EXWM fails to start (%s: %s)" (car err) (cdr err))))) + + +;;;###autoload +(defun exwm-exit () + "Exit EXWM." + (interactive) + (exwm--log) + (run-hooks 'exwm-exit-hook) + (setq confirm-kill-emacs nil) + ;; Exit modules. + (exwm-input--exit) + (exwm-manage--exit) + (exwm-workspace--exit) + (exwm-floating--exit) + (exwm-layout--exit) + (when exwm--connection + (xcb:flush exwm--connection) + (xcb:disconnect exwm--connection)) + (setq exwm--connection nil)) + +;;;###autoload +(defun exwm-enable (&optional undo) + "Enable/Disable EXWM." + (exwm--log "%s" undo) + (pcase undo + (`undo ;prevent reinitialization + (remove-hook 'window-setup-hook #'exwm-init) + (remove-hook 'after-make-frame-functions #'exwm-init)) + (`undo-all ;attempt to revert everything + (remove-hook 'window-setup-hook #'exwm-init) + (remove-hook 'after-make-frame-functions #'exwm-init) + (remove-hook 'kill-emacs-hook #'exwm--server-stop) + (dolist (i exwm-blocking-subrs) + (advice-remove i #'exwm--server-eval-at))) + (_ ;enable EXWM + (setq frame-resize-pixelwise t ;mandatory; before init + window-resize-pixelwise t) + ;; Ignore unrecognized command line arguments. This can be helpful + ;; when EXWM is launched by some session manager. + (push #'vector command-line-functions) + ;; In case EXWM is to be started from a graphical Emacs instance. + (add-hook 'window-setup-hook #'exwm-init t) + ;; In case EXWM is to be started with emacsclient. + (add-hook 'after-make-frame-functions #'exwm-init t) + ;; Manage the subordinate Emacs server. + (add-hook 'kill-emacs-hook #'exwm--server-stop) + (dolist (i exwm-blocking-subrs) + (advice-add i :around #'exwm--server-eval-at))))) + +(defun exwm--server-stop () + "Stop the subordinate Emacs server." + (exwm--log) + (server-force-delete exwm--server-name) + (when exwm--server-process + (delete-process exwm--server-process) + (setq exwm--server-process nil))) + +(defun exwm--server-eval-at (&rest args) + "Wrapper of `server-eval-at' used to advice subrs." + ;; Start the subordinate Emacs server if it's not alive + (exwm--log "%s" args) + (unless (server-running-p exwm--server-name) + (when exwm--server-process (delete-process exwm--server-process)) + (setq exwm--server-process + (start-process exwm--server-name + nil + (car command-line-args) ;The executable file + "-d" (frame-parameter nil 'display) + "-Q" + (concat "--daemon=" exwm--server-name) + "--eval" + ;; Create an invisible frame + "(make-frame '((window-system . x) (visibility)))")) + (while (not (server-running-p exwm--server-name)) + (sit-for 0.001))) + (server-eval-at + exwm--server-name + `(progn (select-frame (car (frame-list))) + (let ((result ,(nconc (list (make-symbol (subr-name (car args)))) + (cdr args)))) + (pcase (type-of result) + ;; Return the name of a buffer + (`buffer (buffer-name result)) + ;; We blindly convert all font objects to their XLFD names. This + ;; might cause problems of course, but it still has a chance to + ;; work (whereas directly passing font objects would merely + ;; raise errors). + ((or `font-entity `font-object `font-spec) + (font-xlfd-name result)) + ;; Passing following types makes little sense + ((or `compiled-function `finalizer `frame `hash-table `marker + `overlay `process `window `window-configuration)) + ;; Passing the name of a subr + (`subr (make-symbol (subr-name result))) + ;; For other types, return the value as-is. + (t result)))))) + +(defun exwm--confirm-kill-emacs (prompt &optional force) + "Confirm before exiting Emacs." + (exwm--log) + (when (cond + ((and force (not (eq force 'no-check))) + ;; Force killing Emacs. + t) + ((or (eq force 'no-check) (not exwm--id-buffer-alist)) + ;; Check if there's any unsaved file. + (pcase (catch 'break + (let ((kill-emacs-query-functions + (append kill-emacs-query-functions + (list (lambda () + (throw 'break 'break)))))) + (save-buffers-kill-emacs))) + (`break (y-or-n-p prompt)) + (x x))) + (t + (yes-or-no-p (format "[EXWM] %d window(s) will be destroyed. %s" + (length exwm--id-buffer-alist) prompt)))) + ;; Run `kill-emacs-hook' (`server-force-stop' excluded) before Emacs + ;; frames are unmapped so that errors (if any) can be visible. + (if (memq #'server-force-stop kill-emacs-hook) + (progn + (setq kill-emacs-hook (delq #'server-force-stop kill-emacs-hook)) + (run-hooks 'kill-emacs-hook) + (setq kill-emacs-hook (list #'server-force-stop))) + (run-hooks 'kill-emacs-hook) + (setq kill-emacs-hook nil)) + ;; Exit each module, destroying all resources created by this connection. + (exwm-exit) + ;; Set the return value. + t)) + + + +(provide 'exwm) + +;;; exwm.el ends here diff --git a/third_party/emacs/exwm/xinitrc b/third_party/emacs/exwm/xinitrc new file mode 100644 index 000000000000..591e4199144f --- /dev/null +++ b/third_party/emacs/exwm/xinitrc @@ -0,0 +1,20 @@ +# Disable access control for the current user. +xhost +SI:localuser:$USER + +# Make Java applications aware this is a non-reparenting window manager. +export _JAVA_AWT_WM_NONREPARENTING=1 + +# Set default cursor. +xsetroot -cursor_name left_ptr + +# Set keyboard repeat rate. +xset r rate 200 60 + +# Uncomment the following block to use the exwm-xim module. +#export XMODIFIERS=@im=exwm-xim +#export GTK_IM_MODULE=xim +#export QT_IM_MODULE=xim +#export CLUTTER_IM_MODULE=xim + +# Finally start Emacs +exec emacs diff --git a/third_party/emacs/rcirc/default.nix b/third_party/emacs/rcirc/default.nix new file mode 100644 index 000000000000..9d22c7cd8663 --- /dev/null +++ b/third_party/emacs/rcirc/default.nix @@ -0,0 +1,7 @@ +{ pkgs, ... }: + +pkgs.emacsPackages.trivialBuild rec { + pname = "rcirc"; + version = "1"; + src = ./rcirc.el; +} diff --git a/third_party/emacs/rcirc/rcirc.el b/third_party/emacs/rcirc/rcirc.el new file mode 100644 index 000000000000..b59cb4e9afe4 --- /dev/null +++ b/third_party/emacs/rcirc/rcirc.el @@ -0,0 +1,3133 @@ +;;; rcirc.el --- default, simple IRC client -*- lexical-binding: t; -*- + +;; Copyright (C) 2005-2019 Free Software Foundation, Inc. + +;; Author: Ryan Yeske <rcyeske@gmail.com> +;; Maintainers: Ryan Yeske <rcyeske@gmail.com>, +;; Leo Liu <sdl.web@gmail.com> +;; Keywords: comm + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Internet Relay Chat (IRC) is a form of instant communication over +;; the Internet. It is mainly designed for group (many-to-many) +;; communication in discussion forums called channels, but also allows +;; one-to-one communication. + +;; Rcirc has simple defaults and clear and consistent behavior. +;; Message arrival timestamps, activity notification on the mode line, +;; message filling, nick completion, and keepalive pings are all +;; enabled by default, but can easily be adjusted or turned off. Each +;; discussion takes place in its own buffer and there is a single +;; server buffer per connection. + +;; Open a new irc connection with: +;; M-x irc RET + +;;; Todo: + +;;; Code: + +(require 'cl-lib) +(require 'ring) +(require 'time-date) +(require 'subr-x) + +(defgroup rcirc nil + "Simple IRC client." + :version "22.1" + :prefix "rcirc-" + :link '(custom-manual "(rcirc)") + :group 'applications) + +(defcustom rcirc-server-alist + '(("irc.freenode.net" :channels ("#rcirc") + ;; Don't use the TLS port by default, in case gnutls is not available. + ;; :port 7000 :encryption tls + )) + "An alist of IRC connections to establish when running `rcirc'. +Each element looks like (SERVER-NAME PARAMETERS). + +SERVER-NAME is a string describing the server to connect +to. + +The optional PARAMETERS come in pairs PARAMETER VALUE. + +The following parameters are recognized: + +`:nick' + +VALUE must be a string. If absent, `rcirc-default-nick' is used +for this connection. + +`:port' + +VALUE must be a number or string. If absent, +`rcirc-default-port' is used. + +`:user-name' + +VALUE must be a string. If absent, `rcirc-default-user-name' is +used. + +`:password' + +VALUE must be a string. If absent, no PASS command will be sent +to the server. + +`:full-name' + +VALUE must be a string. If absent, `rcirc-default-full-name' is +used. + +`:channels' + +VALUE must be a list of strings describing which channels to join +when connecting to this server. If absent, no channels will be +connected to automatically. + +`:encryption' + +VALUE must be `plain' (the default) for unencrypted connections, or `tls' +for connections using SSL/TLS. + +`:server-alias' + +VALUE must be a string that will be used instead of the server name for +display purposes. If absent, the real server name will be displayed instead." + :type '(alist :key-type string + :value-type (plist :options + ((:nick string) + (:port integer) + (:user-name string) + (:password string) + (:full-name string) + (:channels (repeat string)) + (:encryption (choice (const tls) + (const plain))) + (:server-alias string)))) + :group 'rcirc) + +(defcustom rcirc-default-port 6667 + "The default port to connect to." + :type 'integer + :group 'rcirc) + +(defcustom rcirc-default-nick (user-login-name) + "Your nick." + :type 'string + :group 'rcirc) + +(defcustom rcirc-default-user-name "user" + "Your user name sent to the server when connecting." + :version "24.1" ; changed default + :type 'string + :group 'rcirc) + +(defcustom rcirc-default-full-name "unknown" + "The full name sent to the server when connecting." + :version "24.1" ; changed default + :type 'string + :group 'rcirc) + +(defcustom rcirc-fill-flag t + "Non-nil means line-wrap messages printed in channel buffers." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-fill-column nil + "Column beyond which automatic line-wrapping should happen. +If nil, use value of `fill-column'. +If a function (e.g., `frame-text-width' or `window-text-width'), +call it to compute the number of columns." + :risky t ; can get funcalled + :type '(choice (const :tag "Value of `fill-column'" nil) + (integer :tag "Number of columns") + (function :tag "Function returning the number of columns")) + :group 'rcirc) + +(defcustom rcirc-fill-prefix nil + "Text to insert before filled lines. +If nil, calculate the prefix dynamically to line up text +underneath each nick." + :type '(choice (const :tag "Dynamic" nil) + (string :tag "Prefix text")) + :group 'rcirc) + +(defvar rcirc-ignore-buffer-activity-flag nil + "If non-nil, ignore activity in this buffer.") +(make-variable-buffer-local 'rcirc-ignore-buffer-activity-flag) + +(defvar rcirc-low-priority-flag nil + "If non-nil, activity in this buffer is considered low priority.") +(make-variable-buffer-local 'rcirc-low-priority-flag) + +(defcustom rcirc-omit-responses + '("JOIN" "PART" "QUIT" "NICK") + "Responses which will be hidden when `rcirc-omit-mode' is enabled." + :type '(repeat string) + :group 'rcirc) + +(defvar rcirc-prompt-start-marker nil) + +(define-minor-mode rcirc-omit-mode + "Toggle the hiding of \"uninteresting\" lines. +With a prefix argument ARG, enable Rcirc-Omit mode if ARG is +positive, and disable it otherwise. If called from Lisp, enable +the mode if ARG is omitted or nil. + +Uninteresting lines are those whose responses are listed in +`rcirc-omit-responses'." + nil " Omit" nil + (if rcirc-omit-mode + (progn + (add-to-invisibility-spec '(rcirc-omit . nil)) + (message "Rcirc-Omit mode enabled")) + (remove-from-invisibility-spec '(rcirc-omit . nil)) + (message "Rcirc-Omit mode disabled")) + (dolist (window (get-buffer-window-list (current-buffer))) + (with-selected-window window + (recenter (when (> (point) rcirc-prompt-start-marker) -1))))) + +(defcustom rcirc-time-format "%H:%M " + "Describes how timestamps are printed. +Used as the first arg to `format-time-string'." + :type 'string + :group 'rcirc) + +(defcustom rcirc-input-ring-size 1024 + "Size of input history ring." + :type 'integer + :group 'rcirc) + +(defcustom rcirc-read-only-flag t + "Non-nil means make text in IRC buffers read-only." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-buffer-maximum-lines nil + "The maximum size in lines for rcirc buffers. +Channel buffers are truncated from the top to be no greater than this +number. If zero or nil, no truncating is done." + :type '(choice (const :tag "No truncation" nil) + (integer :tag "Number of lines")) + :group 'rcirc) + +(defcustom rcirc-scroll-show-maximum-output t + "If non-nil, scroll buffer to keep the point at the bottom of +the window." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-authinfo nil + "List of authentication passwords. +Each element of the list is a list with a SERVER-REGEXP string +and a method symbol followed by method specific arguments. + +The valid METHOD symbols are `nickserv', `chanserv' and +`bitlbee'. + +The ARGUMENTS for each METHOD symbol are: + `nickserv': NICK PASSWORD [NICKSERV-NICK] + `chanserv': NICK CHANNEL PASSWORD + `bitlbee': NICK PASSWORD + `quakenet': ACCOUNT PASSWORD + +Examples: + ((\"freenode\" nickserv \"bob\" \"p455w0rd\") + (\"freenode\" chanserv \"bob\" \"#bobland\" \"passwd99\") + (\"bitlbee\" bitlbee \"robert\" \"sekrit\") + (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\") + (\"quakenet.org\" quakenet \"bobby\" \"sekrit\"))" + :type '(alist :key-type (string :tag "Server") + :value-type (choice (list :tag "NickServ" + (const nickserv) + (string :tag "Nick") + (string :tag "Password")) + (list :tag "ChanServ" + (const chanserv) + (string :tag "Nick") + (string :tag "Channel") + (string :tag "Password")) + (list :tag "BitlBee" + (const bitlbee) + (string :tag "Nick") + (string :tag "Password")) + (list :tag "QuakeNet" + (const quakenet) + (string :tag "Account") + (string :tag "Password")))) + :group 'rcirc) + +(defcustom rcirc-auto-authenticate-flag t + "Non-nil means automatically send authentication string to server. +See also `rcirc-authinfo'." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-authenticate-before-join t + "Non-nil means authenticate to services before joining channels. +Currently only works with NickServ on some networks." + :version "24.1" + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-prompt "> " + "Prompt string to use in IRC buffers. + +The following replacements are made: +%n is your nick. +%s is the server. +%t is the buffer target, a channel or a user. + +Setting this alone will not affect the prompt; +use either M-x customize or also call `rcirc-update-prompt'." + :type 'string + :set 'rcirc-set-changed + :initialize 'custom-initialize-default + :group 'rcirc) + +(defcustom rcirc-keywords nil + "List of keywords to highlight in message text." + :type '(repeat string) + :group 'rcirc) + +(defcustom rcirc-ignore-list () + "List of ignored nicks. +Use /ignore to list them, use /ignore NICK to add or remove a nick." + :type '(repeat string) + :group 'rcirc) + +(defvar rcirc-ignore-list-automatic () + "List of ignored nicks added to `rcirc-ignore-list' because of renaming. +When an ignored person renames, their nick is added to both lists. +Nicks will be removed from the automatic list on follow-up renamings or +parts.") + +(defcustom rcirc-bright-nicks nil + "List of nicks to be emphasized. +See `rcirc-bright-nick' face." + :type '(repeat string) + :group 'rcirc) + +(defcustom rcirc-dim-nicks nil + "List of nicks to be deemphasized. +See `rcirc-dim-nick' face." + :type '(repeat string) + :group 'rcirc) + +(define-obsolete-variable-alias 'rcirc-print-hooks + 'rcirc-print-functions "24.3") +(defcustom rcirc-print-functions nil + "Hook run after text is printed. +Called with 5 arguments, PROCESS, SENDER, RESPONSE, TARGET and TEXT." + :type 'hook + :group 'rcirc) + +(defvar rcirc-authenticated-hook nil + "Hook run after successfully authenticated.") + +(defcustom rcirc-always-use-server-buffer-flag nil + "Non-nil means messages without a channel target will go to the server buffer." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-decode-coding-system 'utf-8 + "Coding system used to decode incoming irc messages. +Set to `undecided' if you want the encoding of the incoming +messages autodetected." + :type 'coding-system + :group 'rcirc) + +(defcustom rcirc-encode-coding-system 'utf-8 + "Coding system used to encode outgoing irc messages." + :type 'coding-system + :group 'rcirc) + +(defcustom rcirc-coding-system-alist nil + "Alist to decide a coding system to use for a channel I/O operation. +The format is ((PATTERN . VAL) ...). +PATTERN is either a string or a cons of strings. +If PATTERN is a string, it is used to match a target. +If PATTERN is a cons of strings, the car part is used to match a +target, and the cdr part is used to match a server. +VAL is either a coding system or a cons of coding systems. +If VAL is a coding system, it is used for both decoding and encoding +messages. +If VAL is a cons of coding systems, the car part is used for decoding, +and the cdr part is used for encoding." + :type '(alist :key-type (choice (string :tag "Channel Regexp") + (cons (string :tag "Channel Regexp") + (string :tag "Server Regexp"))) + :value-type (choice coding-system + (cons (coding-system :tag "Decode") + (coding-system :tag "Encode")))) + :group 'rcirc) + +(defcustom rcirc-multiline-major-mode 'fundamental-mode + "Major-mode function to use in multiline edit buffers." + :type 'function + :group 'rcirc) + +(defcustom rcirc-nick-completion-format "%s: " + "Format string to use in nick completions. + +The format string is only used when completing at the beginning +of a line. The string is passed as the first argument to +`format' with the nickname as the second argument." + :version "24.1" + :type 'string + :group 'rcirc) + +(defcustom rcirc-kill-channel-buffers nil + "When non-nil, kill channel buffers when the server buffer is killed. +Only the channel buffers associated with the server in question +will be killed." + :version "24.3" + :type 'boolean + :group 'rcirc) + +(defvar rcirc-nick nil) + +(defvar rcirc-prompt-end-marker nil) + +(defvar rcirc-nick-table nil) + +(defvar rcirc-recent-quit-alist nil + "Alist of nicks that have recently quit or parted the channel.") + +(defvar rcirc-nick-syntax-table + (let ((table (make-syntax-table text-mode-syntax-table))) + (mapc (lambda (c) (modify-syntax-entry c "w" table)) + "[]\\`_^{|}-") + (modify-syntax-entry ?' "_" table) + table) + "Syntax table which includes all nick characters as word constituents.") + +;; each process has an alist of (target . buffer) pairs +(defvar rcirc-buffer-alist nil) + +(defvar rcirc-activity nil + "List of buffers with unviewed activity.") + +(defvar rcirc-activity-string "" + "String displayed in mode line representing `rcirc-activity'.") +(put 'rcirc-activity-string 'risky-local-variable t) + +(defvar rcirc-server-buffer nil + "The server buffer associated with this channel buffer.") + +(defvar rcirc-target nil + "The channel or user associated with this buffer.") + +(defvar rcirc-urls nil + "List of URLs seen in the current buffer and their start positions.") +(put 'rcirc-urls 'permanent-local t) + +(defvar rcirc-timeout-seconds 600 + "Kill connection after this many seconds if there is no activity.") + +(defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version)) + +(defvar rcirc-startup-channels nil) + +(defvar rcirc-server-name-history nil + "History variable for \\[rcirc] call.") + +(defvar rcirc-server-port-history nil + "History variable for \\[rcirc] call.") + +(defvar rcirc-nick-name-history nil + "History variable for \\[rcirc] call.") + +(defvar rcirc-user-name-history nil + "History variable for \\[rcirc] call.") + +(defvar rcirc-last-message-time nil) + +;;;###autoload +(defun rcirc (arg) + "Connect to all servers in `rcirc-server-alist'. + +Do not connect to a server if it is already connected. + +If ARG is non-nil, instead prompt for connection parameters." + (interactive "P") + (if arg + (let* ((server (completing-read "IRC Server: " + rcirc-server-alist + nil nil + (caar rcirc-server-alist) + 'rcirc-server-name-history)) + (server-plist (cdr (assoc-string server rcirc-server-alist))) + (port (read-string "IRC Port: " + (number-to-string + (or (plist-get server-plist :port) + rcirc-default-port)) + 'rcirc-server-port-history)) + (nick (read-string "IRC Nick: " + (or (plist-get server-plist :nick) + rcirc-default-nick) + 'rcirc-nick-name-history)) + (user-name (read-string "IRC Username: " + (or (plist-get server-plist :user-name) + rcirc-default-user-name) + 'rcirc-user-name-history)) + (password (read-passwd "IRC Password: " nil + (plist-get server-plist :password))) + (channels (split-string + (read-string "IRC Channels: " + (mapconcat 'identity + (plist-get server-plist + :channels) + " ")) + "[, ]+" t)) + (encryption (rcirc-prompt-for-encryption server-plist))) + (rcirc-connect server port nick user-name + rcirc-default-full-name + channels password encryption)) + ;; connect to servers in `rcirc-server-alist' + (let (connected-servers) + (dolist (c rcirc-server-alist) + (let ((server (car c)) + (nick (or (plist-get (cdr c) :nick) rcirc-default-nick)) + (port (or (plist-get (cdr c) :port) rcirc-default-port)) + (user-name (or (plist-get (cdr c) :user-name) + rcirc-default-user-name)) + (full-name (or (plist-get (cdr c) :full-name) + rcirc-default-full-name)) + (channels (plist-get (cdr c) :channels)) + (password (plist-get (cdr c) :password)) + (encryption (plist-get (cdr c) :encryption)) + (server-alias (plist-get (cdr c) :server-alias)) + contact) + (when server + (let (connected) + (dolist (p (rcirc-process-list)) + (when (string= (or server-alias server) (process-name p)) + (setq connected p))) + (if (not connected) + (condition-case nil + (rcirc-connect server port nick user-name + full-name channels password encryption + server-alias) + (quit (message "Quit connecting to %s" + (or server-alias server)))) + (with-current-buffer (process-buffer connected) + (setq contact (process-contact + (get-buffer-process (current-buffer)) :name)) + (setq connected-servers + (cons (if (stringp contact) + contact (or server-alias server)) + connected-servers)))))))) + (when connected-servers + (message "Already connected to %s" + (if (cdr connected-servers) + (concat (mapconcat 'identity (butlast connected-servers) ", ") + ", and " + (car (last connected-servers))) + (car connected-servers))))))) + +;;;###autoload +(defalias 'irc 'rcirc) + + +(defvar rcirc-process-output nil) +(defvar rcirc-topic nil) +(defvar rcirc-keepalive-timer nil) +(defvar rcirc-last-server-message-time nil) +(defvar rcirc-server nil) ; server provided by server +(defvar rcirc-server-name nil) ; server name given by 001 response +(defvar rcirc-timeout-timer nil) +(defvar rcirc-user-authenticated nil) +(defvar rcirc-user-disconnect nil) +(defvar rcirc-connecting nil) +(defvar rcirc-connection-info nil) +(defvar rcirc-process nil) + +;;;###autoload +(defun rcirc-connect (server &optional port nick user-name + full-name startup-channels password encryption + server-alias) + (save-excursion + (message "Connecting to %s..." (or server-alias server)) + (let* ((inhibit-eol-conversion) + (port-number (if port + (if (stringp port) + (string-to-number port) + port) + rcirc-default-port)) + (nick (or nick rcirc-default-nick)) + (user-name (or user-name rcirc-default-user-name)) + (full-name (or full-name rcirc-default-full-name)) + (startup-channels startup-channels) + (process (open-network-stream + (or server-alias server) nil server port-number + :type (or encryption 'plain)))) + ;; set up process + (set-process-coding-system process 'raw-text 'raw-text) + (switch-to-buffer (rcirc-generate-new-buffer-name process nil)) + (set-process-buffer process (current-buffer)) + (rcirc-mode process nil) + (set-process-sentinel process 'rcirc-sentinel) + (set-process-filter process 'rcirc-filter) + + (setq-local rcirc-connection-info + (list server port nick user-name full-name startup-channels + password encryption server-alias)) + (setq-local rcirc-process process) + (setq-local rcirc-server server) + (setq-local rcirc-server-name + (or server-alias server)) ; Update when we get 001 response. + (setq-local rcirc-buffer-alist nil) + (setq-local rcirc-nick-table (make-hash-table :test 'equal)) + (setq-local rcirc-nick nick) + (setq-local rcirc-process-output nil) + (setq-local rcirc-startup-channels startup-channels) + (setq-local rcirc-last-server-message-time (current-time)) + + (setq-local rcirc-timeout-timer nil) + (setq-local rcirc-user-disconnect nil) + (setq-local rcirc-user-authenticated nil) + (setq-local rcirc-connecting t) + + (add-hook 'auto-save-hook 'rcirc-log-write) + + ;; identify + (unless (zerop (length password)) + (rcirc-send-string process (concat "PASS " password))) + (rcirc-send-string process (concat "NICK " nick)) + (rcirc-send-string process "CAP LS 302") + (rcirc-send-string process (concat "USER " user-name + " 0 * :" full-name)) + + ;; setup ping timer if necessary + (unless rcirc-keepalive-timer + (setq rcirc-keepalive-timer + (run-at-time 0 (/ rcirc-timeout-seconds 2) 'rcirc-keepalive))) + + (message "Connecting to %s...done" (or server-alias server)) + + ;; return process object + process))) + +(defmacro with-rcirc-process-buffer (process &rest body) + (declare (indent 1) (debug t)) + `(with-current-buffer (process-buffer ,process) + ,@body)) + +(defmacro with-rcirc-server-buffer (&rest body) + (declare (indent 0) (debug t)) + `(with-current-buffer rcirc-server-buffer + ,@body)) + +(define-obsolete-function-alias 'rcirc-float-time 'float-time "26.1") + +(defun rcirc-prompt-for-encryption (server-plist) + "Prompt the user for the encryption method to use. +SERVER-PLIST is the property list for the server." + (let ((msg "Encryption (default %s): ") + (choices '("plain" "tls")) + (default (or (plist-get server-plist :encryption) + 'plain))) + (intern + (completing-read (format msg default) + choices nil t nil nil (symbol-name default))))) + +(defun rcirc-keepalive () + "Send keep alive pings to active rcirc processes. +Kill processes that have not received a server message since the +last ping." + (if (rcirc-process-list) + (mapc (lambda (process) + (with-rcirc-process-buffer process + (when (not rcirc-connecting) + (rcirc-send-ctcp process + rcirc-nick + (format "KEEPALIVE %f" + (float-time)))))) + (rcirc-process-list)) + ;; no processes, clean up timer + (when (timerp rcirc-keepalive-timer) + (cancel-timer rcirc-keepalive-timer)) + (setq rcirc-keepalive-timer nil))) + +(defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message) + (with-rcirc-process-buffer process + (setq header-line-format (format "%f" (- (float-time) + (string-to-number message)))))) + +(defvar rcirc-debug-buffer "*rcirc debug*") +(defvar rcirc-debug-flag nil + "If non-nil, write information to `rcirc-debug-buffer'.") +(defun rcirc-debug (process text) + "Add an entry to the debug log including PROCESS and TEXT. +Debug text is written to `rcirc-debug-buffer' if `rcirc-debug-flag' +is non-nil." + (when rcirc-debug-flag + (with-current-buffer (get-buffer-create rcirc-debug-buffer) + (goto-char (point-max)) + (insert (concat + "[" + (format-time-string "%Y-%m-%dT%T ") (process-name process) + "] " + text))))) + +(define-obsolete-variable-alias 'rcirc-sentinel-hooks + 'rcirc-sentinel-functions "24.3") +(defvar rcirc-sentinel-functions nil + "Hook functions called when the process sentinel is called. +Functions are called with PROCESS and SENTINEL arguments.") + +(defcustom rcirc-reconnect-delay 0 + "The minimum interval in seconds between reconnect attempts. +When 0, do not auto-reconnect." + :version "25.1" + :type 'integer + :group 'rcirc) + +(defvar rcirc-last-connect-time nil + "The last time the buffer was connected.") + +(defun rcirc-sentinel (process sentinel) + "Called when PROCESS receives SENTINEL." + (let ((sentinel (replace-regexp-in-string "\n" "" sentinel))) + (rcirc-debug process (format "SENTINEL: %S %S\n" process sentinel)) + (with-rcirc-process-buffer process + (dolist (buffer (cons nil (mapcar 'cdr rcirc-buffer-alist))) + (with-current-buffer (or buffer (current-buffer)) + (rcirc-print process "rcirc.el" "ERROR" rcirc-target + (format "%s: %s (%S)" + (process-name process) + sentinel + (process-status process)) + (not rcirc-target)) + (rcirc-disconnect-buffer))) + (when (and (string= sentinel "deleted") + (< 0 rcirc-reconnect-delay)) + (let ((now (current-time))) + (when (or (null rcirc-last-connect-time) + (< rcirc-reconnect-delay + (float-time (time-subtract now rcirc-last-connect-time)))) + (setq rcirc-last-connect-time now) + (rcirc-cmd-reconnect nil)))) + (run-hook-with-args 'rcirc-sentinel-functions process sentinel)))) + +(defun rcirc-disconnect-buffer (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + ;; set rcirc-target to nil for each channel so cleanup + ;; doesn't happen when we reconnect + (setq rcirc-target nil) + (setq mode-line-process ":disconnected"))) + +(defun rcirc-process-list () + "Return a list of rcirc processes." + (let (ps) + (mapc (lambda (p) + (when (buffer-live-p (process-buffer p)) + (with-rcirc-process-buffer p + (when (eq major-mode 'rcirc-mode) + (setq ps (cons p ps)))))) + (process-list)) + ps)) + +(define-obsolete-variable-alias 'rcirc-receive-message-hooks + 'rcirc-receive-message-functions "24.3") +(defvar rcirc-receive-message-functions nil + "Hook functions run when a message is received from server. +Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") +(defun rcirc-filter (process output) + "Called when PROCESS receives OUTPUT." + (rcirc-debug process output) + (rcirc-reschedule-timeout process) + (with-rcirc-process-buffer process + (setq rcirc-last-server-message-time (current-time)) + (setq rcirc-process-output (concat rcirc-process-output output)) + (when (= ?\n (aref rcirc-process-output + (1- (length rcirc-process-output)))) + (let ((lines (split-string rcirc-process-output "[\n\r]" t))) + (setq rcirc-process-output nil) + (dolist (line lines) + (rcirc-process-server-response process line)))))) + +(defun rcirc-reschedule-timeout (process) + (with-rcirc-process-buffer process + (when (not rcirc-connecting) + (with-rcirc-process-buffer process + (when rcirc-timeout-timer (cancel-timer rcirc-timeout-timer)) + (setq rcirc-timeout-timer (run-at-time rcirc-timeout-seconds nil + 'rcirc-delete-process + process)))))) + +(defun rcirc-delete-process (process) + (delete-process process)) + +(defvar rcirc-trap-errors-flag t) +(defun rcirc-process-server-response (process text) + (if rcirc-trap-errors-flag + (condition-case err + (rcirc-process-server-response-1 process text) + (error + (rcirc-print process "RCIRC" "ERROR" nil + (format "\"%s\" %s" text err) t))) + (rcirc-process-server-response-1 process text))) + +(defun rcirc-handle-message-tags (tags) + (if-let* ((time (cdr (assoc "time" tags))) + (timestamp (floor (float-time (date-to-time time))))) + (setq rcirc-last-message-time timestamp))) + +(defun rcirc-parse-tags (tags) + "Parse TAGS message prefix." + (mapcar (lambda (tag) + (let ((p (split-string tag "="))) + `(,(car p) . ,(cadr p)))) + (split-string tags ";"))) + +(defun rcirc-process-server-response-1 (process text) + + ;; attempt to extract and handle IRCv3 message tags (which contain server-time) + (if (string-match "^\\(@\\([^ ]+\\) \\)?\\(\\(:[^ ]+ \\)?[^ ]+ .+\\)$" text) + (let ((tags (match-string 2 text)) + (rest (match-string 3 text))) + (when tags + (rcirc-handle-message-tags (rcirc-parse-tags tags))) + (setq text rest))) + + (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\) \\(.+\\)$" text) + (let* ((user (match-string 2 text)) + (sender (rcirc-user-nick user)) + (cmd (match-string 3 text)) + (args (match-string 4 text)) + (handler (intern-soft (concat "rcirc-handler-" cmd)))) + (string-match "^\\([^:]*\\):?\\(.+\\)?$" args) + (let* ((args1 (match-string 1 args)) + (args2 (match-string 2 args)) + (args (delq nil (append (split-string args1 " " t) + (list args2))))) + (if (not (fboundp handler)) + (rcirc-handler-generic process cmd sender args text) + (funcall handler process sender args text)) + (run-hook-with-args 'rcirc-receive-message-functions + process cmd sender args text))) + (message "UNHANDLED: %s" text))) + +(defvar rcirc-responses-no-activity '("305" "306") + "Responses that don't trigger activity in the mode-line indicator.") + +(defun rcirc-handler-generic (process response sender args _text) + "Generic server response handler." + (rcirc-print process sender response nil + (mapconcat 'identity (cdr args) " ") + (not (member response rcirc-responses-no-activity)))) + +(defun rcirc--connection-open-p (process) + (memq (process-status process) '(run open))) + +(defun rcirc-send-string (process string) + "Send PROCESS a STRING plus a newline." + (let ((string (concat (encode-coding-string string rcirc-encode-coding-system) + "\n"))) + (unless (rcirc--connection-open-p process) + (error "Network connection to %s is not open" + (process-name process))) + (rcirc-debug process string) + (process-send-string process string))) + +(defun rcirc-send-privmsg (process target string) + (rcirc-send-string process (format "PRIVMSG %s :%s" target string))) + +(defun rcirc-send-ctcp (process target request &optional args) + (let ((args (if args (concat " " args) ""))) + (rcirc-send-privmsg process target + (format "\C-a%s%s\C-a" request args)))) + +(defun rcirc-buffer-process (&optional buffer) + "Return the process associated with channel BUFFER. +With no argument or nil as argument, use the current buffer." + (let ((buffer (or buffer (and (buffer-live-p rcirc-server-buffer) + rcirc-server-buffer)))) + (if buffer + (with-current-buffer buffer rcirc-process) + rcirc-process))) + +(defun rcirc-server-name (process) + "Return PROCESS server name, given by the 001 response." + (with-rcirc-process-buffer process + (or rcirc-server-name + (warn "server name for process %S unknown" process)))) + +(defun rcirc-nick (process) + "Return PROCESS nick." + (with-rcirc-process-buffer process + (or rcirc-nick rcirc-default-nick))) + +(defun rcirc-buffer-nick (&optional buffer) + "Return the nick associated with BUFFER. +With no argument or nil as argument, use the current buffer." + (with-current-buffer (or buffer (current-buffer)) + (with-current-buffer rcirc-server-buffer + (or rcirc-nick rcirc-default-nick)))) + +(defvar rcirc-max-message-length 420 + "Messages longer than this value will be split.") + +(defun rcirc-split-message (message) + "Split MESSAGE into chunks within `rcirc-max-message-length'." + ;; `rcirc-encode-coding-system' can have buffer-local value. + (let ((encoding rcirc-encode-coding-system)) + (with-temp-buffer + (insert message) + (goto-char (point-min)) + (let (result) + (while (not (eobp)) + (goto-char (or (byte-to-position rcirc-max-message-length) + (point-max))) + ;; max message length is 512 including CRLF + (while (and (not (bobp)) + (> (length (encode-coding-region + (point-min) (point) encoding t)) + rcirc-max-message-length)) + (forward-char -1)) + (push (delete-and-extract-region (point-min) (point)) result)) + (nreverse result))))) + +(defun rcirc-send-message (process target message &optional noticep silent) + "Send TARGET associated with PROCESS a privmsg with text MESSAGE. +If NOTICEP is non-nil, send a notice instead of privmsg. +If SILENT is non-nil, do not print the message in any irc buffer." + (let ((response (if noticep "NOTICE" "PRIVMSG"))) + (rcirc-get-buffer-create process target) + (dolist (msg (rcirc-split-message message)) + (rcirc-send-string process (concat response " " target " :" msg)) + (unless silent + (rcirc-print process (rcirc-nick process) response target msg))))) + +(defvar rcirc-input-ring nil) +(defvar rcirc-input-ring-index 0) + +(defun rcirc-prev-input-string (arg) + (ring-ref rcirc-input-ring (+ rcirc-input-ring-index arg))) + +(defun rcirc-insert-prev-input () + (interactive) + (when (<= rcirc-prompt-end-marker (point)) + (delete-region rcirc-prompt-end-marker (point-max)) + (insert (rcirc-prev-input-string 0)) + (setq rcirc-input-ring-index (1+ rcirc-input-ring-index)))) + +(defun rcirc-insert-next-input () + (interactive) + (when (<= rcirc-prompt-end-marker (point)) + (delete-region rcirc-prompt-end-marker (point-max)) + (setq rcirc-input-ring-index (1- rcirc-input-ring-index)) + (insert (rcirc-prev-input-string -1)))) + +(defvar rcirc-server-commands + '("/admin" "/away" "/connect" "/die" "/error" "/info" + "/invite" "/ison" "/join" "/kick" "/kill" "/links" + "/list" "/lusers" "/mode" "/motd" "/names" "/nick" + "/notice" "/oper" "/part" "/pass" "/ping" "/pong" + "/privmsg" "/quit" "/rehash" "/restart" "/service" "/servlist" + "/server" "/squery" "/squit" "/stats" "/summon" "/time" + "/topic" "/trace" "/user" "/userhost" "/users" "/version" + "/wallops" "/who" "/whois" "/whowas") + "A list of user commands by IRC server. +The value defaults to RFCs 1459 and 2812.") + +;; /me and /ctcp are not defined by `defun-rcirc-command'. +(defvar rcirc-client-commands '("/me" "/ctcp") + "A list of user commands defined by IRC client rcirc. +The list is updated automatically by `defun-rcirc-command'.") + +(defun rcirc-completion-at-point () + "Function used for `completion-at-point-functions' in `rcirc-mode'." + (and (rcirc-looking-at-input) + (let* ((beg (save-excursion + ;; On some networks it is common to message or + ;; mention someone using @nick instead of just + ;; nick. + (if (re-search-backward "[[:space:]@]" rcirc-prompt-end-marker t) + (1+ (point)) + rcirc-prompt-end-marker))) + (table (if (and (= beg rcirc-prompt-end-marker) + (eq (char-after beg) ?/)) + (delete-dups + (nconc (sort (copy-sequence rcirc-client-commands) + 'string-lessp) + (sort (copy-sequence rcirc-server-commands) + 'string-lessp))) + (rcirc-channel-nicks (rcirc-buffer-process) + rcirc-target)))) + (list beg (point) table)))) + +(defvar rcirc-completions nil) +(defvar rcirc-completion-start nil) + +(defun rcirc-complete () + "Cycle through completions from list of nicks in channel or IRC commands. +IRC command completion is performed only if `/' is the first input char." + (interactive) + (unless (rcirc-looking-at-input) + (error "Point not located after rcirc prompt")) + (if (eq last-command this-command) + (setq rcirc-completions + (append (cdr rcirc-completions) (list (car rcirc-completions)))) + (let ((completion-ignore-case t) + (table (rcirc-completion-at-point))) + (setq rcirc-completion-start (car table)) + (setq rcirc-completions + (and rcirc-completion-start + (all-completions (buffer-substring rcirc-completion-start + (cadr table)) + (nth 2 table)))))) + (let ((completion (car rcirc-completions))) + (when completion + (delete-region rcirc-completion-start (point)) + (insert + (cond + ((= (aref completion 0) ?/) (concat completion " ")) + ((= rcirc-completion-start rcirc-prompt-end-marker) + (format rcirc-nick-completion-format completion)) + (t completion)))))) + +(defun set-rcirc-decode-coding-system (coding-system) + "Set the decode coding system used in this channel." + (interactive "zCoding system for incoming messages: ") + (setq-local rcirc-decode-coding-system coding-system)) + +(defun set-rcirc-encode-coding-system (coding-system) + "Set the encode coding system used in this channel." + (interactive "zCoding system for outgoing messages: ") + (setq-local rcirc-encode-coding-system coding-system)) + +(defvar rcirc-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'rcirc-send-input) + (define-key map (kbd "M-p") 'rcirc-insert-prev-input) + (define-key map (kbd "M-n") 'rcirc-insert-next-input) + (define-key map (kbd "TAB") 'rcirc-complete) + (define-key map (kbd "C-c C-b") 'rcirc-browse-url) + (define-key map (kbd "C-c C-c") 'rcirc-edit-multiline) + (define-key map (kbd "C-c C-j") 'rcirc-cmd-join) + (define-key map (kbd "C-c C-k") 'rcirc-cmd-kick) + (define-key map (kbd "C-c C-l") 'rcirc-toggle-low-priority) + (define-key map (kbd "C-c C-d") 'rcirc-cmd-mode) + (define-key map (kbd "C-c C-m") 'rcirc-cmd-msg) + (define-key map (kbd "C-c C-r") 'rcirc-cmd-nick) ; rename + (define-key map (kbd "C-c C-o") 'rcirc-omit-mode) + (define-key map (kbd "C-c C-p") 'rcirc-cmd-part) + (define-key map (kbd "C-c C-q") 'rcirc-cmd-query) + (define-key map (kbd "C-c C-t") 'rcirc-cmd-topic) + (define-key map (kbd "C-c C-n") 'rcirc-cmd-names) + (define-key map (kbd "C-c C-w") 'rcirc-cmd-whois) + (define-key map (kbd "C-c C-x") 'rcirc-cmd-quit) + (define-key map (kbd "C-c TAB") ; C-i + 'rcirc-toggle-ignore-buffer-activity) + (define-key map (kbd "C-c C-s") 'rcirc-switch-to-server-buffer) + (define-key map (kbd "C-c C-a") 'rcirc-jump-to-first-unread-line) + map) + "Keymap for rcirc mode.") + +(defvar rcirc-short-buffer-name nil + "Generated abbreviation to use to indicate buffer activity.") + +(defvar rcirc-mode-hook nil + "Hook run when setting up rcirc buffer.") + +(defvar rcirc-last-post-time nil) + +(defvar rcirc-log-alist nil + "Alist of lines to log to disk when `rcirc-log-flag' is non-nil. +Each element looks like (FILENAME . TEXT).") + +(defvar rcirc-current-line 0 + "The current number of responses printed in this channel. +This number is independent of the number of lines in the buffer.") + +(defun rcirc-mode (process target) + ;; FIXME: Use define-derived-mode. + "Major mode for IRC channel buffers. + +\\{rcirc-mode-map}" + (kill-all-local-variables) + (use-local-map rcirc-mode-map) + (setq mode-name "rcirc") + (setq major-mode 'rcirc-mode) + (setq mode-line-process nil) + + (setq-local rcirc-input-ring + ;; If rcirc-input-ring is already a ring with desired + ;; size do not re-initialize. + (if (and (ring-p rcirc-input-ring) + (= (ring-size rcirc-input-ring) + rcirc-input-ring-size)) + rcirc-input-ring + (make-ring rcirc-input-ring-size))) + (setq-local rcirc-server-buffer (process-buffer process)) + (setq-local rcirc-target target) + (setq-local rcirc-topic nil) + (setq-local rcirc-last-post-time (current-time)) + (setq-local fill-paragraph-function 'rcirc-fill-paragraph) + (setq-local rcirc-recent-quit-alist nil) + (setq-local rcirc-current-line 0) + (setq-local rcirc-last-connect-time (current-time)) + + (use-hard-newlines t) + (setq-local rcirc-short-buffer-name nil) + (setq-local rcirc-urls nil) + + ;; setup for omitting responses + (setq buffer-invisibility-spec '()) + (setq buffer-display-table (make-display-table)) + (set-display-table-slot buffer-display-table 4 + (let ((glyph (make-glyph-code + ?. 'font-lock-keyword-face))) + (make-vector 3 glyph))) + + (dolist (i rcirc-coding-system-alist) + (let ((chan (if (consp (car i)) (caar i) (car i))) + (serv (if (consp (car i)) (cdar i) ""))) + (when (and (string-match chan (or target "")) + (string-match serv (rcirc-server-name process))) + (setq-local rcirc-decode-coding-system + (if (consp (cdr i)) (cadr i) (cdr i))) + (setq-local rcirc-encode-coding-system + (if (consp (cdr i)) (cddr i) (cdr i)))))) + + ;; setup the prompt and markers + (setq-local rcirc-prompt-start-marker (point-max-marker)) + (setq-local rcirc-prompt-end-marker (point-max-marker)) + (rcirc-update-prompt) + (goto-char rcirc-prompt-end-marker) + + (setq-local overlay-arrow-position (make-marker)) + + ;; if the user changes the major mode or kills the buffer, there is + ;; cleanup work to do + (add-hook 'change-major-mode-hook 'rcirc-change-major-mode-hook nil t) + (add-hook 'kill-buffer-hook 'rcirc-kill-buffer-hook nil t) + + ;; add to buffer list, and update buffer abbrevs + (when target ; skip server buffer + (let ((buffer (current-buffer))) + (with-rcirc-process-buffer process + (setq rcirc-buffer-alist (cons (cons target buffer) + rcirc-buffer-alist)))) + (rcirc-update-short-buffer-names)) + + (add-hook 'completion-at-point-functions + 'rcirc-completion-at-point nil 'local) + + (run-mode-hooks 'rcirc-mode-hook)) + +(defun rcirc-update-prompt (&optional all) + "Reset the prompt string in the current buffer. + +If ALL is non-nil, update prompts in all IRC buffers." + (if all + (mapc (lambda (process) + (mapc (lambda (buffer) + (with-current-buffer buffer + (rcirc-update-prompt))) + (with-rcirc-process-buffer process + (mapcar 'cdr rcirc-buffer-alist)))) + (rcirc-process-list)) + (let ((inhibit-read-only t) + (prompt (or rcirc-prompt ""))) + (mapc (lambda (rep) + (setq prompt + (replace-regexp-in-string (car rep) (cdr rep) prompt))) + (list (cons "%n" (rcirc-buffer-nick)) + (cons "%s" (with-rcirc-server-buffer rcirc-server-name)) + (cons "%t" (or rcirc-target "")))) + (save-excursion + (delete-region rcirc-prompt-start-marker rcirc-prompt-end-marker) + (goto-char rcirc-prompt-start-marker) + (let ((start (point))) + (insert-before-markers prompt) + (set-marker rcirc-prompt-start-marker start) + (when (not (zerop (- rcirc-prompt-end-marker + rcirc-prompt-start-marker))) + (add-text-properties rcirc-prompt-start-marker + rcirc-prompt-end-marker + (list 'face 'rcirc-prompt + 'read-only t 'field t + 'front-sticky t 'rear-nonsticky t)))))))) + +(defun rcirc-set-changed (option value) + "Set OPTION to VALUE and do updates after a customization change." + (set-default option value) + (cond ((eq option 'rcirc-prompt) + (rcirc-update-prompt 'all)) + (t + (error "Bad option %s" option)))) + +(defun rcirc-channel-p (target) + "Return t if TARGET is a channel name." + (and target + (not (zerop (length target))) + (or (eq (aref target 0) ?#) + (eq (aref target 0) ?&)))) + +(defcustom rcirc-log-directory "~/.emacs.d/rcirc-log" + "Directory to keep IRC logfiles." + :type 'directory + :group 'rcirc) + +(defcustom rcirc-log-flag nil + "Non-nil means log IRC activity to disk. +Logfiles are kept in `rcirc-log-directory'." + :type 'boolean + :group 'rcirc) + +(defun rcirc-kill-buffer-hook () + "Part the channel when killing an rcirc buffer. + +If `rcirc-kill-channel-buffers' is non-nil and the killed buffer +is a server buffer, kills all of the channel buffers associated +with it." + (when (eq major-mode 'rcirc-mode) + (when (and rcirc-log-flag + rcirc-log-directory) + (rcirc-log-write)) + (rcirc-clean-up-buffer "Killed buffer") + (when (and rcirc-buffer-alist ;; it's a server buffer + rcirc-kill-channel-buffers) + (dolist (channel rcirc-buffer-alist) + (kill-buffer (cdr channel)))))) + +(defun rcirc-change-major-mode-hook () + "Part the channel when changing the major-mode." + (rcirc-clean-up-buffer "Changed major mode")) + +(defun rcirc-clean-up-buffer (reason) + (let ((buffer (current-buffer))) + (rcirc-clear-activity buffer) + (when (and (rcirc-buffer-process) + (rcirc--connection-open-p (rcirc-buffer-process))) + (with-rcirc-server-buffer + (setq rcirc-buffer-alist + (rassq-delete-all buffer rcirc-buffer-alist))) + (rcirc-update-short-buffer-names) + (if (rcirc-channel-p rcirc-target) + (rcirc-send-string (rcirc-buffer-process) + (concat "PART " rcirc-target " :" reason)) + (when rcirc-target + (rcirc-remove-nick-channel (rcirc-buffer-process) + (rcirc-buffer-nick) + rcirc-target)))) + (setq rcirc-target nil))) + +(defun rcirc-generate-new-buffer-name (process target) + "Return a buffer name based on PROCESS and TARGET. +This is used for the initial name given to IRC buffers." + (substring-no-properties + (if target + (concat target "@" (process-name process)) + (concat "*" (process-name process) "*")))) + +(defun rcirc-get-buffer (process target &optional server) + "Return the buffer associated with the PROCESS and TARGET. + +If optional argument SERVER is non-nil, return the server buffer +if there is no existing buffer for TARGET, otherwise return nil." + (with-rcirc-process-buffer process + (if (null target) + (current-buffer) + (let ((buffer (cdr (assoc-string target rcirc-buffer-alist t)))) + (or buffer (when server (current-buffer))))))) + +(defun rcirc-get-buffer-create (process target) + "Return the buffer associated with the PROCESS and TARGET. +Create the buffer if it doesn't exist." + (let ((buffer (rcirc-get-buffer process target))) + (if (and buffer (buffer-live-p buffer)) + (with-current-buffer buffer + (when (not rcirc-target) + (setq rcirc-target target)) + buffer) + ;; create the buffer + (with-rcirc-process-buffer process + (let ((new-buffer (get-buffer-create + (rcirc-generate-new-buffer-name process target)))) + (with-current-buffer new-buffer + (rcirc-mode process target) + (rcirc-put-nick-channel process (rcirc-nick process) target + rcirc-current-line)) + new-buffer))))) + +(defun rcirc-send-input () + "Send input to target associated with the current buffer." + (interactive) + (if (< (point) rcirc-prompt-end-marker) + ;; copy the line down to the input area + (progn + (forward-line 0) + (let ((start (if (eq (point) (point-min)) + (point) + (if (get-text-property (1- (point)) 'hard) + (point) + (previous-single-property-change (point) 'hard)))) + (end (next-single-property-change (1+ (point)) 'hard))) + (goto-char (point-max)) + (insert (replace-regexp-in-string + "\n\\s-+" " " + (buffer-substring-no-properties start end))))) + ;; process input + (goto-char (point-max)) + (when (not (equal 0 (- (point) rcirc-prompt-end-marker))) + ;; delete a trailing newline + (when (eq (point) (point-at-bol)) + (delete-char -1)) + (let ((input (buffer-substring-no-properties + rcirc-prompt-end-marker (point)))) + (dolist (line (split-string input "\n")) + (rcirc-process-input-line line)) + ;; add to input-ring + (save-excursion + (ring-insert rcirc-input-ring input) + (setq rcirc-input-ring-index 0)))))) + +(defun rcirc-fill-paragraph (&optional justify) + (interactive "P") + (when (> (point) rcirc-prompt-end-marker) + (save-restriction + (narrow-to-region rcirc-prompt-end-marker (point-max)) + (let ((fill-column rcirc-max-message-length)) + (fill-region (point-min) (point-max) justify))))) + +(defun rcirc-process-input-line (line) + (if (string-match "^/\\([^ ]+\\) ?\\(.*\\)$" line) + (rcirc-process-command (match-string 1 line) + (match-string 2 line) + line) + (rcirc-process-message line))) + +(defun rcirc-process-message (line) + (if (not rcirc-target) + (message "Not joined (no target)") + (delete-region rcirc-prompt-end-marker (point)) + (rcirc-send-message (rcirc-buffer-process) rcirc-target line) + (setq rcirc-last-post-time (current-time)))) + +(defun rcirc-process-command (command args line) + (if (eq (aref command 0) ?/) + ;; "//text" will send "/text" as a message + (rcirc-process-message (substring line 1)) + (let ((fun (intern-soft (concat "rcirc-cmd-" command))) + (process (rcirc-buffer-process))) + (newline) + (with-current-buffer (current-buffer) + (delete-region rcirc-prompt-end-marker (point)) + (if (string= command "me") + (rcirc-print process (rcirc-buffer-nick) + "ACTION" rcirc-target args) + (rcirc-print process (rcirc-buffer-nick) + "COMMAND" rcirc-target line)) + (set-marker rcirc-prompt-end-marker (point)) + (if (fboundp fun) + (funcall fun args process rcirc-target) + (rcirc-send-string process + (concat command " :" args))))))) + +(defvar rcirc-parent-buffer nil) +(make-variable-buffer-local 'rcirc-parent-buffer) +(put 'rcirc-parent-buffer 'permanent-local t) +(defvar rcirc-window-configuration nil) +(defun rcirc-edit-multiline () + "Move current edit to a dedicated buffer." + (interactive) + (let ((pos (1+ (- (point) rcirc-prompt-end-marker)))) + (goto-char (point-max)) + (let ((text (buffer-substring-no-properties rcirc-prompt-end-marker + (point))) + (parent (buffer-name))) + (delete-region rcirc-prompt-end-marker (point)) + (setq rcirc-window-configuration (current-window-configuration)) + (pop-to-buffer (concat "*multiline " parent "*")) + (funcall rcirc-multiline-major-mode) + (rcirc-multiline-minor-mode 1) + (setq rcirc-parent-buffer parent) + (insert text) + (and (> pos 0) (goto-char pos)) + (message "Type C-c C-c to return text to %s, or C-c C-k to cancel" parent)))) + +(defvar rcirc-multiline-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-c") 'rcirc-multiline-minor-submit) + (define-key map (kbd "C-x C-s") 'rcirc-multiline-minor-submit) + (define-key map (kbd "C-c C-k") 'rcirc-multiline-minor-cancel) + (define-key map (kbd "ESC ESC ESC") 'rcirc-multiline-minor-cancel) + map) + "Keymap for multiline mode in rcirc.") + +(define-minor-mode rcirc-multiline-minor-mode + "Minor mode for editing multiple lines in rcirc. +With a prefix argument ARG, enable the mode if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil." + :init-value nil + :lighter " rcirc-mline" + :keymap rcirc-multiline-minor-mode-map + :global nil + :group 'rcirc + (setq fill-column rcirc-max-message-length)) + +(defun rcirc-multiline-minor-submit () + "Send the text in buffer back to parent buffer." + (interactive) + (untabify (point-min) (point-max)) + (let ((text (buffer-substring (point-min) (point-max))) + (buffer (current-buffer)) + (pos (point))) + (set-buffer rcirc-parent-buffer) + (goto-char (point-max)) + (insert text) + (kill-buffer buffer) + (set-window-configuration rcirc-window-configuration) + (goto-char (+ rcirc-prompt-end-marker (1- pos))))) + +(defun rcirc-multiline-minor-cancel () + "Cancel the multiline edit." + (interactive) + (kill-buffer (current-buffer)) + (set-window-configuration rcirc-window-configuration)) + +(defun rcirc-any-buffer (process) + "Return a buffer for PROCESS, either the one selected or the process buffer." + (if rcirc-always-use-server-buffer-flag + (process-buffer process) + (let ((buffer (window-buffer))) + (if (and buffer + (with-current-buffer buffer + (and (eq major-mode 'rcirc-mode) + (eq (rcirc-buffer-process) process)))) + buffer + (process-buffer process))))) + +(defcustom rcirc-response-formats + '(("PRIVMSG" . "<%N> %m") + ("NOTICE" . "-%N- %m") + ("ACTION" . "[%N %m]") + ("COMMAND" . "%m") + ("ERROR" . "%fw!!! %m") + (t . "%fp*** %fs%n %r %m")) + "An alist of formats used for printing responses. +The format is looked up using the response-type as a key; +if no match is found, the default entry (with a key of t) is used. + +The entry's value part should be a string, which is inserted with +the of the following escape sequences replaced by the described values: + + %m The message text + %n The sender's nick + %N The sender's nick (with face `rcirc-my-nick' or `rcirc-other-nick') + %r The response-type + %t The target + %fw Following text uses the face `font-lock-warning-face' + %fp Following text uses the face `rcirc-server-prefix' + %fs Following text uses the face `rcirc-server' + %f[FACE] Following text uses the face FACE + %f- Following text uses the default face + %% A literal `%' character" + :type '(alist :key-type (choice (string :tag "Type") + (const :tag "Default" t)) + :value-type string) + :group 'rcirc) + +(defun rcirc-format-response-string (process sender response target text) + "Return a nicely-formatted response string, incorporating TEXT +\(and perhaps other arguments). The specific formatting used +is found by looking up RESPONSE in `rcirc-response-formats'." + (with-temp-buffer + (insert (or (cdr (assoc response rcirc-response-formats)) + (cdr (assq t rcirc-response-formats)))) + (goto-char (point-min)) + (let ((start (point-min)) + (sender (if (or (not sender) + (string= (rcirc-server-name process) sender)) + "" + sender)) + face) + (while (re-search-forward "%\\(\\(f\\(.\\)\\)\\|\\(.\\)\\)" nil t) + (rcirc-add-face start (match-beginning 0) face) + (setq start (match-beginning 0)) + (replace-match + (cl-case (aref (match-string 1) 0) + (?f (setq face + (cl-case (string-to-char (match-string 3)) + (?w 'font-lock-warning-face) + (?p 'rcirc-server-prefix) + (?s 'rcirc-server) + (t nil))) + "") + (?n sender) + (?N (let ((my-nick (rcirc-nick process))) + (save-match-data + (with-syntax-table rcirc-nick-syntax-table + (rcirc-facify sender + (cond ((string= sender my-nick) + 'rcirc-my-nick) + ((and rcirc-bright-nicks + (string-match + (regexp-opt rcirc-bright-nicks + 'words) + sender)) + 'rcirc-bright-nick) + ((and rcirc-dim-nicks + (string-match + (regexp-opt rcirc-dim-nicks + 'words) + sender)) + 'rcirc-dim-nick) + (t + 'rcirc-other-nick))))))) + (?m (propertize text 'rcirc-text text)) + (?r response) + (?t (or target "")) + (t (concat "UNKNOWN CODE:" (match-string 0)))) + t t nil 0) + (rcirc-add-face (match-beginning 0) (match-end 0) face)) + (rcirc-add-face start (match-beginning 0) face)) + (buffer-substring (point-min) (point-max)))) + +(defun rcirc-target-buffer (process sender response target _text) + "Return a buffer to print the server response." + (cl-assert (not (bufferp target))) + (with-rcirc-process-buffer process + (cond ((not target) + (rcirc-any-buffer process)) + ((not (rcirc-channel-p target)) + ;; message from another user + (if (or (string= response "PRIVMSG") + (string= response "ACTION")) + (rcirc-get-buffer-create process (if (string= sender rcirc-nick) + target + sender)) + (rcirc-get-buffer process target t))) + ((or (rcirc-get-buffer process target) + (rcirc-any-buffer process)))))) + +(defvar rcirc-activity-types nil) +(make-variable-buffer-local 'rcirc-activity-types) +(defvar rcirc-last-sender nil) +(make-variable-buffer-local 'rcirc-last-sender) + +(defcustom rcirc-omit-threshold 100 + "Number of lines since last activity from a nick before `rcirc-omit-responses' are omitted." + :type 'integer + :group 'rcirc) + +(defcustom rcirc-log-process-buffers nil + "Non-nil if rcirc process buffers should be logged to disk." + :group 'rcirc + :type 'boolean + :version "24.1") + +(defun rcirc-last-quit-line (process nick target) + "Return the line number where NICK left TARGET. +Returns nil if the information is not recorded." + (let ((chanbuf (rcirc-get-buffer process target))) + (when chanbuf + (cdr (assoc-string nick (with-current-buffer chanbuf + rcirc-recent-quit-alist)))))) + +(defun rcirc-last-line (process nick target) + "Return the line from the last activity from NICK in TARGET." + (let ((line (or (cdr (assoc-string target + (gethash nick (with-rcirc-server-buffer + rcirc-nick-table)) t)) + (rcirc-last-quit-line process nick target)))) + (if line + line + ;;(message "line is nil for %s in %s" nick target) + nil))) + +(defun rcirc-elapsed-lines (process nick target) + "Return the number of lines since activity from NICK in TARGET." + (let ((last-activity-line (rcirc-last-line process nick target))) + (when (and last-activity-line + (> last-activity-line 0)) + (- rcirc-current-line last-activity-line)))) + +(defvar rcirc-markup-text-functions + '(rcirc-markup-attributes + rcirc-markup-my-nick + rcirc-markup-urls + rcirc-markup-keywords + rcirc-markup-bright-nicks) + + "List of functions used to manipulate text before it is printed. + +Each function takes two arguments, SENDER, and RESPONSE. The +buffer is narrowed with the text to be printed and the point is +at the beginning of the `rcirc-text' propertized text.") + +(defun rcirc-print (process sender response target text &optional activity) + "Print TEXT in the buffer associated with TARGET. +Format based on SENDER and RESPONSE. If ACTIVITY is non-nil, +record activity." + (or text (setq text "")) + (unless (and (or (member sender rcirc-ignore-list) + (member (with-syntax-table rcirc-nick-syntax-table + (when (string-match "^\\([^/]\\w*\\)[:,]" text) + (match-string 1 text))) + rcirc-ignore-list)) + ;; do not ignore if we sent the message + (not (string= sender (rcirc-nick process)))) + (let* ((buffer (rcirc-target-buffer process sender response target text)) + (inhibit-read-only t)) + (with-current-buffer buffer + (let ((moving (= (point) rcirc-prompt-end-marker)) + (old-point (point-marker)) + (fill-start (marker-position rcirc-prompt-start-marker))) + + (setq text (decode-coding-string text rcirc-decode-coding-system)) + (unless (string= sender (rcirc-nick process)) + ;; mark the line with overlay arrow + (unless (or (marker-position overlay-arrow-position) + (get-buffer-window (current-buffer)) + (member response rcirc-omit-responses)) + (set-marker overlay-arrow-position + (marker-position rcirc-prompt-start-marker)))) + + ;; temporarily set the marker insertion-type because + ;; insert-before-markers results in hidden text in new buffers + (goto-char rcirc-prompt-start-marker) + (set-marker-insertion-type rcirc-prompt-start-marker t) + (set-marker-insertion-type rcirc-prompt-end-marker t) + + (let ((start (point))) + (insert (rcirc-format-response-string process sender response nil + text) + (propertize "\n" 'hard t)) + + ;; squeeze spaces out of text before rcirc-text + (fill-region fill-start + (1- (or (next-single-property-change fill-start + 'rcirc-text) + rcirc-prompt-end-marker))) + + ;; run markup functions + (save-excursion + (save-restriction + (narrow-to-region start rcirc-prompt-start-marker) + (goto-char (or (next-single-property-change start 'rcirc-text) + (point))) + (when (rcirc-buffer-process) + (save-excursion (rcirc-markup-timestamp sender response)) + (dolist (fn rcirc-markup-text-functions) + (save-excursion (funcall fn sender response))) + (when rcirc-fill-flag + (save-excursion (rcirc-markup-fill sender response)))) + + (when rcirc-read-only-flag + (add-text-properties (point-min) (point-max) + '(read-only t front-sticky t)))) + ;; make text omittable + (let ((last-activity-lines (rcirc-elapsed-lines process sender target))) + (if (and (not (string= (rcirc-nick process) sender)) + (member response rcirc-omit-responses) + (or (not last-activity-lines) + (< rcirc-omit-threshold last-activity-lines))) + (put-text-property (1- start) (1- rcirc-prompt-start-marker) + 'invisible 'rcirc-omit) + ;; otherwise increment the line count + (setq rcirc-current-line (1+ rcirc-current-line)))))) + + (set-marker-insertion-type rcirc-prompt-start-marker nil) + (set-marker-insertion-type rcirc-prompt-end-marker nil) + + ;; truncate buffer if it is very long + (save-excursion + (when (and rcirc-buffer-maximum-lines + (> rcirc-buffer-maximum-lines 0) + (= (forward-line (- rcirc-buffer-maximum-lines)) 0)) + (delete-region (point-min) (point)))) + + ;; set the window point for buffers show in windows + (walk-windows (lambda (w) + (when (and (not (eq (selected-window) w)) + (eq (current-buffer) + (window-buffer w)) + (>= (window-point w) + rcirc-prompt-end-marker)) + (set-window-point w (point-max)))) + nil t) + + ;; restore the point + (goto-char (if moving rcirc-prompt-end-marker old-point)) + + ;; keep window on bottom line if it was already there + (when rcirc-scroll-show-maximum-output + (let ((window (get-buffer-window))) + (when window + (with-selected-window window + (when (eq major-mode 'rcirc-mode) + (when (<= (- (window-height) + (count-screen-lines (window-point) + (window-start)) + 1) + 0) + (recenter -1))))))) + + ;; flush undo (can we do something smarter here?) + (buffer-disable-undo) + (buffer-enable-undo)) + + ;; record mode line activity + (when (and activity + (not rcirc-ignore-buffer-activity-flag) + (not (and rcirc-dim-nicks sender + (string-match (regexp-opt rcirc-dim-nicks) sender) + (rcirc-channel-p target)))) + (rcirc-record-activity (current-buffer) + (when (not (rcirc-channel-p rcirc-target)) + 'nick))) + + (when (and rcirc-log-flag + (or target + rcirc-log-process-buffers)) + (rcirc-log process sender response target text)) + + (sit-for 0) ; displayed text before hook + (run-hook-with-args 'rcirc-print-functions + process sender response target text))))) + +(defun rcirc-generate-log-filename (process target) + (if target + (rcirc-generate-new-buffer-name process target) + (process-name process))) + +(defcustom rcirc-log-filename-function 'rcirc-generate-log-filename + "A function to generate the filename used by rcirc's logging facility. + +It is called with two arguments, PROCESS and TARGET (see +`rcirc-generate-new-buffer-name' for their meaning), and should +return the filename, or nil if no logging is desired for this +session. + +If the returned filename is absolute (`file-name-absolute-p' +returns t), then it is used as-is, otherwise the resulting file +is put into `rcirc-log-directory'. + +The filename is then cleaned using `convert-standard-filename' to +guarantee valid filenames for the current OS." + :group 'rcirc + :type 'function) + +(defun rcirc-log (process sender response target text) + "Record line in `rcirc-log', to be later written to disk." + (let ((filename (funcall rcirc-log-filename-function process target))) + (unless (null filename) + (let ((cell (assoc-string filename rcirc-log-alist)) + (line (concat (format-time-string rcirc-time-format) + (substring-no-properties + (rcirc-format-response-string process sender + response target text)) + "\n"))) + (if cell + (setcdr cell (concat (cdr cell) line)) + (setq rcirc-log-alist + (cons (cons filename line) rcirc-log-alist))))))) + +(defun rcirc-log-write () + "Flush `rcirc-log-alist' data to disk. + +Log data is written to `rcirc-log-directory', except for +log-files with absolute names (see `rcirc-log-filename-function')." + (dolist (cell rcirc-log-alist) + (let ((filename (convert-standard-filename + (expand-file-name (car cell) + rcirc-log-directory))) + (coding-system-for-write 'utf-8)) + (make-directory (file-name-directory filename) t) + (with-temp-buffer + (insert (cdr cell)) + (write-region (point-min) (point-max) filename t 'quiet)))) + (setq rcirc-log-alist nil)) + +(defun rcirc-view-log-file () + "View logfile corresponding to the current buffer." + (interactive) + (find-file-other-window + (expand-file-name (funcall rcirc-log-filename-function + (rcirc-buffer-process) rcirc-target) + rcirc-log-directory))) + +(defun rcirc-join-channels (process channels) + "Join CHANNELS." + (save-window-excursion + (dolist (channel channels) + (with-rcirc-process-buffer process + (rcirc-cmd-join channel process))))) + +;;; nick management +(defvar rcirc-nick-prefix-chars "~&@%+") +(defun rcirc-user-nick (user) + "Return the nick from USER. Remove any non-nick junk." + (save-match-data + (if (string-match (concat "^[" rcirc-nick-prefix-chars + "]?\\([^! ]+\\)!?") (or user "")) + (match-string 1 user) + user))) + +(defun rcirc-nick-channels (process nick) + "Return list of channels for NICK." + (with-rcirc-process-buffer process + (mapcar (lambda (x) (car x)) + (gethash nick rcirc-nick-table)))) + +(defun rcirc-put-nick-channel (process nick channel &optional line) + "Add CHANNEL to list associated with NICK. +Update the associated linestamp if LINE is non-nil. + +If the record doesn't exist, and LINE is nil, set the linestamp +to zero." + (let ((nick (rcirc-user-nick nick))) + (with-rcirc-process-buffer process + (let* ((chans (gethash nick rcirc-nick-table)) + (record (assoc-string channel chans t))) + (if record + (when line (setcdr record line)) + (puthash nick (cons (cons channel (or line 0)) + chans) + rcirc-nick-table)))))) + +(defun rcirc-nick-remove (process nick) + "Remove NICK from table." + (with-rcirc-process-buffer process + (remhash nick rcirc-nick-table))) + +(defun rcirc-remove-nick-channel (process nick channel) + "Remove the CHANNEL from list associated with NICK." + (with-rcirc-process-buffer process + (let* ((chans (gethash nick rcirc-nick-table)) + (newchans + ;; instead of assoc-string-delete-all: + (let ((record (assoc-string channel chans t))) + (when record + (setcar record 'delete) + (assq-delete-all 'delete chans))))) + (if newchans + (puthash nick newchans rcirc-nick-table) + (remhash nick rcirc-nick-table))))) + +(defun rcirc-channel-nicks (process target) + "Return the list of nicks associated with TARGET sorted by last activity." + (when target + (if (rcirc-channel-p target) + (with-rcirc-process-buffer process + (let (nicks) + (maphash + (lambda (k v) + (let ((record (assoc-string target v t))) + (if record + (setq nicks (cons (cons k (cdr record)) nicks))))) + rcirc-nick-table) + (mapcar (lambda (x) (car x)) + (sort nicks (lambda (x y) + (let ((lx (or (cdr x) 0)) + (ly (or (cdr y) 0))) + (< ly lx))))))) + (list target)))) + +(defun rcirc-ignore-update-automatic (nick) + "Remove NICK from `rcirc-ignore-list' +if NICK is also on `rcirc-ignore-list-automatic'." + (when (member nick rcirc-ignore-list-automatic) + (setq rcirc-ignore-list-automatic + (delete nick rcirc-ignore-list-automatic) + rcirc-ignore-list + (delete nick rcirc-ignore-list)))) + +(defun rcirc-nickname< (s1 s2) + "Return t if IRC nickname S1 is less than S2, and nil otherwise. +Operator nicknames (@) are considered less than voiced +nicknames (+). Any other nicknames are greater than voiced +nicknames. The comparison is case-insensitive." + (setq s1 (downcase s1) + s2 (downcase s2)) + (let* ((s1-op (eq ?@ (string-to-char s1))) + (s2-op (eq ?@ (string-to-char s2)))) + (if s1-op + (if s2-op + (string< (substring s1 1) (substring s2 1)) + t) + (if s2-op + nil + (string< s1 s2))))) + +(defun rcirc-sort-nicknames-join (input sep) + "Return a string of sorted nicknames. +INPUT is a string containing nicknames separated by SEP. +This function does not alter the INPUT string." + (let* ((parts (split-string input sep t)) + (sorted (sort parts 'rcirc-nickname<))) + (mapconcat 'identity sorted sep))) + +;;; activity tracking +(defvar rcirc-track-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-@") 'rcirc-next-active-buffer) + (define-key map (kbd "C-c C-SPC") 'rcirc-next-active-buffer) + map) + "Keymap for rcirc track minor mode.") + +;;;###autoload +(define-minor-mode rcirc-track-minor-mode + "Global minor mode for tracking activity in rcirc buffers. +With a prefix argument ARG, enable the mode if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil." + :init-value nil + :lighter "" + :keymap rcirc-track-minor-mode-map + :global t + :group 'rcirc + (or global-mode-string (setq global-mode-string '(""))) + ;; toggle the mode-line channel indicator + (if rcirc-track-minor-mode + (progn + (and (not (memq 'rcirc-activity-string global-mode-string)) + (setq global-mode-string + (append global-mode-string '(rcirc-activity-string)))) + (add-hook 'window-configuration-change-hook + 'rcirc-window-configuration-change)) + (setq global-mode-string + (delete 'rcirc-activity-string global-mode-string)) + (remove-hook 'window-configuration-change-hook + 'rcirc-window-configuration-change))) + +(or (assq 'rcirc-ignore-buffer-activity-flag minor-mode-alist) + (setq minor-mode-alist + (cons '(rcirc-ignore-buffer-activity-flag " Ignore") minor-mode-alist))) +(or (assq 'rcirc-low-priority-flag minor-mode-alist) + (setq minor-mode-alist + (cons '(rcirc-low-priority-flag " LowPri") minor-mode-alist))) + +(defun rcirc-toggle-ignore-buffer-activity () + "Toggle the value of `rcirc-ignore-buffer-activity-flag'." + (interactive) + (setq rcirc-ignore-buffer-activity-flag + (not rcirc-ignore-buffer-activity-flag)) + (message (if rcirc-ignore-buffer-activity-flag + "Ignore activity in this buffer" + "Notice activity in this buffer")) + (force-mode-line-update)) + +(defun rcirc-toggle-low-priority () + "Toggle the value of `rcirc-low-priority-flag'." + (interactive) + (setq rcirc-low-priority-flag + (not rcirc-low-priority-flag)) + (message (if rcirc-low-priority-flag + "Activity in this buffer is low priority" + "Activity in this buffer is normal priority")) + (force-mode-line-update)) + +(defun rcirc-switch-to-server-buffer () + "Switch to the server buffer associated with current channel buffer." + (interactive) + (unless (buffer-live-p rcirc-server-buffer) + (error "No such buffer")) + (switch-to-buffer rcirc-server-buffer)) + +(defun rcirc-jump-to-first-unread-line () + "Move the point to the first unread line in this buffer." + (interactive) + (if (marker-position overlay-arrow-position) + (goto-char overlay-arrow-position) + (message "No unread messages"))) + +(defun rcirc-bury-buffers () + "Bury all RCIRC buffers." + (interactive) + (dolist (buf (buffer-list)) + (when (eq 'rcirc-mode (with-current-buffer buf major-mode)) + (bury-buffer buf) ; buffers not shown + (quit-windows-on buf)))) ; buffers shown in a window + +(defun rcirc-next-active-buffer (arg) + "Switch to the next rcirc buffer with activity. +With prefix ARG, go to the next low priority buffer with activity." + (interactive "P") + (let* ((pair (rcirc-split-activity rcirc-activity)) + (lopri (car pair)) + (hipri (cdr pair))) + (if (or (and (not arg) hipri) + (and arg lopri)) + (progn + (switch-to-buffer (car (if arg lopri hipri))) + (when (> (point) rcirc-prompt-start-marker) + (recenter -1))) + (rcirc-bury-buffers) + (message "No IRC activity.%s" + (if lopri + (concat + " Type C-u " (key-description (this-command-keys)) + " for low priority activity.") + ""))))) + +(define-obsolete-variable-alias 'rcirc-activity-hooks + 'rcirc-activity-functions "24.3") +(defvar rcirc-activity-functions nil + "Hook to be run when there is channel activity. + +Functions are called with a single argument, the buffer with the +activity. Only run if the buffer is not visible and +`rcirc-ignore-buffer-activity-flag' is non-nil.") + +(defun rcirc-record-activity (buffer &optional type) + "Record BUFFER activity with TYPE." + (with-current-buffer buffer + (let ((old-activity rcirc-activity) + (old-types rcirc-activity-types)) + (when (not (get-buffer-window (current-buffer) t)) + (setq rcirc-activity + (sort (if (memq (current-buffer) rcirc-activity) rcirc-activity + (cons (current-buffer) rcirc-activity)) + (lambda (b1 b2) + (let ((t1 (with-current-buffer b1 rcirc-last-post-time)) + (t2 (with-current-buffer b2 rcirc-last-post-time))) + (time-less-p t2 t1))))) + (cl-pushnew type rcirc-activity-types) + (unless (and (equal rcirc-activity old-activity) + (member type old-types)) + (rcirc-update-activity-string))))) + (run-hook-with-args 'rcirc-activity-functions buffer)) + +(defun rcirc-clear-activity (buffer) + "Clear the BUFFER activity." + (setq rcirc-activity (remove buffer rcirc-activity)) + (with-current-buffer buffer + (setq rcirc-activity-types nil))) + +(defun rcirc-clear-unread (buffer) + "Erase the last read message arrow from BUFFER." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (set-marker overlay-arrow-position nil)))) + +(defun rcirc-split-activity (activity) + "Return a cons cell with ACTIVITY split into (lopri . hipri)." + (let (lopri hipri) + (dolist (buf activity) + (with-current-buffer buf + (if (and rcirc-low-priority-flag + (not (member 'nick rcirc-activity-types))) + (push buf lopri) + (push buf hipri)))) + (cons (nreverse lopri) (nreverse hipri)))) + +(defvar rcirc-update-activity-string-hook nil + "Hook run whenever the activity string is updated.") + +;; TODO: add mouse properties +(defun rcirc-update-activity-string () + "Update mode-line string." + (let* ((pair (rcirc-split-activity rcirc-activity)) + (lopri (car pair)) + (hipri (cdr pair))) + (setq rcirc-activity-string + (cond ((or hipri lopri) + (concat (and hipri "[") + (rcirc-activity-string hipri) + (and hipri lopri ",") + (and lopri + (concat "(" + (rcirc-activity-string lopri) + ")")) + (and hipri "]"))) + ((not (null (rcirc-process-list))) + "[]") + (t "[]"))) + (run-hooks 'rcirc-update-activity-string-hook))) + +(defun rcirc-activity-string (buffers) + (mapconcat (lambda (b) + (let ((s (substring-no-properties (rcirc-short-buffer-name b)))) + (with-current-buffer b + (dolist (type rcirc-activity-types) + (rcirc-add-face 0 (length s) + (cl-case type + (nick 'rcirc-track-nick) + (keyword 'rcirc-track-keyword)) + s))) + s)) + buffers ",")) + +(defun rcirc-short-buffer-name (buffer) + "Return a short name for BUFFER to use in the mode line indicator." + (with-current-buffer buffer + (or rcirc-short-buffer-name (buffer-name)))) + +(defun rcirc-visible-buffers () + "Return a list of the visible buffers that are in rcirc-mode." + (let (acc) + (walk-windows (lambda (w) + (with-current-buffer (window-buffer w) + (when (eq major-mode 'rcirc-mode) + (push (current-buffer) acc))))) + acc)) + +(defvar rcirc-visible-buffers nil) +(defun rcirc-window-configuration-change () + (unless (minibuffer-window-active-p (minibuffer-window)) + ;; delay this until command has finished to make sure window is + ;; actually visible before clearing activity + (add-hook 'post-command-hook 'rcirc-window-configuration-change-1))) + +(defun rcirc-window-configuration-change-1 () + ;; clear activity and overlay arrows + (let* ((old-activity rcirc-activity) + (hidden-buffers rcirc-visible-buffers)) + + (setq rcirc-visible-buffers (rcirc-visible-buffers)) + + (dolist (vbuf rcirc-visible-buffers) + (setq hidden-buffers (delq vbuf hidden-buffers)) + ;; clear activity for all visible buffers + (rcirc-clear-activity vbuf)) + + ;; clear unread arrow from recently hidden buffers + (dolist (hbuf hidden-buffers) + (rcirc-clear-unread hbuf)) + + ;; remove any killed buffers from list + (setq rcirc-activity + (delq nil (mapcar (lambda (buf) (when (buffer-live-p buf) buf)) + rcirc-activity))) + ;; update the mode-line string + (unless (equal old-activity rcirc-activity) + (rcirc-update-activity-string))) + + (remove-hook 'post-command-hook 'rcirc-window-configuration-change-1)) + + +;;; buffer name abbreviation +(defun rcirc-update-short-buffer-names () + (let ((bufalist + (apply 'append (mapcar (lambda (process) + (with-rcirc-process-buffer process + rcirc-buffer-alist)) + (rcirc-process-list))))) + (dolist (i (rcirc-abbreviate bufalist)) + (when (buffer-live-p (cdr i)) + (with-current-buffer (cdr i) + (setq rcirc-short-buffer-name (car i))))))) + +(defun rcirc-abbreviate (pairs) + (apply 'append (mapcar 'rcirc-rebuild-tree (rcirc-make-trees pairs)))) + +(defun rcirc-rebuild-tree (tree &optional acc) + (let ((ch (char-to-string (car tree)))) + (dolist (x (cdr tree)) + (if (listp x) + (setq acc (append acc + (mapcar (lambda (y) + (cons (concat ch (car y)) + (cdr y))) + (rcirc-rebuild-tree x)))) + (setq acc (cons (cons ch x) acc)))) + acc)) + +(defun rcirc-make-trees (pairs) + (let (alist) + (mapc (lambda (pair) + (if (consp pair) + (let* ((str (car pair)) + (data (cdr pair)) + (char (unless (zerop (length str)) + (aref str 0))) + (rest (unless (zerop (length str)) + (substring str 1))) + (part (if char (assq char alist)))) + (if part + ;; existing partition + (setcdr part (cons (cons rest data) (cdr part))) + ;; new partition + (setq alist (cons (if char + (list char (cons rest data)) + data) + alist)))) + (setq alist (cons pair alist)))) + pairs) + ;; recurse into cdrs of alist + (mapc (lambda (x) + (when (and (listp x) (listp (cadr x))) + (setcdr x (if (> (length (cdr x)) 1) + (rcirc-make-trees (cdr x)) + (setcdr x (list (cl-cdadr x))))))) + alist))) + +;;; /commands these are called with 3 args: PROCESS, TARGET, which is +;; the current buffer/channel/user, and ARGS, which is a string +;; containing the text following the /cmd. + +(defmacro defun-rcirc-command (command argument docstring interactive-form + &rest body) + "Define a command." + `(progn + (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name command))) + (defun ,(intern (concat "rcirc-cmd-" (symbol-name command))) + (,@argument &optional process target) + ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values given" + "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") + ,interactive-form + (let ((process (or process (rcirc-buffer-process))) + (target (or target rcirc-target))) + (ignore target) ; mark `target' variable as ignorable + ,@body)))) + +(defun-rcirc-command msg (message) + "Send private MESSAGE to TARGET." + (interactive "i") + (if (null message) + (progn + (setq target (completing-read "Message nick: " + (with-rcirc-server-buffer + rcirc-nick-table))) + (when (> (length target) 0) + (setq message (read-string (format "Message %s: " target))) + (when (> (length message) 0) + (rcirc-send-message process target message)))) + (if (not (string-match "\\([^ ]+\\) \\(.+\\)" message)) + (message "Not enough args, or something.") + (setq target (match-string 1 message) + message (match-string 2 message)) + (rcirc-send-message process target message)))) + +(defun-rcirc-command query (nick) + "Open a private chat buffer to NICK." + (interactive (list (completing-read "Query nick: " + (with-rcirc-server-buffer rcirc-nick-table)))) + (let ((existing-buffer (rcirc-get-buffer process nick))) + (switch-to-buffer (or existing-buffer + (rcirc-get-buffer-create process nick))) + (when (not existing-buffer) + (rcirc-cmd-whois nick)))) + +(defun-rcirc-command join (channels) + "Join CHANNELS. +CHANNELS is a comma- or space-separated string of channel names." + (interactive "sJoin channels: ") + (let* ((split-channels (split-string channels "[ ,]" t)) + (buffers (mapcar (lambda (ch) + (rcirc-get-buffer-create process ch)) + split-channels)) + (channels (mapconcat 'identity split-channels ","))) + (rcirc-send-string process (concat "JOIN " channels)) + (when (not (eq (selected-window) (minibuffer-window))) + (dolist (b buffers) ;; order the new channel buffers in the buffer list + (switch-to-buffer b))))) + +(defun-rcirc-command invite (nick-channel) + "Invite NICK to CHANNEL." + (interactive (list + (concat + (completing-read "Invite nick: " + (with-rcirc-server-buffer rcirc-nick-table)) + " " + (read-string "Channel: ")))) + (rcirc-send-string process (concat "INVITE " nick-channel))) + +;; TODO: /part #channel reason, or consider removing #channel altogether +(defun-rcirc-command part (channel) + "Part CHANNEL." + (interactive "sPart channel: ") + (let ((channel (if (> (length channel) 0) channel target))) + (rcirc-send-string process (concat "PART " channel " :" rcirc-id-string)))) + +(defun-rcirc-command quit (reason) + "Send a quit message to server with REASON." + (interactive "sQuit reason: ") + (rcirc-send-string process (concat "QUIT :" + (if (not (zerop (length reason))) + reason + rcirc-id-string)))) + +(defun-rcirc-command reconnect (_) + "Reconnect to current server." + (interactive "i") + (with-rcirc-server-buffer + (cond + (rcirc-connecting (message "Already connecting")) + ((process-live-p process) (message "Server process is alive")) + (t (let ((conn-info rcirc-connection-info)) + (setf (nth 5 conn-info) + (cl-remove-if-not #'rcirc-channel-p + (mapcar #'car rcirc-buffer-alist))) + (apply #'rcirc-connect conn-info)))))) + +(defun-rcirc-command nick (nick) + "Change nick to NICK." + (interactive "i") + (when (null nick) + (setq nick (read-string "New nick: " (rcirc-nick process)))) + (rcirc-send-string process (concat "NICK " nick))) + +(defun-rcirc-command names (channel) + "Display list of names in CHANNEL or in current channel if CHANNEL is nil. +If called interactively, prompt for a channel when prefix arg is supplied." + (interactive "P") + (if (called-interactively-p 'interactive) + (if channel + (setq channel (read-string "List names in channel: " target)))) + (let ((channel (if (> (length channel) 0) + channel + target))) + (rcirc-send-string process (concat "NAMES " channel)))) + +(defun-rcirc-command topic (topic) + "List TOPIC for the TARGET channel. +With a prefix arg, prompt for new topic." + (interactive "P") + (if (and (called-interactively-p 'interactive) topic) + (setq topic (read-string "New Topic: " rcirc-topic))) + (rcirc-send-string process (concat "TOPIC " target + (when (> (length topic) 0) + (concat " :" topic))))) + +(defun-rcirc-command whois (nick) + "Request information from server about NICK." + (interactive (list + (completing-read "Whois: " + (with-rcirc-server-buffer rcirc-nick-table)))) + (rcirc-send-string process (concat "WHOIS " nick))) + +(defun-rcirc-command mode (args) + "Set mode with ARGS." + (interactive (list (concat (read-string "Mode nick or channel: ") + " " (read-string "Mode: ")))) + (rcirc-send-string process (concat "MODE " args))) + +(defun-rcirc-command list (channels) + "Request information on CHANNELS from server." + (interactive "sList Channels: ") + (rcirc-send-string process (concat "LIST " channels))) + +(defun-rcirc-command oper (args) + "Send operator command to server." + (interactive "sOper args: ") + (rcirc-send-string process (concat "OPER " args))) + +(defun-rcirc-command quote (message) + "Send MESSAGE literally to server." + (interactive "sServer message: ") + (rcirc-send-string process message)) + +(defun-rcirc-command kick (arg) + "Kick NICK from current channel." + (interactive (list + (concat (completing-read "Kick nick: " + (rcirc-channel-nicks + (rcirc-buffer-process) + rcirc-target)) + (read-from-minibuffer "Kick reason: ")))) + (let* ((arglist (split-string arg)) + (argstring (concat (car arglist) " :" + (mapconcat 'identity (cdr arglist) " ")))) + (rcirc-send-string process (concat "KICK " target " " argstring)))) + +(defun rcirc-cmd-ctcp (args &optional process _target) + (if (string-match "^\\([^ ]+\\)\\s-+\\(.+\\)$" args) + (let* ((target (match-string 1 args)) + (request (upcase (match-string 2 args))) + (function (intern-soft (concat "rcirc-ctcp-sender-" request)))) + (if (fboundp function) ;; use special function if available + (funcall function process target request) + (rcirc-send-ctcp process target request))) + (rcirc-print process (rcirc-nick process) "ERROR" nil + "usage: /ctcp NICK REQUEST"))) + +(defun rcirc-ctcp-sender-PING (process target _request) + "Send a CTCP PING message to TARGET." + (let ((timestamp (format-time-string "%s"))) + (rcirc-send-ctcp process target "PING" timestamp))) + +(defun rcirc-cmd-me (args &optional process target) + (rcirc-send-ctcp process target "ACTION" args)) + +(defun rcirc-add-or-remove (set &rest elements) + (dolist (elt elements) + (if (and elt (not (string= "" elt))) + (setq set (if (member-ignore-case elt set) + (delete elt set) + (cons elt set))))) + set) + +(defun-rcirc-command ignore (nick) + "Manage the ignore list. +Ignore NICK, unignore NICK if already ignored, or list ignored +nicks when no NICK is given. When listing ignored nicks, the +ones added to the list automatically are marked with an asterisk." + (interactive "sToggle ignoring of nick: ") + (setq rcirc-ignore-list + (apply #'rcirc-add-or-remove rcirc-ignore-list + (split-string nick nil t))) + (rcirc-print process nil "IGNORE" target + (mapconcat + (lambda (nick) + (concat nick + (if (member nick rcirc-ignore-list-automatic) + "*" ""))) + rcirc-ignore-list " "))) + +(defun-rcirc-command bright (nick) + "Manage the bright nick list." + (interactive "sToggle emphasis of nick: ") + (setq rcirc-bright-nicks + (apply #'rcirc-add-or-remove rcirc-bright-nicks + (split-string nick nil t))) + (rcirc-print process nil "BRIGHT" target + (mapconcat 'identity rcirc-bright-nicks " "))) + +(defun-rcirc-command dim (nick) + "Manage the dim nick list." + (interactive "sToggle deemphasis of nick: ") + (setq rcirc-dim-nicks + (apply #'rcirc-add-or-remove rcirc-dim-nicks + (split-string nick nil t))) + (rcirc-print process nil "DIM" target + (mapconcat 'identity rcirc-dim-nicks " "))) + +(defun-rcirc-command keyword (keyword) + "Manage the keyword list. +Mark KEYWORD, unmark KEYWORD if already marked, or list marked +keywords when no KEYWORD is given." + (interactive "sToggle highlighting of keyword: ") + (setq rcirc-keywords + (apply #'rcirc-add-or-remove rcirc-keywords + (split-string keyword nil t))) + (rcirc-print process nil "KEYWORD" target + (mapconcat 'identity rcirc-keywords " "))) + + +(defun rcirc-add-face (start end name &optional object) + "Add face NAME to the face text property of the text from START to END." + (when name + (let ((pos start) + next prop) + (while (< pos end) + (setq prop (get-text-property pos 'font-lock-face object) + next (next-single-property-change pos 'font-lock-face object end)) + (unless (member name (get-text-property pos 'font-lock-face object)) + (add-text-properties pos next + (list 'font-lock-face (cons name prop)) object)) + (setq pos next))))) + +(defun rcirc-facify (string face) + "Return a copy of STRING with FACE property added." + (let ((string (or string ""))) + (rcirc-add-face 0 (length string) face string) + string)) + +(defvar rcirc-url-regexp + (concat + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" + "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" + "\\(//[-a-z0-9_.]+:[0-9]*\\)?" + (if (string-match "[[:digit:]]" "1") ;; Support POSIX? + (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") + (punct "!?:;.,")) + (concat + "\\(?:" + ;; Match paired parentheses, e.g. in Wikipedia URLs: + "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]" + "\\|" + "[" chars punct "]+" "[" chars "]" + "\\)")) + (concat ;; XEmacs 21.4 doesn't support POSIX. + "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+" + "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)")) + "\\)") + "Regexp matching URLs. Set to nil to disable URL features in rcirc.") + +;; cf cl-remove-if-not +(defun rcirc-condition-filter (condp lst) + "Remove all items not satisfying condition CONDP in list LST. +CONDP is a function that takes a list element as argument and returns +non-nil if that element should be included. Returns a new list." + (delq nil (mapcar (lambda (x) (and (funcall condp x) x)) lst))) + +(defun rcirc-browse-url (&optional arg) + "Prompt for URL to browse based on URLs in buffer before point. + +If ARG is given, opens the URL in a new browser window." + (interactive "P") + (let* ((point (point)) + (filtered (rcirc-condition-filter + (lambda (x) (>= point (cdr x))) + rcirc-urls)) + (completions (mapcar (lambda (x) (car x)) filtered)) + (defaults (mapcar (lambda (x) (car x)) filtered))) + (browse-url (completing-read "Rcirc browse-url: " + completions nil nil (car defaults) nil defaults) + arg))) + +(defun rcirc-markup-timestamp (_sender _response) + (goto-char (point-min)) + (insert (rcirc-facify (format-time-string rcirc-time-format + (let ((time rcirc-last-message-time)) + (when time (setq rcirc-last-message-time nil)) + time)) + 'rcirc-timestamp))) + +(defun rcirc-markup-attributes (_sender _response) + (while (re-search-forward "\\([\C-b\C-_\C-v]\\).*?\\(\\1\\|\C-o\\)" nil t) + (rcirc-add-face (match-beginning 0) (match-end 0) + (cl-case (char-after (match-beginning 1)) + (?\C-b 'bold) + (?\C-v 'italic) + (?\C-_ 'underline))) + ;; keep the ^O since it could terminate other attributes + (when (not (eq ?\C-o (char-before (match-end 2)))) + (delete-region (match-beginning 2) (match-end 2))) + (delete-region (match-beginning 1) (match-end 1)) + (goto-char (match-beginning 1))) + ;; remove the ^O characters now + (goto-char (point-min)) + (while (re-search-forward "\C-o+" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + +(defun rcirc-markup-my-nick (_sender response) + (with-syntax-table rcirc-nick-syntax-table + (while (re-search-forward (concat "\\b" + (regexp-quote (rcirc-nick + (rcirc-buffer-process))) + "\\b") + nil t) + (rcirc-add-face (match-beginning 0) (match-end 0) + 'rcirc-nick-in-message) + (when (string= response "PRIVMSG") + (rcirc-add-face (point-min) (point-max) + 'rcirc-nick-in-message-full-line) + (rcirc-record-activity (current-buffer) 'nick))))) + +(defun rcirc-markup-urls (_sender _response) + (while (and rcirc-url-regexp ;; nil means disable URL catching + (re-search-forward rcirc-url-regexp nil t)) + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (url (match-string-no-properties 0)) + (link-text (buffer-substring-no-properties start end))) + ;; Add a button for the URL. Note that we use `make-text-button', + ;; rather than `make-button', as text-buttons are much faster in + ;; large buffers. + (make-text-button start end + 'face 'rcirc-url + 'follow-link t + 'rcirc-url url + 'action (lambda (button) + (browse-url (button-get button 'rcirc-url)))) + ;; record the url if it is not already the latest stored url + (when (not (string= link-text (caar rcirc-urls))) + (push (cons link-text start) rcirc-urls))))) + +(defun rcirc-markup-keywords (sender response) + (when (and (string= response "PRIVMSG") + (not (string= sender (rcirc-nick (rcirc-buffer-process))))) + (let* ((target (or rcirc-target "")) + (keywords (delq nil (mapcar (lambda (keyword) + (when (not (string-match keyword + target)) + keyword)) + rcirc-keywords)))) + (when keywords + (while (re-search-forward (regexp-opt keywords 'words) nil t) + (rcirc-add-face (match-beginning 0) (match-end 0) 'rcirc-keyword) + (rcirc-record-activity (current-buffer) 'keyword)))))) + +(defun rcirc-markup-bright-nicks (_sender response) + (when (and rcirc-bright-nicks + (string= response "NAMES")) + (with-syntax-table rcirc-nick-syntax-table + (while (re-search-forward (regexp-opt rcirc-bright-nicks 'words) nil t) + (rcirc-add-face (match-beginning 0) (match-end 0) + 'rcirc-bright-nick))))) + +(defun rcirc-markup-fill (_sender response) + (when (not (string= response "372")) ; /motd + (let ((fill-prefix + (or rcirc-fill-prefix + (make-string (- (point) (line-beginning-position)) ?\s))) + (fill-column (- (cond ((null rcirc-fill-column) fill-column) + ((functionp rcirc-fill-column) + (funcall rcirc-fill-column)) + (t rcirc-fill-column)) + ;; make sure ... doesn't cause line wrapping + 3))) + (fill-region (point) (point-max) nil t)))) + +;;; handlers +;; these are called with the server PROCESS, the SENDER, which is a +;; server or a user, depending on the command, the ARGS, which is a +;; list of strings, and the TEXT, which is the original server text, +;; verbatim +(defun rcirc-handler-001 (process sender args text) + (rcirc-handler-generic process "001" sender args text) + (with-rcirc-process-buffer process + (setq rcirc-connecting nil) + (rcirc-reschedule-timeout process) + (setq rcirc-server-name sender) + (setq rcirc-nick (car args)) + (rcirc-update-prompt) + (if rcirc-auto-authenticate-flag + (if (and rcirc-authenticate-before-join + ;; We have to ensure that there's an authentication + ;; entry for that server. Else, + ;; rcirc-authenticated-hook won't be triggered, and + ;; autojoin won't happen at all. + (let (auth-required) + (dolist (s rcirc-authinfo auth-required) + (when (string-match (car s) rcirc-server-name) + (setq auth-required t))))) + (progn + (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t) + (rcirc-authenticate)) + (rcirc-authenticate) + (rcirc-join-channels process rcirc-startup-channels)) + (rcirc-join-channels process rcirc-startup-channels)))) + +(defun rcirc-join-channels-post-auth (process) + "Join `rcirc-startup-channels' after authenticating." + (with-rcirc-process-buffer process + (rcirc-join-channels process rcirc-startup-channels))) + +(defun rcirc-handler-PRIVMSG (process sender args text) + (rcirc-check-auth-status process sender args text) + (let ((target (if (rcirc-channel-p (car args)) + (car args) + sender)) + (message (or (cadr args) ""))) + (if (string-match "^\C-a\\(.*\\)\C-a$" message) + (rcirc-handler-CTCP process target sender (match-string 1 message)) + (rcirc-print process sender "PRIVMSG" target message t)) + ;; update nick linestamp + (with-current-buffer (rcirc-get-buffer process target t) + (rcirc-put-nick-channel process sender target rcirc-current-line)))) + +(defun rcirc-handler-NOTICE (process sender args text) + (rcirc-check-auth-status process sender args text) + (let ((target (car args)) + (message (cadr args))) + (if (string-match "^\C-a\\(.*\\)\C-a$" message) + (rcirc-handler-CTCP-response process target sender + (match-string 1 message)) + (rcirc-print process sender "NOTICE" + (cond ((rcirc-channel-p target) + target) + ;;; -ChanServ- [#gnu] Welcome... + ((string-match "\\[\\(#[^] ]+\\)\\]" message) + (match-string 1 message)) + (sender + (if (string= sender (rcirc-server-name process)) + nil ; server notice + sender))) + message t)))) + +(defun rcirc-check-auth-status (process sender args _text) + "Check if the user just authenticated. +If authenticated, runs `rcirc-authenticated-hook' with PROCESS as +the only argument." + (with-rcirc-process-buffer process + (when (and (not rcirc-user-authenticated) + rcirc-authenticate-before-join + rcirc-auto-authenticate-flag) + (let ((target (car args)) + (message (cadr args))) + (when (or + (and ;; nickserv + (string= sender "NickServ") + (string= target rcirc-nick) + (member message + (list + (format "You are now identified for \C-b%s\C-b." rcirc-nick) + (format "You are successfully identified as \C-b%s\C-b." rcirc-nick) + "Password accepted - you are now recognized." + ))) + (and ;; quakenet + (string= sender "Q") + (string= target rcirc-nick) + (string-match "\\`You are now logged in as .+\\.\\'" message))) + (setq rcirc-user-authenticated t) + (run-hook-with-args 'rcirc-authenticated-hook process) + (remove-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t)))))) + +(defun rcirc-handler-WALLOPS (process sender args _text) + (rcirc-print process sender "WALLOPS" sender (car args) t)) + +(defun rcirc-handler-JOIN (process sender args _text) + (let ((channel (car args))) + (with-current-buffer (rcirc-get-buffer-create process channel) + ;; when recently rejoining, restore the linestamp + (rcirc-put-nick-channel process sender channel + (let ((last-activity-lines + (rcirc-elapsed-lines process sender channel))) + (when (and last-activity-lines + (< last-activity-lines rcirc-omit-threshold)) + (rcirc-last-line process sender channel)))) + ;; reset mode-line-process in case joining a channel with an + ;; already open buffer (after getting kicked e.g.) + (setq mode-line-process nil)) + + (rcirc-print process sender "JOIN" channel "") + + ;; print in private chat buffer if it exists + (when (rcirc-get-buffer (rcirc-buffer-process) sender) + (rcirc-print process sender "JOIN" sender channel)))) + +;; PART and KICK are handled the same way +(defun rcirc-handler-PART-or-KICK (process _response channel _sender nick _args) + (rcirc-ignore-update-automatic nick) + (if (not (string= nick (rcirc-nick process))) + ;; this is someone else leaving + (progn + (rcirc-maybe-remember-nick-quit process nick channel) + (rcirc-remove-nick-channel process nick channel)) + ;; this is us leaving + (mapc (lambda (n) + (rcirc-remove-nick-channel process n channel)) + (rcirc-channel-nicks process channel)) + + ;; if the buffer is still around, make it inactive + (let ((buffer (rcirc-get-buffer process channel))) + (when buffer + (rcirc-disconnect-buffer buffer))))) + +(defun rcirc-handler-PART (process sender args _text) + (let* ((channel (car args)) + (reason (cadr args)) + (message (concat channel " " reason))) + (rcirc-print process sender "PART" channel message) + ;; print in private chat buffer if it exists + (when (rcirc-get-buffer (rcirc-buffer-process) sender) + (rcirc-print process sender "PART" sender message)) + + (rcirc-handler-PART-or-KICK process "PART" channel sender sender reason))) + +(defun rcirc-handler-KICK (process sender args _text) + (let* ((channel (car args)) + (nick (cadr args)) + (reason (nth 2 args)) + (message (concat nick " " channel " " reason))) + (rcirc-print process sender "KICK" channel message t) + ;; print in private chat buffer if it exists + (when (rcirc-get-buffer (rcirc-buffer-process) nick) + (rcirc-print process sender "KICK" nick message)) + + (rcirc-handler-PART-or-KICK process "KICK" channel sender nick reason))) + +(defun rcirc-maybe-remember-nick-quit (process nick channel) + "Remember NICK as leaving CHANNEL if they recently spoke." + (let ((elapsed-lines (rcirc-elapsed-lines process nick channel))) + (when (and elapsed-lines + (< elapsed-lines rcirc-omit-threshold)) + (let ((buffer (rcirc-get-buffer process channel))) + (when buffer + (with-current-buffer buffer + (let ((record (assoc-string nick rcirc-recent-quit-alist t)) + (line (rcirc-last-line process nick channel))) + (if record + (setcdr record line) + (setq rcirc-recent-quit-alist + (cons (cons nick line) + rcirc-recent-quit-alist)))))))))) + +(defun rcirc-handler-QUIT (process sender args _text) + (rcirc-ignore-update-automatic sender) + (mapc (lambda (channel) + ;; broadcast quit message each channel + (rcirc-print process sender "QUIT" channel (apply 'concat args)) + ;; record nick in quit table if they recently spoke + (rcirc-maybe-remember-nick-quit process sender channel)) + (rcirc-nick-channels process sender)) + (rcirc-nick-remove process sender)) + +(defun rcirc-handler-NICK (process sender args _text) + (let* ((old-nick sender) + (new-nick (car args)) + (channels (rcirc-nick-channels process old-nick))) + ;; update list of ignored nicks + (rcirc-ignore-update-automatic old-nick) + (when (member old-nick rcirc-ignore-list) + (add-to-list 'rcirc-ignore-list new-nick) + (add-to-list 'rcirc-ignore-list-automatic new-nick)) + ;; print message to nick's channels + (dolist (target channels) + (rcirc-print process sender "NICK" target new-nick)) + ;; update private chat buffer, if it exists + (let ((chat-buffer (rcirc-get-buffer process old-nick))) + (when chat-buffer + (with-current-buffer chat-buffer + (rcirc-print process sender "NICK" old-nick new-nick) + (setq rcirc-target new-nick) + (rename-buffer (rcirc-generate-new-buffer-name process new-nick))))) + ;; remove old nick and add new one + (with-rcirc-process-buffer process + (let ((v (gethash old-nick rcirc-nick-table))) + (remhash old-nick rcirc-nick-table) + (puthash new-nick v rcirc-nick-table)) + ;; if this is our nick... + (when (string= old-nick rcirc-nick) + (setq rcirc-nick new-nick) + (rcirc-update-prompt t) + ;; reauthenticate + (when rcirc-auto-authenticate-flag (rcirc-authenticate)))))) + +(defun rcirc-handler-PING (process _sender args _text) + (rcirc-send-string process (concat "PONG :" (car args)))) + +(defun rcirc-handler-PONG (_process _sender _args _text) + ;; do nothing + ) + +(defun rcirc-handler-TOPIC (process sender args _text) + (let ((topic (cadr args))) + (rcirc-print process sender "TOPIC" (car args) topic) + (with-current-buffer (rcirc-get-buffer process (car args)) + (setq rcirc-topic topic)))) + +(defvar rcirc-nick-away-alist nil) +(defun rcirc-handler-301 (process _sender args text) + "RPL_AWAY" + (let* ((nick (cadr args)) + (rec (assoc-string nick rcirc-nick-away-alist)) + (away-message (nth 2 args))) + (when (or (not rec) + (not (string= (cdr rec) away-message))) + ;; away message has changed + (rcirc-handler-generic process "AWAY" nick (cdr args) text) + (if rec + (setcdr rec away-message) + (setq rcirc-nick-away-alist (cons (cons nick away-message) + rcirc-nick-away-alist)))))) + +(defun rcirc-handler-317 (process sender args _text) + "RPL_WHOISIDLE" + (let* ((nick (nth 1 args)) + (idle-secs (string-to-number (nth 2 args))) + (idle-string + (if (< idle-secs most-positive-fixnum) + (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs) + "a very long time")) + (signon-time (seconds-to-time (string-to-number (nth 3 args)))) + (signon-string (format-time-string "%c" signon-time)) + (message (format "%s idle for %s, signed on %s" + nick idle-string signon-string))) + (rcirc-print process sender "317" nil message t))) + +(defun rcirc-handler-332 (process _sender args _text) + "RPL_TOPIC" + (let ((buffer (or (rcirc-get-buffer process (cadr args)) + (rcirc-get-temp-buffer-create process (cadr args))))) + (with-current-buffer buffer + (setq rcirc-topic (nth 2 args))))) + +(defun rcirc-handler-333 (process sender args _text) + "333 says who set the topic and when. +Not in rfc1459.txt" + (let ((buffer (or (rcirc-get-buffer process (cadr args)) + (rcirc-get-temp-buffer-create process (cadr args))))) + (with-current-buffer buffer + (let ((setter (nth 2 args)) + (time (current-time-string + (seconds-to-time + (string-to-number (cl-cadddr args)))))) + (rcirc-print process sender "TOPIC" (cadr args) + (format "%s (%s on %s)" rcirc-topic setter time)))))) + +(defun rcirc-handler-477 (process sender args _text) + "ERR_NOCHANMODES" + (rcirc-print process sender "477" (cadr args) (nth 2 args))) + +(defun rcirc-handler-MODE (process sender args _text) + (let ((target (car args)) + (msg (mapconcat 'identity (cdr args) " "))) + (rcirc-print process sender "MODE" + (if (string= target (rcirc-nick process)) + nil + target) + msg) + + ;; print in private chat buffers if they exist + (mapc (lambda (nick) + (when (rcirc-get-buffer process nick) + (rcirc-print process sender "MODE" nick msg))) + (cddr args)))) + +(defun rcirc-get-temp-buffer-create (process channel) + "Return a buffer based on PROCESS and CHANNEL." + (let ((tmpnam (concat " " (downcase channel) "TMP" (process-name process)))) + (get-buffer-create tmpnam))) + +(defun rcirc-handler-353 (process _sender args _text) + "RPL_NAMREPLY" + (let ((channel (nth 2 args)) + (names (or (nth 3 args) ""))) + (mapc (lambda (nick) + (rcirc-put-nick-channel process nick channel)) + (split-string names " " t)) + ;; create a temporary buffer to insert the names into + ;; rcirc-handler-366 (RPL_ENDOFNAMES) will handle it + (with-current-buffer (rcirc-get-temp-buffer-create process channel) + (goto-char (point-max)) + (insert (car (last args)) " ")))) + +(defun rcirc-handler-366 (process sender args _text) + "RPL_ENDOFNAMES" + (let* ((channel (cadr args)) + (buffer (rcirc-get-temp-buffer-create process channel))) + (with-current-buffer buffer + (rcirc-print process sender "NAMES" channel + (let ((content (buffer-substring (point-min) (point-max)))) + (rcirc-sort-nicknames-join content " ")))) + (kill-buffer buffer))) + +(defun rcirc-handler-433 (process sender args text) + "ERR_NICKNAMEINUSE" + (rcirc-handler-generic process "433" sender args text) + (let* ((new-nick (concat (cadr args) "`"))) + (with-rcirc-process-buffer process + (rcirc-cmd-nick new-nick nil process)))) + +(defun rcirc-authenticate () + "Send authentication to process associated with current buffer. +Passwords are stored in `rcirc-authinfo' (which see)." + (interactive) + (with-rcirc-server-buffer + (dolist (i rcirc-authinfo) + (let ((process (rcirc-buffer-process)) + (server (car i)) + (nick (nth 2 i)) + (method (cadr i)) + (args (cl-cdddr i))) + (when (and (string-match server rcirc-server)) + (if (and (memq method '(nickserv chanserv bitlbee)) + (string-match nick rcirc-nick)) + ;; the following methods rely on the user's nickname. + (cl-case method + (nickserv + (rcirc-send-privmsg + process + (or (cadr args) "NickServ") + (concat "IDENTIFY " (car args)))) + (chanserv + (rcirc-send-privmsg + process + "ChanServ" + (format "IDENTIFY %s %s" (car args) (cadr args)))) + (bitlbee + (rcirc-send-privmsg + process + "&bitlbee" + (concat "IDENTIFY " (car args))))) + ;; quakenet authentication doesn't rely on the user's nickname. + ;; the variable `nick' here represents the Q account name. + (when (eq method 'quakenet) + (rcirc-send-privmsg + process + "Q@CServe.quakenet.org" + (format "AUTH %s %s" nick (car args)))))))))) + +(defun rcirc-handler-INVITE (process sender args _text) + (rcirc-print process sender "INVITE" nil (mapconcat 'identity args " ") t)) + +(defun rcirc-handler-ERROR (process sender args _text) + (rcirc-print process sender "ERROR" nil (mapconcat 'identity args " "))) + +(defun rcirc-handler-CTCP (process target sender text) + (if (string-match "^\\([^ ]+\\) *\\(.*\\)$" text) + (let* ((request (upcase (match-string 1 text))) + (args (match-string 2 text)) + (handler (intern-soft (concat "rcirc-handler-ctcp-" request)))) + (if (not (fboundp handler)) + (rcirc-print process sender "ERROR" target + (format "%s sent unsupported ctcp: %s" sender text) + t) + (funcall handler process target sender args) + (unless (or (string= request "ACTION") + (string= request "KEEPALIVE")) + (rcirc-print process sender "CTCP" target + (format "%s" text) t)))))) + +(defun rcirc-handler-ctcp-VERSION (process _target sender _args) + (rcirc-send-string process + (concat "NOTICE " sender + " :\C-aVERSION " rcirc-id-string + "\C-a"))) + +(defun rcirc-handler-ctcp-ACTION (process target sender args) + (rcirc-print process sender "ACTION" target args t)) + +(defun rcirc-handler-ctcp-TIME (process _target sender _args) + (rcirc-send-string process + (concat "NOTICE " sender + " :\C-aTIME " (current-time-string) "\C-a"))) + +(defun rcirc-handler-CTCP-response (process _target sender message) + (rcirc-print process sender "CTCP" nil message t)) + +(defun rcirc-handler-CAP (process _sender args _text) + (when (equal (cadr args) "LS") + (rcirc-send-string process "CAP REQ :server-time")) + + (when (or (equal (cadr args) "ACK") + (equal (cadr args) "NAK")) + ;; Capability negotiation is best-effort here, I know that my + ;; servers support server-time and thus we end negotiation + ;; immediately. + (rcirc-send-string process "CAP END"))) + +(defgroup rcirc-faces nil + "Faces for rcirc." + :group 'rcirc + :group 'faces) + +(defface rcirc-my-nick ; font-lock-function-name-face + '((((class color) (min-colors 88) (background light)) :foreground "Blue1") + (((class color) (min-colors 88) (background dark)) :foreground "LightSkyBlue") + (((class color) (min-colors 16) (background light)) :foreground "Blue") + (((class color) (min-colors 16) (background dark)) :foreground "LightSkyBlue") + (((class color) (min-colors 8)) :foreground "blue" :weight bold) + (t :inverse-video t :weight bold)) + "Rcirc face for my messages." + :group 'rcirc-faces) + +(defface rcirc-other-nick ; font-lock-variable-name-face + '((((class grayscale) (background light)) + :foreground "Gray90" :weight bold :slant italic) + (((class grayscale) (background dark)) + :foreground "DimGray" :weight bold :slant italic) + (((class color) (min-colors 88) (background light)) :foreground "DarkGoldenrod") + (((class color) (min-colors 88) (background dark)) :foreground "LightGoldenrod") + (((class color) (min-colors 16) (background light)) :foreground "DarkGoldenrod") + (((class color) (min-colors 16) (background dark)) :foreground "LightGoldenrod") + (((class color) (min-colors 8)) :foreground "yellow" :weight light) + (t :weight bold :slant italic)) + "Rcirc face for other users' messages." + :group 'rcirc-faces) + +(defface rcirc-bright-nick + '((((class grayscale) (background light)) + :foreground "LightGray" :weight bold :underline t) + (((class grayscale) (background dark)) + :foreground "Gray50" :weight bold :underline t) + (((class color) (min-colors 88) (background light)) :foreground "CadetBlue") + (((class color) (min-colors 88) (background dark)) :foreground "Aquamarine") + (((class color) (min-colors 16) (background light)) :foreground "CadetBlue") + (((class color) (min-colors 16) (background dark)) :foreground "Aquamarine") + (((class color) (min-colors 8)) :foreground "magenta") + (t :weight bold :underline t)) + "Rcirc face for nicks matched by `rcirc-bright-nicks'." + :group 'rcirc-faces) + +(defface rcirc-dim-nick + '((t :inherit default)) + "Rcirc face for nicks in `rcirc-dim-nicks'." + :group 'rcirc-faces) + +(defface rcirc-server ; font-lock-comment-face + '((((class grayscale) (background light)) + :foreground "DimGray" :weight bold :slant italic) + (((class grayscale) (background dark)) + :foreground "LightGray" :weight bold :slant italic) + (((class color) (min-colors 88) (background light)) + :foreground "Firebrick") + (((class color) (min-colors 88) (background dark)) + :foreground "chocolate1") + (((class color) (min-colors 16) (background light)) + :foreground "red") + (((class color) (min-colors 16) (background dark)) + :foreground "red1") + (((class color) (min-colors 8) (background light))) + (((class color) (min-colors 8) (background dark))) + (t :weight bold :slant italic)) + "Rcirc face for server messages." + :group 'rcirc-faces) + +(defface rcirc-server-prefix ; font-lock-comment-delimiter-face + '((default :inherit rcirc-server) + (((class grayscale))) + (((class color) (min-colors 16))) + (((class color) (min-colors 8) (background light)) + :foreground "red") + (((class color) (min-colors 8) (background dark)) + :foreground "red1")) + "Rcirc face for server prefixes." + :group 'rcirc-faces) + +(defface rcirc-timestamp + '((t :inherit default)) + "Rcirc face for timestamps." + :group 'rcirc-faces) + +(defface rcirc-nick-in-message ; font-lock-keyword-face + '((((class grayscale) (background light)) :foreground "LightGray" :weight bold) + (((class grayscale) (background dark)) :foreground "DimGray" :weight bold) + (((class color) (min-colors 88) (background light)) :foreground "Purple") + (((class color) (min-colors 88) (background dark)) :foreground "Cyan1") + (((class color) (min-colors 16) (background light)) :foreground "Purple") + (((class color) (min-colors 16) (background dark)) :foreground "Cyan") + (((class color) (min-colors 8)) :foreground "cyan" :weight bold) + (t :weight bold)) + "Rcirc face for instances of your nick within messages." + :group 'rcirc-faces) + +(defface rcirc-nick-in-message-full-line '((t :weight bold)) + "Rcirc face for emphasizing the entire message when your nick is mentioned." + :group 'rcirc-faces) + +(defface rcirc-prompt ; comint-highlight-prompt + '((((min-colors 88) (background dark)) :foreground "cyan1") + (((background dark)) :foreground "cyan") + (t :foreground "dark blue")) + "Rcirc face for prompts." + :group 'rcirc-faces) + +(defface rcirc-track-nick + '((((type tty)) :inherit default) + (t :inverse-video t)) + "Rcirc face used in the mode-line when your nick is mentioned." + :group 'rcirc-faces) + +(defface rcirc-track-keyword '((t :weight bold)) + "Rcirc face used in the mode-line when keywords are mentioned." + :group 'rcirc-faces) + +(defface rcirc-url '((t :weight bold)) + "Rcirc face used to highlight urls." + :group 'rcirc-faces) + +(defface rcirc-keyword '((t :inherit highlight)) + "Rcirc face used to highlight keywords." + :group 'rcirc-faces) + + +;; When using M-x flyspell-mode, only check words after the prompt +(put 'rcirc-mode 'flyspell-mode-predicate 'rcirc-looking-at-input) +(defun rcirc-looking-at-input () + "Returns true if point is past the input marker." + (>= (point) rcirc-prompt-end-marker)) + + +(provide 'rcirc) + +;;; rcirc.el ends here diff --git a/third_party/emacs/vterm.nix b/third_party/emacs/vterm.nix new file mode 100644 index 000000000000..674a919c99f0 --- /dev/null +++ b/third_party/emacs/vterm.nix @@ -0,0 +1,11 @@ +# Overridden vterm to fetch a newer version +{ pkgs, ... }: + +pkgs.emacsPackages.vterm.overrideAttrs(_: { + src = pkgs.fetchFromGitHub{ + owner = "akermu"; + repo = "emacs-libvterm"; + rev = "58b4cc40ee9872a08fc5cbfee78ad0e195a3306c"; + sha256 = "1w5yfl8nq4k7xyldf0ivzv36vhz3dwdzk6q2vs3xwpx6ljy52px6"; + }; +}) |