diff options
Diffstat (limited to 'lisp/term')
| -rw-r--r-- | lisp/term/common-win.el | 38 | ||||
| -rw-r--r-- | lisp/term/haiku-win.el | 635 | ||||
| -rw-r--r-- | lisp/term/ns-win.el | 135 | ||||
| -rw-r--r-- | lisp/term/pc-win.el | 8 | ||||
| -rw-r--r-- | lisp/term/pgtk-win.el | 400 | ||||
| -rw-r--r-- | lisp/term/w32-win.el | 4 | ||||
| -rw-r--r-- | lisp/term/x-win.el | 141 | ||||
| -rw-r--r-- | lisp/term/xterm.el | 2 |
8 files changed, 1260 insertions, 103 deletions
diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el index 7a48fc04c6c..f7faba9cb7c 100644 --- a/lisp/term/common-win.el +++ b/lisp/term/common-win.el @@ -59,21 +59,19 @@ (setq system-key-alist (list ;; These are special "keys" used to pass events from C to lisp. - (cons 1 'ns-power-off) - (cons 2 'ns-open-file) - (cons 3 'ns-open-temp-file) - (cons 4 'ns-drag-file) - (cons 5 'ns-drag-color) - (cons 6 'ns-drag-text) - (cons 7 'ns-change-font) - (cons 8 'ns-open-file-line) -;;; (cons 9 'ns-insert-working-text) -;;; (cons 10 'ns-delete-working-text) - (cons 11 'ns-spi-service-call) - (cons 12 'ns-new-frame) - (cons 13 'ns-toggle-toolbar) - (cons 14 'ns-show-prefs) - )))) + (cons 1 (make-non-key-event 'ns-power-off)) + (cons 2 (make-non-key-event 'ns-open-file)) + (cons 3 (make-non-key-event 'ns-open-temp-file)) + (cons 4 (make-non-key-event 'ns-drag-file)) + (cons 5 (make-non-key-event 'ns-drag-color)) + (cons 6 (make-non-key-event 'ns-drag-text)) + (cons 8 (make-non-key-event 'ns-open-file-line)) +;;; (cons 9 (make-non-key-event 'ns-insert-working-text)) +;;; (cons 10 (make-non-key-event 'ns-delete-working-text)) + (cons 11 (make-non-key-event 'ns-spi-service-call)) + (cons 12 (make-non-key-event 'ns-new-frame)) + (cons 13 (make-non-key-event 'ns-toggle-toolbar)) + (cons 14 (make-non-key-event 'ns-show-prefs)))))) (set-terminal-parameter frame 'x-setup-function-keys t))) (defvar x-invocation-args) @@ -419,6 +417,16 @@ the operating system.") (setq defined-colors (cons this-color defined-colors)))) defined-colors))) +;;;; Session management. + +(defvar emacs-save-session-functions nil + "Special hook run when a save-session event occurs. +The functions do not get any argument. +Functions can return non-nil to inform the session manager that the +window system shutdown should be aborted. + +See also `emacs-session-save'.") + (provide 'term/common-win) ;;; common-win.el ends here diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el new file mode 100644 index 00000000000..a16169d477f --- /dev/null +++ b/lisp/term/haiku-win.el @@ -0,0 +1,635 @@ +;;; haiku-win.el --- set up windowing on Haiku -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; 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: + +;; Support for using Haiku's BeOS derived windowing system. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) +(unless (featurep 'haiku) + (error "%s: Loading haiku-win without having Haiku" + invocation-name)) + +;; Documentation-purposes only: actually loaded in loadup.el. +(require 'frame) +(require 'mouse) +(require 'scroll-bar) +(require 'menu-bar) +(require 'fontset) +(require 'dnd) + +(add-to-list 'display-format-alist '(".*" . haiku)) + +;;;; Command line argument handling. + +(defvar x-invocation-args) +(defvar x-command-line-resources) + +(defvar haiku-initialized) +(defvar haiku-signal-invalid-refs) +(defvar haiku-drag-track-function) +(defvar haiku-allowed-ui-colors) + +(defvar haiku-dnd-selection-value nil + "The local value of the special `XdndSelection' selection.") + +(defvar haiku-dnd-selection-converters '((STRING . haiku-dnd-convert-string) + (FILE_NAME . haiku-dnd-convert-file-name) + (text/uri-list . haiku-dnd-convert-text-uri-list)) + "Alist of X selection types to functions that act as selection converters. +The functions should accept a single argument VALUE, describing +the value of the drag-and-drop selection, and return a list of +two elements TYPE and DATA, where TYPE is a string containing the +MIME type of DATA, and DATA is a unibyte string, or nil if the +data could not be converted. + +DATA may also be a list of items; that means to add every +individual item in DATA to the serialized message, instead of +DATA in its entirety. + +DATA can optionally have a text property `type', which specifies +the type of DATA inside the system message (see the doc string of +`haiku-drag-message' for more details). If DATA is a list, then +that property is obtained from the first element of DATA.") + +(defvar haiku-normal-selection-encoders '(haiku-select-encode-xstring + haiku-select-encode-utf-8-string + haiku-select-encode-file-name) + "List of functions which act as selection encoders. +These functions accept two arguments SELECTION and VALUE, and +return an association appropriate for a serialized system +message (or nil if VALUE is not applicable to the encoder) that +will be put into the system selection SELECTION. VALUE is the +content that is being put into the selection by +`gui-set-selection'. See the doc string of `haiku-drag-message' +for more details on the structure of the associations.") + +;; This list has to be set correctly, otherwise Emacs will crash upon +;; encountering an invalid color. +(setq haiku-allowed-ui-colors + ["B_PANEL_BACKGROUND_COLOR" "B_MENU_BACKGROUND_COLOR" + "B_WINDOW_TAB_COLOR" "B_KEYBOARD_NAVIGATION_COLOR" + "B_DESKTOP_COLOR" "B_MENU_SELECTED_BACKGROUND_COLOR" + "B_MENU_ITEM_TEXT_COLOR" "B_MENU_SELECTED_ITEM_TEXT_COLOR" + "B_MENU_SELECTED_BORDER_COLOR" "B_PANEL_TEXT_COLOR" + "B_DOCUMENT_BACKGROUND_COLOR" "B_DOCUMENT_TEXT_COLOR" + "B_CONTROL_BACKGROUND_COLOR" "B_CONTROL_TEXT_COLOR" + "B_CONTROL_BORDER_COLOR" "B_CONTROL_HIGHLIGHT_COLOR" + "B_NAVIGATION_PULSE_COLOR" "B_SHINE_COLOR" + "B_SHADOW_COLOR" "B_TOOLTIP_BACKGROUND_COLOR" + "B_TOOLTIP_TEXT_COLOR" "B_WINDOW_TEXT_COLOR" + "B_WINDOW_INACTIVE_TAB_COLOR" "B_WINDOW_INACTIVE_TEXT_COLOR" + "B_WINDOW_BORDER_COLOR" "B_WINDOW_INACTIVE_BORDER_COLOR" + "B_CONTROL_MARK_COLOR" "B_LIST_BACKGROUND_COLOR" + "B_LIST_SELECTED_BACKGROUND_COLOR" "B_LIST_ITEM_TEXT_COLOR" + "B_LIST_SELECTED_ITEM_TEXT_COLOR" "B_SCROLL_BAR_THUMB_COLOR" + "B_LINK_TEXT_COLOR" "B_LINK_HOVER_COLOR" + "B_LINK_VISITED_COLOR" "B_LINK_ACTIVE_COLOR" + "B_STATUS_BAR_COLOR" "B_SUCCESS_COLOR" "B_FAILURE_COLOR"]) + +(defvar x-colors) +;; Also update `x-colors' to take that into account. +(setq x-colors (append haiku-allowed-ui-colors x-colors)) + +(defun haiku-selection-bounds (value) + "Return bounds of selection value VALUE. +The return value is a list (BEG END BUF) if VALUE is a cons of +two markers or an overlay. Otherwise, it is nil." + (cond ((bufferp value) + (with-current-buffer value + (when (mark t) + (list (mark t) (point) value)))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (when (and (marker-buffer (car value)) + (buffer-name (marker-buffer (car value))) + (eq (marker-buffer (car value)) + (marker-buffer (cdr value)))) + (list (marker-position (car value)) + (marker-position (cdr value)) + (marker-buffer (car value))))) + ((overlayp value) + (when (overlay-buffer value) + (list (overlay-start value) + (overlay-end value) + (overlay-buffer value)))))) + +(defun haiku-dnd-convert-string (value) + "Convert VALUE to a UTF-8 string and appropriate MIME type. +Return a list of the appropriate MIME type, and UTF-8 data of +VALUE as a unibyte string, or nil if VALUE was not a string." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (stringp value) + (list "text/plain" (string-to-unibyte + (encode-coding-string value 'utf-8))))) + +(defun haiku-dnd-convert-file-name (value) + "Convert VALUE to a file system reference if it is a file name." + (cond ((and (stringp value) + (not (file-remote-p value)) + (file-exists-p value)) + (list "refs" (propertize (expand-file-name value) + 'type 'ref))) + ((vectorp value) + (list "refs" + (cl-loop for item across value + collect (propertize (expand-file-name item) + 'type 'ref)))))) + +(defun haiku-dnd-convert-text-uri-list (value) + "Convert VALUE to a list of URLs." + (cond + ((stringp value) (list "text/uri-list" + (concat (url-encode-url value) "\n"))) + ((vectorp value) (list "text/uri-list" + (with-temp-buffer + (cl-loop for tem across value + do (progn + (insert (url-encode-url tem)) + (insert "\n"))) + (buffer-string)))))) + +(eval-and-compile + (defun haiku-get-numeric-enum (name) + "Return the numeric value of the system enumerator NAME." + (or (get name 'haiku-numeric-enum) + (let ((value 0) + (offset 0) + (string (symbol-name name))) + (cl-loop for octet across string + do (progn + (when (or (< octet 0) + (> octet 255)) + (error "Out of range octet: %d" octet)) + (setq value + (logior value + (ash octet + (- (* (1- (length string)) 8) + offset)))) + (setq offset (+ offset 8)))) + (prog1 value + (put name 'haiku-enumerator-id value)))))) + +(defmacro haiku-numeric-enum (name) + "Expand to the numeric value NAME as a system identifier." + (haiku-get-numeric-enum name)) + +(declare-function x-open-connection "haikufns.c") +(declare-function x-handle-args "common-win") +(declare-function haiku-selection-data "haikuselect.c") +(declare-function haiku-selection-put "haikuselect.c") +(declare-function haiku-selection-owner-p "haikuselect.c") +(declare-function haiku-put-resource "haikufns.c") +(declare-function haiku-drag-message "haikuselect.c") +(declare-function haiku-selection-timestamp "haikuselect.c") + +(defun haiku--handle-x-command-line-resources (command-line-resources) + "Handle command line X resources specified with the option `-xrm'. +The resources should be a list of strings in COMMAND-LINE-RESOURCES." + (dolist (s command-line-resources) + (let ((components (split-string s ":"))) + (when (car components) + (haiku-put-resource (car components) + (string-trim-left + (mapconcat #'identity (cdr components) ":"))))))) + +(cl-defmethod window-system-initialization (&context (window-system haiku) + &optional display) + "Set up the window system. WINDOW-SYSTEM must be HAIKU. +DISPLAY may be set to the name of a display that will be initialized." + (cl-assert (not haiku-initialized)) + (create-default-fontset) + (when x-command-line-resources + (haiku--handle-x-command-line-resources + (split-string x-command-line-resources "\n"))) + (x-open-connection (or display "be") x-command-line-resources t) + (setq haiku-initialized t)) + +(cl-defmethod frame-creation-function (params &context (window-system haiku)) + (x-create-frame-with-faces params)) + +(cl-defmethod handle-args-function (args &context (window-system haiku)) + (x-handle-args args)) + +(defun haiku--selection-type-to-mime (type) + "Convert symbolic selection type TYPE to its MIME equivalent. +If TYPE is nil, return \"text/plain\"." + (cond + ((eq type 'STRING) "text/plain;charset=iso-8859-1") + ((eq type 'UTF8_STRING) "text/plain") + ((stringp type) type) + ((symbolp type) (symbol-name type)) + (t "text/plain"))) + +(defun haiku-selection-targets (clipboard) + "Find the types of data available from CLIPBOARD. +CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or +`CLIPBOARD'. Return the available types as a list of strings." + (delq 'type (mapcar #'car (haiku-selection-data clipboard nil)))) + +(defun haiku-select-encode-xstring (_selection value) + "Convert VALUE to a system message association. +VALUE will be encoded as Latin-1 (like on X Windows) and stored +under the type `text/plain;charset=iso-8859-1'." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (and (stringp value) (not (string-empty-p value))) + (list "text/plain;charset=iso-8859-1" (haiku-numeric-enum MIME) + (encode-coding-string value 'iso-latin-1)))) + +(defun haiku-select-encode-utf-8-string (_selection value) + "Convert VALUE to a system message association. +VALUE will be encoded as UTF-8 and stored under the type +`text/plain'." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (and (stringp value) (not (string-empty-p value))) + (list "text/plain" (haiku-numeric-enum MIME) + (encode-coding-string value 'utf-8-unix)))) + +(defun haiku-select-encode-file-name (_selection value) + "Convert VALUE to a system message association. +This takes the file name of VALUE's buffer (if it is an overlay +or a pair of markers) and turns it into a file system reference." + (when (setq value (xselect--selection-bounds value)) + (list "refs" 'ref (buffer-file-name (nth 2 value))))) + +(cl-defmethod gui-backend-get-selection (type data-type + &context (window-system haiku)) + (cond + ((eq data-type 'TARGETS) + (apply #'vector (mapcar #'intern + (haiku-selection-targets type)))) + ;; The timestamp here is really the number of times a program has + ;; put data into the selection. But it always increases, so it + ;; makes sense if one imagines that time is frozen until + ;; immediately before that happens. + ((eq data-type 'TIMESTAMP) + (haiku-selection-timestamp type)) + ((eq type 'XdndSelection) haiku-dnd-selection-value) + (t (haiku-selection-data type + (haiku--selection-type-to-mime data-type))))) + +(cl-defmethod gui-backend-set-selection (type value + &context (window-system haiku)) + (if (eq type 'XdndSelection) + (setq haiku-dnd-selection-value value) + (let ((message nil)) + (dolist (encoder haiku-normal-selection-encoders) + (let ((result (funcall encoder type value))) + (when result + (push result message)))) + (haiku-selection-put type message)))) + +(cl-defmethod gui-backend-selection-exists-p (selection + &context (window-system haiku)) + (haiku-selection-data selection "text/plain")) + +(cl-defmethod gui-backend-selection-owner-p (selection &context (window-system haiku)) + (haiku-selection-owner-p selection)) + +(declare-function haiku-read-file-name "haikufns.c") + +(defun x-file-dialog (prompt dir &optional default-filename mustmatch only-dir-p) + "SKIP: real doc in xfns.c." + (if (eq (framep-on-display (selected-frame)) 'haiku) + (haiku-read-file-name (if (not (string-suffix-p ": " prompt)) + prompt + (substring prompt 0 (- (length prompt) 2))) + (selected-frame) + (or dir (and default-filename + (file-name-directory default-filename))) + mustmatch only-dir-p + (and default-filename + (file-name-nondirectory default-filename))) + (error "x-file-dialog on a tty frame"))) + +(defun haiku-parse-drag-actions (message) + "Given the drag-and-drop message MESSAGE, retrieve the desired action." + (let ((actions (cddr (assoc "be:actions" message))) + (sorted nil)) + (dolist (action (list (haiku-numeric-enum DDCP) + (haiku-numeric-enum DDMV) + (haiku-numeric-enum DDLN))) + (when (member action actions) + (push sorted action))) + (cond + ((eql (car sorted) (haiku-numeric-enum DDCP)) 'copy) + ((eql (car sorted) (haiku-numeric-enum DDMV)) 'move) + ((eql (car sorted) (haiku-numeric-enum DDLN)) 'link) + (t 'private)))) + +(defun haiku-drag-and-drop (event) + "Handle specified drag-n-drop EVENT." + (interactive "e") + (let* ((string (caddr event)) + (window (posn-window (event-start event)))) + (if (eq string 'lambda) ; This means the mouse moved. + (dnd-handle-movement (event-start event)) + (let ((action (haiku-parse-drag-actions string))) + (cond + ;; Don't allow dropping on something other than the text area. + ;; It does nothing and doesn't work with text anyway. + ((posn-area (event-start event))) + ((assoc "refs" string) + (with-selected-window window + (dolist (filename (cddr (assoc "refs" string))) + (dnd-handle-one-url window action + (concat "file:" filename))))) + ((assoc "text/uri-list" string) + (dolist (text (cddr (assoc "text/uri-list" string))) + (let ((uri-list (split-string text "[\0\r\n]" t))) + (dolist (bf uri-list) + (dnd-handle-one-url window action bf))))) + ((assoc "text/plain" string) + (with-selected-window window + (dolist (text (cddr (assoc "text/plain" string))) + (unless mouse-yank-at-point + (goto-char (posn-point (event-start event)))) + (dnd-insert-text window action + (if (multibyte-string-p text) + text + (decode-coding-string text 'undecided)))))) + ((not (eq (cdr (assq 'type string)) + 3003)) ; Type of the placeholder message Emacs uses + ; to cancel a drop on C-g. + (message "Don't know how to drop any of: %s" + (mapcar #'car string)))))))) + +(define-key special-event-map [drag-n-drop] 'haiku-drag-and-drop) + +(defvaralias 'haiku-use-system-tooltips 'use-system-tooltips) + +(defun haiku-use-system-tooltips-watcher (&rest _ignored) + "Variable watcher to force a menu bar update when `use-system-tooltip' changes. +This is necessary because on Haiku `use-system-tooltip' doesn't +take effect on menu items until the menu bar is updated again." + (force-mode-line-update t)) + +;; Note that `mouse-position' can't return the actual frame the mouse +;; pointer is under, so this only works for the frame where the drop +;; started. +(defun haiku-dnd-drag-handler () + "Handle mouse movement during drag-and-drop." + (let ((track-mouse 'drag-source) + (mouse-position (mouse-pixel-position))) + (when (car mouse-position) + (dnd-handle-movement (posn-at-x-y (cadr mouse-position) + (cddr mouse-position) + (car mouse-position)))))) + +(setq haiku-drag-track-function #'haiku-dnd-drag-handler) + +(defun x-begin-drag (targets &optional action frame _return-frame + allow-current-frame follow-tooltip) + "SKIP: real doc in xfns.c." + (unless haiku-dnd-selection-value + (error "No local value for XdndSelection")) + (let ((message nil) + (mouse-highlight nil) + (haiku-signal-invalid-refs nil)) + (dolist (target targets) + (let* ((target-atom (intern target)) + (selection-converter (cdr (assoc target-atom + haiku-dnd-selection-converters))) + (value (if (stringp haiku-dnd-selection-value) + (or (get-text-property 0 target-atom + haiku-dnd-selection-value) + haiku-dnd-selection-value) + haiku-dnd-selection-value))) + (when selection-converter + (let ((selection-result (funcall selection-converter value))) + (when selection-result + (let* ((field (cdr (assoc (car selection-result) message))) + (maybe-string (if (stringp (cadr selection-result)) + (cadr selection-result) + (caadr selection-result)))) + (unless (cadr field) + ;; Add B_MIME_TYPE to the message if the type was not + ;; previously specified, or the type if it was. + (push (or (get-text-property 0 'type maybe-string) + (haiku-numeric-enum MIME)) + (alist-get (car selection-result) message + nil nil #'equal)))) + (if (not (consp (cadr selection-result))) + (push (cadr selection-result) + (cdr (alist-get (car selection-result) message + nil nil #'equal))) + (dolist (tem (cadr selection-result)) + (push tem + (cdr (alist-get (car selection-result) message + nil nil #'equal)))))))))) + (prog1 (or (and (symbolp action) + action) + 'XdndActionCopy) + (haiku-drag-message (or frame (selected-frame)) + message allow-current-frame + follow-tooltip)))) + +(add-variable-watcher 'use-system-tooltips + #'haiku-use-system-tooltips-watcher) + +(defvar haiku-dnd-wheel-count nil + "Cons used to determine how many times the wheel has been turned. +The car is just that; cdr is the timestamp of the last wheel +movement.") + +(defvar haiku-last-wheel-direction nil + "Cons of two elements describing the direction the wheel last turned. +The car is whether or not the movement was horizontal. +The cdr is whether or not the movement was upwards or leftwards.") + +(defun haiku-note-wheel-click (timestamp) + "Note that the mouse wheel was moved at TIMESTAMP during drag-and-drop. +Return the number of clicks that were made in quick succession." + (if (not (integerp double-click-time)) + 1 + (let ((cell haiku-dnd-wheel-count)) + (unless cell + (setq cell (cons 0 timestamp)) + (setq haiku-dnd-wheel-count cell)) + (when (< (cdr cell) (- timestamp double-click-time)) + (setcar cell 0)) + (setcar cell (1+ (car cell))) + (setcdr cell timestamp) + (car cell)))) + +(defvar haiku-drag-wheel-function) + +(defun haiku-dnd-modifier-mask (mods) + "Return the internal modifier mask for the Emacs modifier state MODS. +MODS is a single symbol, or a list of symbols such as `shift' or +`control'." + (let ((mask 0)) + (unless (consp mods) + (setq mods (list mods))) + (dolist (modifier mods) + (cond ((eq modifier 'shift) + (setq mask (logior mask ?\S-\0))) + ((eq modifier 'control) + (setq mask (logior mask ?\C-\0))) + ((eq modifier 'meta) + (setq mask (logior mask ?\M-\0))) + ((eq modifier 'hyper) + (setq mask (logior mask ?\H-\0))) + ((eq modifier 'super) + (setq mask (logior mask ?\s-\0))) + ((eq modifier 'alt) + (setq mask (logior mask ?\A-\0))))) + mask)) + +(defun haiku-dnd-wheel-modifier-type (flags) + "Return the modifier type of an internal modifier mask. +FLAGS is the internal modifier mask of a turn of the mouse wheel." + (let ((modifiers (logior ?\M-\0 ?\C-\0 ?\S-\0 + ?\H-\0 ?\s-\0 ?\A-\0))) + (catch 'type + (dolist (modifier mouse-wheel-scroll-amount) + (when (and (consp modifier) + (eq (haiku-dnd-modifier-mask (car modifier)) + (logand flags modifiers))) + (throw 'type (cdr modifier)))) + nil))) + +(defun haiku-handle-drag-wheel (frame x y horizontal up modifiers) + "Handle wheel movement during drag-and-drop. +FRAME is the frame on top of which the wheel moved. +X and Y are the frame-relative coordinates of the wheel movement. +HORIZONTAL is whether or not the wheel movement was horizontal. +UP is whether or not the wheel moved up (or left). +MODIFIERS is the internal modifier mask of the wheel movement." + (when (not (equal haiku-last-wheel-direction + (cons horizontal up))) + (setq haiku-last-wheel-direction + (cons horizontal up)) + (when (consp haiku-dnd-wheel-count) + (setcar haiku-dnd-wheel-count 0))) + (let ((type (haiku-dnd-wheel-modifier-type modifiers)) + (function (cond + ((and (not horizontal) (not up)) + mwheel-scroll-up-function) + ((not horizontal) + mwheel-scroll-down-function) + ((not up) (if mouse-wheel-flip-direction + mwheel-scroll-right-function + mwheel-scroll-left-function)) + (t (if mouse-wheel-flip-direction + mwheel-scroll-left-function + mwheel-scroll-right-function)))) + (timestamp (time-convert nil 1000)) + (amt 1)) + (cond ((and (eq type 'hscroll) + (not horizontal)) + (setq function (if (not up) + mwheel-scroll-left-function + mwheel-scroll-right-function))) + ((and (eq type 'global-text-scale)) + (setq function 'global-text-scale-adjust + amt (if up 1 -1))) + ((and (eq type 'text-scale)) + (setq function 'text-scale-adjust + amt (if up 1 -1)))) + (when function + (let ((posn (posn-at-x-y x y frame))) + (when (windowp (posn-window posn)) + (with-selected-window (posn-window posn) + (funcall function + (* amt + (or (and (not mouse-wheel-progressive-speed) 1) + (haiku-note-wheel-click (car timestamp))))))))))) + +(setq haiku-drag-wheel-function #'haiku-handle-drag-wheel) + + +;;;; Session management. + +(declare-function haiku-save-session-reply "haikufns.c") + +(defun emacs-session-save () + "SKIP: real doc in x-win.el." + (with-temp-buffer ; Saving sessions is not yet supported. + (condition-case nil + ;; A return of t means cancel the shutdown. + (run-hook-with-args-until-success + 'emacs-save-session-functions) + (error t)))) + +(defun handle-save-session (_event) + "SKIP: real doc in xsmfns.c." + (interactive "e") + (let ((cancel-shutdown t)) + (unwind-protect + (setq cancel-shutdown (emacs-session-save)) + (haiku-save-session-reply (not cancel-shutdown))) + ;; The App Server will kill Emacs after receiving the reply, but + ;; the Deskbar will not, so kill ourself here. + (unless cancel-shutdown (kill-emacs)))) + + +;;;; Cursors. + +;; We use the same interface as X, but the cursor numbers are +;; different, and there are also less cursors. + +(defconst x-pointer-X-cursor 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-arrow 1) ; B_CURSOR_ID_SYSTEM_DEFAULT +(defconst x-pointer-bottom-left-corner 22) ; B_CURSOR_ID_RESIZE_SOUTH_WEST +(defconst x-pointer-bottom-right-corner 21) ; B_CURSOR_ID_RESIZE_SOUTH_EAST +(defconst x-pointer-bottom-side 17) ; B_CURSOR_ID_RESIZE_SOUTH +(defconst x-pointer-clock 14) ; B_CURSOR_ID_PROGRESS +(defconst x-pointer-cross 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-cross-reverse 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-crosshair 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-diamond-cross 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-hand1 7) ; B_CURSOR_ID_GRAB +(defconst x-pointer-hand2 8) ; B_CURSOR_ID_GRABBING +(defconst x-pointer-left-side 18) ; B_CURSOR_ID_RESIZE_WEST +(defconst x-pointer-right-side 16) ; B_CURSOR_ID_RESIZE_EAST +(defconst x-pointer-sb-down-arrow 17) ; B_CURSOR_ID_RESIZE_SOUTH +(defconst x-pointer-sb-left-arrow 18) ; B_CURSOR_ID_RESIZE_WEST +(defconst x-pointer-sb-right-arrow 16) ; B_CURSOR_ID_RESIZE_EAST +(defconst x-pointer-sb-up-arrow 16) ; B_CURSOR_ID_RESIZE_NORTH +(defconst x-pointer-target 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-top-left-corner 20) ; B_CURSOR_ID_RESIZE_NORTH_WEST +(defconst x-pointer-top-right-corner 19) ; B_CURSOR_ID_RESIZE_NORTH_EAST +(defconst x-pointer-top-side 16) ; B_CURSOR_ID_RESIZE_NORTH +(defconst x-pointer-watch 14) ; B_CURSOR_ID_PROGRESS +(defconst x-pointer-invisible 12) ; B_CURSOR_ID_NO_CURSOR + +(provide 'haiku-win) +(provide 'term/haiku-win) + +;;; haiku-win.el ends here diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index ffcd7a852c2..e26191b33b4 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -97,8 +97,6 @@ The properties returned may include `top', `left', `height', and `width'." ;;;; Keyboard mapping. -(define-obsolete-variable-alias 'ns-alternatives-map 'x-alternatives-map "24.1") - ;; Here are some Nextstep-like bindings for command key sequences. (define-key global-map [?\s-,] 'customize) (define-key global-map [?\s-'] 'next-window-any-frame) @@ -142,7 +140,7 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [?\s-p] 'ns-print-buffer) (define-key global-map [?\s-q] 'save-buffers-kill-emacs) (define-key global-map [?\s-s] 'save-buffer) -(define-key global-map [?\s-t] 'ns-popup-font-panel) +(define-key global-map [?\s-t] 'menu-set-font) (define-key global-map [?\s-u] 'revert-buffer) (define-key global-map [?\s-v] 'yank) (define-key global-map [?\s-w] 'delete-frame) @@ -176,7 +174,6 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [ns-power-off] 'save-buffers-kill-emacs) (define-key global-map [ns-open-file] 'ns-find-file) (define-key global-map [ns-open-temp-file] [ns-open-file]) -(define-key global-map [ns-change-font] 'ns-respond-to-change-font) (define-key global-map [ns-open-file-line] 'ns-open-file-select-line) (define-key global-map [ns-spi-service-call] 'ns-spi-service-call) (define-key global-map [ns-new-frame] 'make-frame) @@ -508,25 +505,28 @@ unless the current buffer is a scratch buffer." Switch to a buffer editing the last file dropped, or insert the string dropped into the current buffer." (interactive "e") - (let* ((window (posn-window (event-start event))) - (arg (car (cdr (cdr event)))) - (type (car arg)) - (operations (car (cdr arg))) - (objects (cdr (cdr arg))) - (string (mapconcat 'identity objects "\n"))) - (set-frame-selected-window nil window) - (raise-frame) - (setq window (selected-window)) - (cond ((or (memq 'ns-drag-operation-generic operations) - (memq 'ns-drag-operation-copy operations)) - ;; Perform the default/copy action. - (dolist (data objects) - (dnd-handle-one-url window 'private (if (eq type 'file) - (concat "file:" data) - data)))) - (t - ;; Insert the text as is. - (dnd-insert-text window 'private string))))) + (if (eq (car-safe (cdr-safe (cdr-safe event))) 'lambda) + (dnd-handle-movement (event-start event)) + (let* ((window (posn-window (event-start event))) + (arg (car (cdr (cdr event)))) + (type (car arg)) + (operations (car (cdr arg))) + (objects (cdr (cdr arg))) + (string (mapconcat 'identity objects "\n"))) + (set-frame-selected-window nil window) + (raise-frame) + (setq window (selected-window)) + (goto-char (posn-point (event-start event))) + (cond ((or (memq 'ns-drag-operation-generic operations) + (memq 'ns-drag-operation-copy operations)) + ;; Perform the default/copy action. + (dolist (data objects) + (dnd-handle-one-url window 'private (if (eq type 'file) + (concat "file:" data) + data)))) + (t + ;; Insert the text as is. + (dnd-insert-text window 'private string)))))) (global-set-key [drag-n-drop] 'ns-drag-n-drop) @@ -620,34 +620,6 @@ If FRAME is nil, the change applies to the selected frame." ;; Needed for font listing functions under both backend and normal (setq scalable-fonts-allowed t) -;; Set to use font panel instead -(declare-function ns-popup-font-panel "nsfns.m" (&optional frame)) -(defalias 'x-select-font 'ns-popup-font-panel "Pop up the font panel. -This function has been overloaded in Nextstep.") -(defalias 'mouse-set-font 'ns-popup-font-panel "Pop up the font panel. -This function has been overloaded in Nextstep.") - -;; nsterm.m -(defvar ns-input-font) -(defvar ns-input-fontsize) - -(defun ns-respond-to-change-font () - "Set the font chosen in the font-picker panel. -Respond to changeFont: event, expecting ns-input-font and -ns-input-fontsize of new font." - (interactive) - (let ((face 'default)) - (set-face-attribute face t - :family ns-input-font - :height (* 10 ns-input-fontsize)) - (set-face-attribute face (selected-frame) - :family ns-input-font - :height (* 10 ns-input-fontsize)) - (let ((spec (list (list t (face-attr-construct 'default))))) - (put face 'customized-face spec) - (custom-push-theme 'theme-face face 'user 'set spec) - (put face 'face-modified nil)))) - ;; Default fontset for macOS. This is mainly here to show how a fontset ;; can be set up manually. Ordinarily, fontsets are auto-created whenever ;; a font is chosen by @@ -708,10 +680,6 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") ;;;; Pasteboard support. -(define-obsolete-function-alias 'ns-store-cut-buffer-internal - 'gui-set-selection "24.1") - - (defun ns-copy-including-secondary () (interactive) (call-interactively 'kill-ring-save) @@ -867,10 +835,10 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") ;; For Darwin nothing except UTF-8 makes sense. (when (eq system-type 'darwin) (add-hook 'before-init-hook - #'(lambda () - (setq locale-coding-system 'utf-8-unix) - (setq default-process-coding-system - '(utf-8-unix . utf-8-unix))))) + (lambda () + (setq locale-coding-system 'utf-8-unix) + (setq default-process-coding-system + '(utf-8-unix . utf-8-unix))))) ;; Mac OS X Lion introduces PressAndHold, which is unsupported by this port. ;; See this thread for more details: @@ -896,12 +864,18 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (declare-function ns-disown-selection-internal "nsselect.m" (selection)) (declare-function ns-selection-owner-p "nsselect.m" (&optional selection)) (declare-function ns-selection-exists-p "nsselect.m" (&optional selection)) +(declare-function ns-begin-drag "nsselect.m") + +(defvar ns-dnd-selection-value nil + "The value of the special `XdndSelection' selection on NS.") + (declare-function ns-get-selection "nsselect.m" (selection-symbol target-type)) -(cl-defmethod gui-backend-set-selection (selection value - &context (window-system ns)) - (if value (ns-own-selection-internal selection value) - (ns-disown-selection-internal selection))) +(cl-defmethod gui-backend-set-selection (selection value &context (window-system ns)) + (if (eq selection 'XdndSelection) + (setq ns-dnd-selection-value value) + (if value (ns-own-selection-internal selection value) + (ns-disown-selection-internal selection)))) (cl-defmethod gui-backend-selection-owner-p (selection &context (window-system ns)) @@ -915,6 +889,41 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") &context (window-system ns)) (ns-get-selection selection-symbol target-type)) +(defun x-begin-drag (targets &optional action frame return-frame + allow-current-frame follow-tooltip) + "SKIP: real doc in xfns.c." + (unless ns-dnd-selection-value + (error "No local value for XdndSelection")) + (let ((pasteboard nil)) + (when (and (member "STRING" targets) + (stringp ns-dnd-selection-value)) + (push (cons 'string ns-dnd-selection-value) pasteboard)) + (when (and (member "FILE_NAME" targets) + (file-exists-p ns-dnd-selection-value)) + (let ((value (if (stringp ns-dnd-selection-value) + (or (get-text-property 0 'FILE_NAME + ns-dnd-selection-value) + ns-dnd-selection-value) + ns-dnd-selection-value))) + (if (vectorp value) + (push (cons 'file + (cl-loop for file across value + collect (expand-file-name file))) + pasteboard) + (push (cons 'file + (url-encode-url (concat "file://" + (expand-file-name + ns-dnd-selection-value)))) + pasteboard)))) + (ns-begin-drag frame pasteboard action return-frame + allow-current-frame follow-tooltip))) + +(defun ns-handle-drag-motion (frame x y) + "Handle mouse movement on FRAME at X and Y during drag-and-drop. +This moves point to the current mouse position if + `dnd-indicate-insertion-point' is enabled." + (dnd-handle-movement (posn-at-x-y x y frame))) + (provide 'ns-win) (provide 'term/ns-win) diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el index 327d51f2759..514267a52d6 100644 --- a/lisp/term/pc-win.el +++ b/lisp/term/pc-win.el @@ -246,6 +246,14 @@ Consult the selection. Treat empty strings as if they were unset." ;; if it does not exist, or exists and compares ;; equal with the last text we've put into the ;; Windows clipboard. + ;; NOTE: that variable is actually the last text any program + ;; (not just Emacs) has put into the windows clipboard (up + ;; until the last time Emacs read or set the clipboard), so + ;; it's not suitable for checking actual selection + ;; ownership. This should not result in a bug for the current + ;; uses of gui-backend-selection-owner however, since they + ;; don't actually care about selection ownership, but about + ;; the selected text having changed. (cond ((not text) t) ((equal text gui--last-selected-text-clipboard) text) diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el new file mode 100644 index 00000000000..ee1aad3d0ec --- /dev/null +++ b/lisp/term/pgtk-win.el @@ -0,0 +1,400 @@ +;;; pgtk-win.el --- parse relevant switches and set up for Pure-GTK -*- lexical-binding: t -*- + +;; Copyright (C) 1995, 2001-2020, 2022 Free Software Foundation, Inc. + +;; Author: FSF +;; Keywords: terminals + +;; 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: + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(unless (featurep 'pgtk) + (error "%s: Loading pgtk-win.el but not compiled with PGTK." + invocation-name)) + +;; Documentation-purposes only: actually loaded in loadup.el. +(require 'term/common-win) +(require 'frame) +(require 'mouse) +(require 'scroll-bar) +(require 'faces) +(require 'menu-bar) +(require 'fontset) +(require 'dnd) +(require 'pgtk-dnd) + +(defvar x-invocation-args) +(defvar x-command-line-resources) +(defvar pgtk-input-file) +(defvar pgtk-use-im-context-on-new-connection) + +(declare-function pgtk-use-im-context "pgtkim.c") + +(defun pgtk-drag-n-drop (event &optional new-frame force-text) + "Edit the files listed in the drag-n-drop EVENT. +Switch to a buffer editing the last file dropped." + (interactive "e") + (let* ((window (posn-window (event-start event))) + (arg (car (cdr (cdr event)))) + (type (car arg)) + (data (car (cdr arg))) + (url-or-string (cond ((eq type 'file) + (concat "file:" data)) + (t data)))) + (set-frame-selected-window nil window) + (when new-frame + (select-frame (make-frame))) + (raise-frame) + (setq window (selected-window)) + (if force-text + (dnd-insert-text window 'private data) + (dnd-handle-one-url window 'private url-or-string)))) + +(defun pgtk-drag-n-drop-other-frame (event) + "Edit the files listed in the drag-n-drop EVENT, in other frames. +May create new frames, or reuse existing ones. The frame editing +the last file dropped is selected." + (interactive "e") + (pgtk-drag-n-drop event t)) + +(defun pgtk-drag-n-drop-as-text (event) + "Drop the data in EVENT as text." + (interactive "e") + (pgtk-drag-n-drop event nil t)) + +(defun pgtk-drag-n-drop-as-text-other-frame (event) + "Drop the data in EVENT as text in a new frame." + (interactive "e") + (pgtk-drag-n-drop event t t)) + +(global-set-key [drag-n-drop] 'pgtk-drag-n-drop) + +(defun pgtk-suspend-error () + "Don't allow suspending if any of the frames are PGTK frames." + (if (memq 'pgtk (mapcar 'window-system (frame-list))) + (error "Cannot suspend Emacs while a PGTK GUI frame exists"))) + +(defvar pgtk-initialized nil + "Non-nil if pure-GTK windowing has been initialized.") + +(declare-function x-handle-args "common-win" (args)) +(declare-function x-open-connection "pgtkfns.c" + (display &optional xrm-string must-succeed)) +(declare-function pgtk-set-resource "pgtkfns.c" (attribute value)) + +;; Do the actual window system setup here; the above code just defines +;; functions and variables that we use now. +(cl-defmethod window-system-initialization (&context (window-system pgtk) + &optional display) + "Initialize the PGTK window system. +WINDOW-SYSTEM is, aptly, `pgtk'. +DISPLAY is the name of the display Emacs should connect to." + (cl-assert (not pgtk-initialized)) + + ;; PENDING: not needed? + (setq command-line-args (x-handle-args command-line-args)) + + ;; Make sure we have a valid resource name. + (when (boundp 'x-resource-name) + (unless (stringp x-resource-name) + (let (i) + (setq x-resource-name (copy-sequence invocation-name)) + + ;; Change any . or * characters in x-resource-name to hyphens, + ;; so as not to choke when we use it in X resource queries. + (while (setq i (string-match "[.*]" x-resource-name)) + (aset x-resource-name i ?-))))) + + ;; Setup the default fontset. + (create-default-fontset) + ;; Create the standard fontset. + (condition-case err + (create-fontset-from-fontset-spec standard-fontset-spec t) + (error (display-warning + 'initialization + (format "Creation of the standard fontset failed: %s" err) + :error))) + + (x-open-connection (or display + x-display-name) + x-command-line-resources + ;; Exit Emacs with fatal error if this fails and we + ;; are the initial display. + (= (length (frame-list)) 0)) + + (x-apply-session-resources) + + ;; Don't let Emacs suspend under PGTK. + (add-hook 'suspend-hook 'pgtk-suspend-error) + + (setq pgtk-initialized t)) + +;; Any display name is OK. +(add-to-list 'display-format-alist '(".*" . pgtk)) + +(cl-defmethod handle-args-function (args &context (window-system pgtk)) + (x-handle-args args)) + +(cl-defmethod frame-creation-function (params &context (window-system pgtk)) + (x-create-frame-with-faces params)) + +(declare-function pgtk-own-selection-internal "pgtkselect.c" (selection value &optional frame)) +(declare-function pgtk-disown-selection-internal "pgtkselect.c" (selection &optional terminal)) +(declare-function pgtk-selection-owner-p "pgtkselect.c" (&optional selection terminal)) +(declare-function pgtk-selection-exists-p "pgtkselect.c" (&optional selection terminal)) +(declare-function pgtk-get-selection-internal "pgtkselect.c" (selection-symbol target-type &optional terminal)) + +(cl-defmethod gui-backend-set-selection (selection value + &context (window-system pgtk)) + (if value (pgtk-own-selection-internal selection value) + (pgtk-disown-selection-internal selection))) + +(cl-defmethod gui-backend-selection-owner-p (selection + &context (window-system pgtk)) + (pgtk-selection-owner-p selection)) + +(cl-defmethod gui-backend-selection-exists-p (selection + &context (window-system pgtk)) + (pgtk-selection-exists-p selection)) + +(cl-defmethod gui-backend-get-selection (selection-symbol target-type + &context (window-system pgtk)) + (pgtk-get-selection-internal selection-symbol target-type)) + + +(defvar pgtk-preedit-overlay nil) + +(defun pgtk-preedit-text (event) + "An internal function to display preedit text from input method. + +EVENT is a `preedit-text-event'." + (interactive "e") + (when pgtk-preedit-overlay + (delete-overlay pgtk-preedit-overlay)) + (setq pgtk-preedit-overlay nil) + + (let ((ovstr "") + (idx 0) + atts ov str color face-name) + (dolist (part (nth 1 event)) + (setq str (car part)) + (setq face-name (intern (format "pgtk-im-%d" idx))) + (eval + `(defface ,face-name nil "face of input method preedit")) + (setq atts nil) + (when (setq color (cdr-safe (assq 'fg (cdr part)))) + (setq atts (append atts `(:foreground ,color)))) + (when (setq color (cdr-safe (assq 'bg (cdr part)))) + (setq atts (append atts `(:background ,color)))) + (when (setq color (cdr-safe (assq 'ul (cdr part)))) + (setq atts (append atts `(:underline ,color)))) + (face-spec-set face-name `((t . ,atts))) + (add-text-properties 0 (length str) `(face ,face-name) str) + (setq ovstr (concat ovstr str)) + (setq idx (1+ idx))) + + (setq ov (make-overlay (point) (point))) + (overlay-put ov 'before-string ovstr) + (setq pgtk-preedit-overlay ov))) + +(define-key special-event-map [preedit-text] 'pgtk-preedit-text) + +(defun pgtk-use-im-context-handler () + "Set up input context usage after Emacs initialization." + (when (eq window-system 'pgtk) + (pgtk-use-im-context pgtk-use-im-context-on-new-connection))) + +(add-hook 'after-init-hook #'pgtk-use-im-context-handler) + +(defcustom x-gtk-stock-map + (mapcar (lambda (arg) + (cons (purecopy (car arg)) (purecopy (cdr arg)))) + '( + ("etc/images/new" . ("document-new" "gtk-new")) + ("etc/images/open" . ("document-open" "gtk-open")) + ("etc/images/diropen" . "n:system-file-manager") + ("etc/images/close" . ("window-close" "gtk-close")) + ("etc/images/save" . ("document-save" "gtk-save")) + ("etc/images/saveas" . ("document-save-as" "gtk-save-as")) + ("etc/images/undo" . ("edit-undo" "gtk-undo")) + ("etc/images/cut" . ("edit-cut" "gtk-cut")) + ("etc/images/copy" . ("edit-copy" "gtk-copy")) + ("etc/images/paste" . ("edit-paste" "gtk-paste")) + ("etc/images/search" . ("edit-find" "gtk-find")) + ("etc/images/print" . ("document-print" "gtk-print")) + ("etc/images/preferences" . ("preferences-system" "gtk-preferences")) + ("etc/images/help" . ("help-browser" "gtk-help")) + ("etc/images/left-arrow" . ("go-previous" "gtk-go-back")) + ("etc/images/right-arrow" . ("go-next" "gtk-go-forward")) + ("etc/images/home" . ("go-home" "gtk-home")) + ("etc/images/jump-to" . ("go-jump" "gtk-jump-to")) + ("etc/images/index" . ("gtk-search" "gtk-index")) + ("etc/images/exit" . ("application-exit" "gtk-quit")) + ("etc/images/cancel" . "gtk-cancel") + ("etc/images/info" . ("dialog-information" "gtk-info")) + ("etc/images/bookmark_add" . "n:bookmark_add") + ;; Used in Gnus and/or MH-E: + ("etc/images/attach" . ("mail-attachment" "gtk-attach")) + ("etc/images/connect" . "gtk-connect") + ("etc/images/contact" . "gtk-contact") + ("etc/images/delete" . ("edit-delete" "gtk-delete")) + ("etc/images/describe" . ("document-properties" "gtk-properties")) + ("etc/images/disconnect" . "gtk-disconnect") + ;; ("etc/images/exit" . "gtk-exit") + ("etc/images/lock-broken" . "gtk-lock_broken") + ("etc/images/lock-ok" . "gtk-lock_ok") + ("etc/images/lock" . "gtk-lock") + ("etc/images/next-page" . "gtk-next-page") + ("etc/images/refresh" . ("view-refresh" "gtk-refresh")) + ("etc/images/search-replace" . "edit-find-replace") + ("etc/images/sort-ascending" . ("view-sort-ascending" "gtk-sort-ascending")) + ("etc/images/sort-column-ascending" . "gtk-sort-column-ascending") + ("etc/images/sort-criteria" . "gtk-sort-criteria") + ("etc/images/sort-descending" . ("view-sort-descending" + "gtk-sort-descending")) + ("etc/images/sort-row-ascending" . "gtk-sort-row-ascending") + ("etc/images/spell" . ("tools-check-spelling" "gtk-spell-check")) + ("images/gnus/toggle-subscription" . "gtk-task-recurring") + ("images/mail/compose" . ("mail-message-new" "gtk-mail-compose")) + ("images/mail/copy" . "gtk-mail-copy") + ("images/mail/forward" . "gtk-mail-forward") + ("images/mail/inbox" . "gtk-inbox") + ("images/mail/move" . "gtk-mail-move") + ("images/mail/not-spam" . "gtk-not-spam") + ("images/mail/outbox" . "gtk-outbox") + ("images/mail/reply-all" . "gtk-mail-reply-to-all") + ("images/mail/reply" . "gtk-mail-reply") + ("images/mail/save-draft" . "gtk-mail-handling") + ("images/mail/send" . ("mail-send" "gtk-mail-send")) + ("images/mail/spam" . "gtk-spam") + ;; Used for GDB Graphical Interface + ("images/gud/break" . "gtk-no") + ("images/gud/recstart" . ("media-record" "gtk-media-record")) + ("images/gud/recstop" . ("media-playback-stop" "gtk-media-stop")) + ;; No themed versions available: + ;; mail/preview (combining stock_mail and stock_zoom) + ;; mail/save (combining stock_mail, stock_save and stock_convert) + )) + "How icons for tool bars are mapped to Gtk+ stock items. +Emacs must be compiled with the Gtk+ toolkit for this to have any effect. +A value that begins with n: denotes a named icon instead of a stock icon." + :version "22.2" + :type '(choice (repeat + (choice symbol + (cons (string :tag "Emacs icon") + (choice (group (string :tag "Named") + (string :tag "Stock")) + (string :tag "Stock/named")))))) + :group 'pgtk) + +(defcustom icon-map-list '(x-gtk-stock-map) + "A list of alists that map icon file names to stock/named icons. +The alists are searched in the order they appear. The first match is used. +The keys in the alists are file names without extension and with two directory +components. For example, to map /usr/share/emacs/22.1.1/etc/images/open.xpm +to stock item gtk-open, use: + + (\"etc/images/open\" . \"gtk-open\") + +Themes also have named icons. To map to one of those, use n: before the name: + + (\"etc/images/diropen\" . \"n:system-file-manager\") + +The list elements are either the symbol name for the alist or the +alist itself. + +If you don't want stock icons, set the variable to nil." + :version "22.2" + :type '(choice (const :tag "Don't use stock icons" nil) + (repeat (choice symbol + (cons (string :tag "Emacs icon") + (string :tag "Stock/named"))))) + :group 'pgtk) + +(defconst x-gtk-stock-cache (make-hash-table :weakness t :test 'equal)) + +(defun x-gtk-map-stock (file) + "Map icon with file name FILE to a Gtk+ stock name. +This uses `icon-map-list' to map icon file names to stock icon names." + (when (stringp file) + (or (gethash file x-gtk-stock-cache) + (puthash + file + (save-match-data + (let* ((file-sans (file-name-sans-extension file)) + (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)" + file-sans) + (match-string 1 file-sans))) + (icon-map icon-map-list) + elem value) + (while (and (null value) icon-map) + (setq elem (car icon-map) + value (assoc-string (or key file-sans) + (if (symbolp elem) + (symbol-value elem) + elem)) + icon-map (cdr icon-map))) + (and value (cdr value)))) + x-gtk-stock-cache)))) + +(declare-function accelerate-menu "pgtkmenu.c" (&optional frame) t) + +(defun pgtk-menu-bar-open (&optional frame) + "Open the menu bar if it is shown. +`popup-menu' is used if it is off." + (interactive "i") + (cond + ((and (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0))) + (fboundp 'accelerate-menu)) + (accelerate-menu frame)) + (t + (popup-menu (mouse-menu-bar-map) last-nonmenu-event)))) + +(defun pgtk-device-class (name) + "Return the device class of NAME. +Users should not call this function; see `device-class' instead." + (cond + ((string-match-p "XTEST" name) 'test) + ((string= "Virtual core pointer" name) 'core-pointer) + ((string= "Virtual core keyboard" name) 'core-keyboard) + (t (let ((number (ignore-errors + (string-to-number name)))) + (when number + (cl-case number + (0 'mouse) + (1 'pen) + (2 'eraser) + (3 'puck) + (4 'keyboard) + (5 'touchscreen) + (6 'touchpad) + (7 'trackpoint) + (8 'pad))))))) + +(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips) + + +(define-key special-event-map [drag-n-drop] #'pgtk-dnd-handle-drag-n-drop-event) +(add-hook 'after-make-frame-functions #'pgtk-dnd-init-frame) + +(provide 'pgtk-win) +(provide 'term/pgtk-win) + +;;; pgtk-win.el ends here diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 8b39ed9d86e..993f1d43208 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -81,7 +81,6 @@ (&optional frame exclude-proportional)) (defvar w32-color-map) ;; defined in w32fns.c -(make-obsolete 'w32-default-color-map nil "24.1") (declare-function w32-send-sys-command "w32fns.c") (declare-function set-message-beep "w32fns.c") @@ -274,6 +273,9 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(gif "libgif-6.dll" "giflib5.dll" "gif.dll") '(gif "libgif-5.dll" "giflib4.dll" "libungif4.dll" "libungif.dll"))) '(svg "librsvg-2-2.dll") + '(webp "libwebp-7.dll" "libwebp.dll") + '(webpdemux "libwebpdemux-2.dll" "libwebpdemux.dll") + '(sqlite3 "libsqlite3-0.dll") '(gdk-pixbuf "libgdk_pixbuf-2.0-0.dll") '(glib "libglib-2.0-0.dll") '(gio "libgio-2.0-0.dll") diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index 62cd9848667..55fe11a097c 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -85,6 +85,8 @@ (defvar x-selection-timeout) (defvar x-session-id) (defvar x-session-previous-id) +(defvar x-dnd-movement-function) +(defvar x-dnd-unsupported-drop-function) (defun x-handle-no-bitmap-icon (_switch) (setq default-frame-alist (cons '(icon-type) default-frame-alist))) @@ -107,14 +109,6 @@ (setq x-session-previous-id (car x-invocation-args) x-invocation-args (cdr x-invocation-args))) -(defvar emacs-save-session-functions nil - "Special hook run when a save-session event occurs. -The functions do not get any argument. -Functions can return non-nil to inform the session manager that the -window system shutdown should be aborted. - -See also `emacs-session-save'.") - (defun emacs-session-filename (session-id) "Construct a filename to save the session in based on SESSION-ID. Return a filename in `user-emacs-directory', unless the session file @@ -247,7 +241,9 @@ exists." (defconst x-pointer-ur-angle 148) (defconst x-pointer-watch 150) (defconst x-pointer-xterm 152) -(defconst x-pointer-invisible 255) +(defconst x-pointer-invisible 65536) ;; This value is larger than a + ;; CARD16, so it cannot be a + ;; valid cursor. ;;;; Keysyms @@ -1175,9 +1171,6 @@ as returned by `x-server-vendor'." ;;;; Selections -(define-obsolete-function-alias 'x-cut-buffer-or-selection-value - 'x-selection-value "24.1") - ;; Arrange for the kill and yank functions to set and check the clipboard. (defun x-clipboard-yank () @@ -1186,8 +1179,12 @@ as returned by `x-server-vendor'." (interactive "*") (let ((clipboard-text (gui--selection-value-internal 'CLIPBOARD)) (select-enable-clipboard t)) - (if (and clipboard-text (> (length clipboard-text) 0)) - (kill-new clipboard-text)) + (when (and clipboard-text (> (length clipboard-text) 0)) + ;; Avoid asserting ownership of CLIPBOARD, which will cause + ;; `gui-selection-value' to return nil in the future. + ;; (bug#56273) + (let ((select-enable-clipboard nil)) + (kill-new clipboard-text))) (yank))) (declare-function accelerate-menu "xmenu.c" (&optional frame) t) @@ -1295,14 +1292,6 @@ This returns an error if any Emacs frames are X frames." (cons (cons 'width (cdr (assq 'width parsed))) default-frame-alist)))))) - ;; Check the reverseVideo resource. - (let ((case-fold-search t)) - (let ((rv (x-get-resource "reverseVideo" "ReverseVideo"))) - (if (and rv - (string-match "^\\(true\\|yes\\|on\\)$" rv)) - (setq default-frame-alist - (cons '(reverse . t) default-frame-alist))))) - ;; Set x-selection-timeout, measured in milliseconds. (let ((res-selection-timeout (x-get-resource "selectionTimeout" "SelectionTimeout"))) @@ -1378,7 +1367,8 @@ This returns an error if any Emacs frames are X frames." (cl-defmethod gui-backend-get-selection (selection-symbol target-type &context (window-system x) &optional time-stamp terminal) - (x-get-selection-internal selection-symbol target-type time-stamp terminal)) + (x-get-selection-internal selection-symbol target-type + time-stamp terminal)) ;; Initiate drag and drop (add-hook 'after-make-frame-functions 'x-dnd-init-frame) @@ -1489,6 +1479,12 @@ If you don't want stock icons, set the variable to nil." (string :tag "Stock/named"))))) :group 'x) +(defcustom x-display-cursor-at-start-of-preedit-string nil + "If non-nil, display the cursor at the start of any pre-edit text." + :version "29.1" + :type 'boolean + :group 'x) + (defconst x-gtk-stock-cache (make-hash-table :weakness t :test 'equal)) (defun x-gtk-map-stock (file) @@ -1517,6 +1513,105 @@ This uses `icon-map-list' to map icon file names to stock icon names." (global-set-key [XF86WakeUp] 'ignore) + +(defvar x-preedit-overlay nil + "The overlay currently used to display preedit text from a compose sequence.") + +;; With some input methods, text gets inserted before Emacs is told to +;; remove any preedit text that was displayed, which causes both the +;; preedit overlay and the text to be visible for a brief period of +;; time. This pre-command-hook clears the overlay before any command +;; and should be set whenever a preedit overlay is visible. +(defun x-clear-preedit-text () + "Clear the pre-edit overlay and remove itself from pre-command-hook. +This function should be installed in `pre-command-hook' whenever +preedit text is displayed." + (when x-preedit-overlay + (delete-overlay x-preedit-overlay) + (setq x-preedit-overlay nil)) + (remove-hook 'pre-command-hook #'x-clear-preedit-text)) + +(defun x-preedit-text (event) + "Display preedit text from a compose sequence in EVENT. +EVENT is a preedit-text event." + (interactive "e") + (when x-preedit-overlay + (delete-overlay x-preedit-overlay) + (setq x-preedit-overlay nil) + (remove-hook 'pre-command-hook #'x-clear-preedit-text)) + (when (nth 1 event) + (let ((string (propertize (nth 1 event) 'face '(:underline t)))) + (setq x-preedit-overlay (make-overlay (point) (point))) + (add-hook 'pre-command-hook #'x-clear-preedit-text) + (overlay-put x-preedit-overlay 'window (selected-window)) + (overlay-put x-preedit-overlay 'before-string + (if x-display-cursor-at-start-of-preedit-string + (propertize string 'cursor t) + string))))) + +(define-key special-event-map [preedit-text] 'x-preedit-text) + +(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips) + +(declare-function x-internal-focus-input-context "xfns.c" (focus)) + +(defun x-gtk-use-native-input-watcher (_symbol newval &rest _ignored) + "Variable watcher for `x-gtk-use-native-input'. +If NEWVAL is non-nil, focus the GTK input context of focused +frames on all displays." + (when (and (featurep 'gtk) + (eq (framep (selected-frame)) 'x)) + (x-internal-focus-input-context newval))) + +(add-variable-watcher 'x-gtk-use-native-input + #'x-gtk-use-native-input-watcher) + +(defun x-dnd-movement (_frame position) + "Handle movement to POSITION during drag-and-drop." + (dnd-handle-movement position)) + +(defun x-device-class (name) + "Return the device class of NAME. +Users should not call this function; see `device-class' instead." + (let ((downcased-name (downcase name))) + (cond + ((string-match-p "XTEST" name) 'test) + ((string= "Virtual core pointer" name) 'core-pointer) + ((string= "Virtual core keyboard" name) 'core-keyboard) + ((string-match-p "eraser" downcased-name) 'eraser) + ((string-match-p " pad" downcased-name) 'pad) + ((or (or (string-match-p "wacom" downcased-name) + (string-match-p "pen" downcased-name)) + (string-match-p "stylus" downcased-name)) + 'pen) + ((or (string-prefix-p "xwayland-touch:" name) + (string-match-p "touchscreen" downcased-name)) + 'touchscreen) + ((or (string-match-p "trackpoint" downcased-name) + (string-match-p "stick" downcased-name)) + 'trackpoint) + ((or (string-match-p "mouse" downcased-name) + (string-match-p "optical" downcased-name) + (string-match-p "pointer" downcased-name)) + 'mouse) + ((string-match-p "cursor" downcased-name) 'puck) + ((or (string-match-p "keyboard" downcased-name) + ;; One of my cheap keyboards is really named this... + (string= name "USB USB Keykoard")) + 'keyboard) + ((string-match-p "button" downcased-name) 'power-button) + ((string-match-p "touchpad" downcased-name) 'touchpad) + ((or (string-match-p "midi" downcased-name) + (string-match-p "piano" downcased-name)) + 'piano) + ((or (string-match-p "wskbd" downcased-name) ; NetBSD/OpenBSD + (and (string-match-p "/dev" downcased-name) + (string-match-p "kbd" downcased-name))) + 'keyboard)))) + +(setq x-dnd-movement-function #'x-dnd-movement) +(setq x-dnd-unsupported-drop-function #'x-dnd-handle-unsupported-drop) + (provide 'x-win) (provide 'term/x-win) diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el index a7e257f41c5..08e38c9a050 100644 --- a/lisp/term/xterm.el +++ b/lisp/term/xterm.el @@ -66,7 +66,7 @@ If you select a region larger than this size, it won't be copied to your system clipboard. Since clipboard data is base 64 encoded, the actual number of string bytes that can be copied is 3/4 of this value." :version "25.1" - :type 'integer) + :type 'natnum) (defcustom xterm-set-window-title nil "Whether Emacs should set window titles to an Emacs frame in an XTerm." |