1;;; xterm.el --- define function key sequences and standard colors for xterm -*- lexical-binding: t -*- 2 3;; Copyright (C) 1995, 2001-2020 Free Software Foundation, Inc. 4 5;; Author: FSF 6;; Keywords: terminals 7 8;; This file is part of GNU Emacs. 9 10;; GNU Emacs is free software: you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation, either version 3 of the License, or 13;; (at your option) any later version. 14 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 22 23;;; Commentary: 24 25;;; Code: 26(eval-when-compile (require 'cl-lib)) 27(or (featurep 'pgtk) 28 (error "%s: Loading pgtk-win.el but not compiled for pure Gtk+-3." 29 invocation-name)) 30 31;; Documentation-purposes only: actually loaded in loadup.el. 32(require 'term/common-win) 33(require 'frame) 34(require 'mouse) 35(require 'scroll-bar) 36(require 'faces) 37(require 'menu-bar) 38(require 'fontset) 39(require 'dnd) 40 41(defgroup pgtk nil 42 "Pure-GTK specific features." 43 :group 'environment) 44 45;;;; Command line argument handling. 46 47(defvar x-invocation-args) 48;; Set in term/common-win.el; currently unused by Gtk's x-open-connection. 49(defvar x-command-line-resources) 50 51;; pgtkterm.c. 52(defvar pgtk-input-file) 53 54(declare-function pgtk-use-im-context "pgtkim.c") 55(defvar pgtk-use-im-context-on-new-connection) 56 57(defun pgtk-handle-nxopen (_switch &optional temp) 58 (setq unread-command-events (append unread-command-events 59 (if temp '(pgtk-open-temp-file) 60 '(pgtk-open-file))) 61 pgtk-input-file (append pgtk-input-file (list (pop x-invocation-args))))) 62 63(defun pgtk-handle-nxopentemp (switch) 64 (pgtk-handle-nxopen switch t)) 65 66(defun pgtk-ignore-1-arg (_switch) 67 (setq x-invocation-args (cdr x-invocation-args))) 68 69;;;; File handling. 70 71(declare-function pgtk-hide-emacs "pgtkfns.c" (on)) 72 73 74(defun pgtk-drag-n-drop (event &optional new-frame force-text) 75 "Edit the files listed in the drag-n-drop EVENT. 76Switch to a buffer editing the last file dropped." 77 (interactive "e") 78 (let* ((window (posn-window (event-start event))) 79 (arg (car (cdr (cdr event)))) 80 (type (car arg)) 81 (data (car (cdr arg))) 82 (url-or-string (cond ((eq type 'file) 83 (concat "file:" data)) 84 (t data)))) 85 (set-frame-selected-window nil window) 86 (when new-frame 87 (select-frame (make-frame))) 88 (raise-frame) 89 (setq window (selected-window)) 90 (if force-text 91 (dnd-insert-text window 'private data) 92 (dnd-handle-one-url window 'private url-or-string)))) 93 94 95(defun pgtk-drag-n-drop-other-frame (event) 96 "Edit the files listed in the drag-n-drop EVENT, in other frames. 97May create new frames, or reuse existing ones. The frame editing 98the last file dropped is selected." 99 (interactive "e") 100 (pgtk-drag-n-drop event t)) 101 102(defun pgtk-drag-n-drop-as-text (event) 103 "Drop the data in EVENT as text." 104 (interactive "e") 105 (pgtk-drag-n-drop event nil t)) 106 107(defun pgtk-drag-n-drop-as-text-other-frame (event) 108 "Drop the data in EVENT as text in a new frame." 109 (interactive "e") 110 (pgtk-drag-n-drop event t t)) 111 112(global-set-key [drag-n-drop] 'pgtk-drag-n-drop) 113(global-set-key [C-drag-n-drop] 'pgtk-drag-n-drop-other-frame) 114(global-set-key [M-drag-n-drop] 'pgtk-drag-n-drop-as-text) 115(global-set-key [C-M-drag-n-drop] 'pgtk-drag-n-drop-as-text-other-frame) 116 117;;;; Frame-related functions. 118 119;; pgtkterm.c 120(defvar pgtk-alternate-modifier) 121(defvar pgtk-right-alternate-modifier) 122(defvar pgtk-right-command-modifier) 123(defvar pgtk-right-control-modifier) 124 125;; You say tomAYto, I say tomAHto.. 126(with-no-warnings 127 (defvaralias 'pgtk-option-modifier 'pgtk-alternate-modifier) 128 (defvaralias 'pgtk-right-option-modifier 'pgtk-right-alternate-modifier)) 129 130(defun pgtk-do-hide-emacs () 131 (interactive) 132 (pgtk-hide-emacs t)) 133 134(declare-function pgtk-hide-others "pgtkfns.c" ()) 135 136(defun pgtk-do-hide-others () 137 (interactive) 138 (pgtk-hide-others)) 139 140(declare-function pgtk-emacs-info-panel "pgtkfns.c" ()) 141 142(defun pgtk-do-emacs-info-panel () 143 (interactive) 144 (pgtk-emacs-info-panel)) 145 146(defun pgtk-next-frame () 147 "Switch to next visible frame." 148 (interactive) 149 (other-frame 1)) 150 151(defun pgtk-prev-frame () 152 "Switch to previous visible frame." 153 (interactive) 154 (other-frame -1)) 155 156;; Frame will be focused anyway, so select it 157;; (if this is not done, mode line is dimmed until first interaction) 158;; FIXME: Sounds like we're working around a bug in the underlying code. 159(add-hook 'after-make-frame-functions 'select-frame) 160 161(defvar tool-bar-mode) 162(declare-function tool-bar-mode "tool-bar" (&optional arg)) 163 164;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ; 165;; see https://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html . 166(defun pgtk-toggle-toolbar (&optional frame) 167 "Switches the tool bar on and off in frame FRAME. 168 If FRAME is nil, the change applies to the selected frame." 169 (interactive) 170 (modify-frame-parameters 171 frame (list (cons 'tool-bar-lines 172 (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0) 173 0 1)) )) 174 (if (not tool-bar-mode) (tool-bar-mode t))) 175 176 177;;;; Dialog-related functions. 178 179;; Ask user for confirm before printing. Due to Kevin Rodgers. 180(defun pgtk-print-buffer () 181 "Interactive front-end to `print-buffer': asks for user confirmation first." 182 (interactive) 183 (if (and (called-interactively-p 'interactive) 184 (or (listp last-nonmenu-event) 185 (and (char-or-string-p (event-basic-type last-command-event)) 186 (memq 'super (event-modifiers last-command-event))))) 187 (let ((last-nonmenu-event (if (listp last-nonmenu-event) 188 last-nonmenu-event 189 ;; Fake it: 190 `(mouse-1 POSITION 1)))) 191 (if (y-or-n-p (format "Print buffer %s? " (buffer-name))) 192 (print-buffer) 193 (error "Canceled"))) 194 (print-buffer))) 195 196;;;; Font support. 197 198;; Needed for font listing functions under both backend and normal 199(setq scalable-fonts-allowed t) 200 201;; Default fontset. This is mainly here to show how a fontset 202;; can be set up manually. Ordinarily, fontsets are auto-created whenever 203;; a font is chosen by 204(defvar pgtk-standard-fontset-spec 205 ;; Only some code supports this so far, so use uglier XLFD version 206 ;; "-pgtk-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai" 207 (mapconcat 'identity 208 '("-*-Monospace-*-*-*-*-10-*-*-*-*-*-fontset-standard" 209 "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1") 210 ",") 211 "String of fontset spec of the standard fontset. 212This defines a fontset consisting of the Courier and other fonts. 213See the documentation of `create-fontset-from-fontset-spec' for the format.") 214 215 216;;;; Pasteboard support. 217 218(define-obsolete-function-alias 'pgtk-store-cut-buffer-internal 219 'gui-set-selection "24.1") 220 221 222(defun pgtk-copy-including-secondary () 223 (interactive) 224 (call-interactively 'kill-ring-save) 225 (gui-set-selection 'SECONDARY (buffer-substring (point) (mark t)))) 226 227(defun pgtk-paste-secondary () 228 (interactive) 229 (insert (gui-get-selection 'SECONDARY))) 230 231 232(defun pgtk-suspend-error () 233 ;; Don't allow suspending if any of the frames are PGTK frames. 234 (if (memq 'pgtk (mapcar 'window-system (frame-list))) 235 (error "Cannot suspend Emacs while a PGTK GUI frame exists"))) 236 237 238 239(defvar pgtk-initialized nil 240 "Non-nil if pure-GTK windowing has been initialized.") 241 242(declare-function x-handle-args "common-win" (args)) 243(declare-function x-open-connection "pgtkfns.c" 244 (display &optional xrm-string must-succeed)) 245(declare-function pgtk-set-resource "pgtkfns.c" (owner name value)) 246 247;; Do the actual pure-GTK Windows setup here; the above code just 248;; defines functions and variables that we use now. 249(cl-defmethod window-system-initialization (&context (window-system pgtk) 250 &optional display) 251 "Initialize Emacs for pure-GTK windowing." 252 (cl-assert (not pgtk-initialized)) 253 254 ;; PENDING: not needed? 255 (setq command-line-args (x-handle-args command-line-args)) 256 257 ;; Make sure we have a valid resource name. 258 (or (stringp x-resource-name) 259 (let (i) 260 (setq x-resource-name (copy-sequence invocation-name)) 261 262 ;; Change any . or * characters in x-resource-name to hyphens, 263 ;; so as not to choke when we use it in X resource queries. 264 (while (setq i (string-match "[.*]" x-resource-name)) 265 (aset x-resource-name i ?-)))) 266 267 ;; Setup the default fontset. 268 (create-default-fontset) 269 ;; Create the standard fontset. 270 (condition-case err 271 (create-fontset-from-fontset-spec pgtk-standard-fontset-spec t) 272 (error (display-warning 273 'initialization 274 (format "Creation of the standard fontset failed: %s" err) 275 :error))) 276 277 (x-open-connection (or display 278 x-display-name) 279 x-command-line-resources 280 ;; Exit Emacs with fatal error if this fails and we 281 ;; are the initial display. 282 (= (length (frame-list)) 0)) 283 284 (x-apply-session-resources) 285 286 ;; Don't let Emacs suspend under PGTK. 287 (add-hook 'suspend-hook 'pgtk-suspend-error) 288 289 (setq pgtk-initialized t)) 290 291;; Any display name is OK. 292(add-to-list 'display-format-alist '(".*" . pgtk)) 293(cl-defmethod handle-args-function (args &context (window-system pgtk)) 294 (x-handle-args args)) 295 296(cl-defmethod frame-creation-function (params &context (window-system pgtk)) 297 (x-create-frame-with-faces params)) 298 299(declare-function pgtk-own-selection-internal "pgtkselect.c" (selection value &optional frame)) 300(declare-function pgtk-disown-selection-internal "pgtkselect.c" (selection &optional time_object terminal)) 301(declare-function pgtk-selection-owner-p "pgtkselect.c" (&optional selection terminal)) 302(declare-function pgtk-selection-exists-p "pgtkselect.c" (&optional selection terminal)) 303(declare-function pgtk-get-selection-internal "pgtkselect.c" (selection-symbol target-type &optional time_stamp terminal)) 304 305(cl-defmethod gui-backend-set-selection (selection value 306 &context (window-system pgtk)) 307 (if value (pgtk-own-selection-internal selection value) 308 (pgtk-disown-selection-internal selection))) 309 310(cl-defmethod gui-backend-selection-owner-p (selection 311 &context (window-system pgtk)) 312 (pgtk-selection-owner-p selection)) 313 314(cl-defmethod gui-backend-selection-exists-p (selection 315 &context (window-system pgtk)) 316 (pgtk-selection-exists-p selection)) 317 318(cl-defmethod gui-backend-get-selection (selection-symbol target-type 319 &context (window-system pgtk)) 320 (pgtk-get-selection-internal selection-symbol target-type)) 321 322 323(defvar pgtk-preedit-overlay nil) 324 325(defun pgtk-preedit-text (event) 326 "An internal function to display preedit text from input method. 327 328EVENT is an event of PGTK_PREEDIT_TEXT_EVENT. 329It contains colors and texts." 330 (interactive "e") 331 (when pgtk-preedit-overlay 332 (delete-overlay pgtk-preedit-overlay)) 333 (setq pgtk-preedit-overlay nil) 334 335 (let ((ovstr "") 336 (idx 0) 337 atts ov str color face-name) 338 (dolist (part (nth 1 event)) 339 (setq str (car part)) 340 (setq face-name (intern (format "pgtk-im-%d" idx))) 341 (eval 342 `(defface ,face-name nil "face of input method preedit")) 343 (setq atts nil) 344 (when (setq color (cdr-safe (assq 'fg (cdr part)))) 345 (setq atts (append atts `(:foreground ,color)))) 346 (when (setq color (cdr-safe (assq 'bg (cdr part)))) 347 (setq atts (append atts `(:background ,color)))) 348 (when (setq color (cdr-safe (assq 'ul (cdr part)))) 349 (setq atts (append atts `(:underline ,color)))) 350 (face-spec-set face-name `((t . ,atts))) 351 (add-text-properties 0 (length str) `(face ,face-name) str) 352 (setq ovstr (concat ovstr str)) 353 (setq idx (1+ idx))) 354 355 (setq ov (make-overlay (point) (point))) 356 (overlay-put ov 'before-string ovstr) 357 (setq pgtk-preedit-overlay ov))) 358 359 360(add-hook 'after-init-hook 361 (function 362 (lambda () 363 (when (eq window-system 'pgtk) 364 (pgtk-use-im-context pgtk-use-im-context-on-new-connection))))) 365 366 367;;; 368 369(defcustom x-gtk-stock-map 370 (mapcar (lambda (arg) 371 (cons (purecopy (car arg)) (purecopy (cdr arg)))) 372 '( 373 ("etc/images/new" . ("document-new" "gtk-new")) 374 ("etc/images/open" . ("document-open" "gtk-open")) 375 ("etc/images/diropen" . "n:system-file-manager") 376 ("etc/images/close" . ("window-close" "gtk-close")) 377 ("etc/images/save" . ("document-save" "gtk-save")) 378 ("etc/images/saveas" . ("document-save-as" "gtk-save-as")) 379 ("etc/images/undo" . ("edit-undo" "gtk-undo")) 380 ("etc/images/cut" . ("edit-cut" "gtk-cut")) 381 ("etc/images/copy" . ("edit-copy" "gtk-copy")) 382 ("etc/images/paste" . ("edit-paste" "gtk-paste")) 383 ("etc/images/search" . ("edit-find" "gtk-find")) 384 ("etc/images/print" . ("document-print" "gtk-print")) 385 ("etc/images/preferences" . ("preferences-system" "gtk-preferences")) 386 ("etc/images/help" . ("help-browser" "gtk-help")) 387 ("etc/images/left-arrow" . ("go-previous" "gtk-go-back")) 388 ("etc/images/right-arrow" . ("go-next" "gtk-go-forward")) 389 ("etc/images/home" . ("go-home" "gtk-home")) 390 ("etc/images/jump-to" . ("go-jump" "gtk-jump-to")) 391 ("etc/images/index" . ("gtk-search" "gtk-index")) 392 ("etc/images/exit" . ("application-exit" "gtk-quit")) 393 ("etc/images/cancel" . "gtk-cancel") 394 ("etc/images/info" . ("dialog-information" "gtk-info")) 395 ("etc/images/bookmark_add" . "n:bookmark_add") 396 ;; Used in Gnus and/or MH-E: 397 ("etc/images/attach" . ("mail-attachment" "gtk-attach")) 398 ("etc/images/connect" . "gtk-connect") 399 ("etc/images/contact" . "gtk-contact") 400 ("etc/images/delete" . ("edit-delete" "gtk-delete")) 401 ("etc/images/describe" . ("document-properties" "gtk-properties")) 402 ("etc/images/disconnect" . "gtk-disconnect") 403 ;; ("etc/images/exit" . "gtk-exit") 404 ("etc/images/lock-broken" . "gtk-lock_broken") 405 ("etc/images/lock-ok" . "gtk-lock_ok") 406 ("etc/images/lock" . "gtk-lock") 407 ("etc/images/next-page" . "gtk-next-page") 408 ("etc/images/refresh" . ("view-refresh" "gtk-refresh")) 409 ("etc/images/search-replace" . "edit-find-replace") 410 ("etc/images/sort-ascending" . ("view-sort-ascending" "gtk-sort-ascending")) 411 ("etc/images/sort-column-ascending" . "gtk-sort-column-ascending") 412 ("etc/images/sort-criteria" . "gtk-sort-criteria") 413 ("etc/images/sort-descending" . ("view-sort-descending" 414 "gtk-sort-descending")) 415 ("etc/images/sort-row-ascending" . "gtk-sort-row-ascending") 416 ("etc/images/spell" . ("tools-check-spelling" "gtk-spell-check")) 417 ("images/gnus/toggle-subscription" . "gtk-task-recurring") 418 ("images/mail/compose" . ("mail-message-new" "gtk-mail-compose")) 419 ("images/mail/copy" . "gtk-mail-copy") 420 ("images/mail/forward" . "gtk-mail-forward") 421 ("images/mail/inbox" . "gtk-inbox") 422 ("images/mail/move" . "gtk-mail-move") 423 ("images/mail/not-spam" . "gtk-not-spam") 424 ("images/mail/outbox" . "gtk-outbox") 425 ("images/mail/reply-all" . "gtk-mail-reply-to-all") 426 ("images/mail/reply" . "gtk-mail-reply") 427 ("images/mail/save-draft" . "gtk-mail-handling") 428 ("images/mail/send" . ("mail-send" "gtk-mail-send")) 429 ("images/mail/spam" . "gtk-spam") 430 ;; Used for GDB Graphical Interface 431 ("images/gud/break" . "gtk-no") 432 ("images/gud/recstart" . ("media-record" "gtk-media-record")) 433 ("images/gud/recstop" . ("media-playback-stop" "gtk-media-stop")) 434 ;; No themed versions available: 435 ;; mail/preview (combining stock_mail and stock_zoom) 436 ;; mail/save (combining stock_mail, stock_save and stock_convert) 437 )) 438 "How icons for tool bars are mapped to Gtk+ stock items. 439Emacs must be compiled with the Gtk+ toolkit for this to have any effect. 440A value that begins with n: denotes a named icon instead of a stock icon." 441 :version "22.2" 442 :type '(choice (repeat 443 (choice symbol 444 (cons (string :tag "Emacs icon") 445 (choice (group (string :tag "Named") 446 (string :tag "Stock")) 447 (string :tag "Stock/named")))))) 448 :group 'pgtk) 449 450(defcustom icon-map-list '(x-gtk-stock-map) 451 "A list of alists that map icon file names to stock/named icons. 452The alists are searched in the order they appear. The first match is used. 453The keys in the alists are file names without extension and with two directory 454components. For example, to map /usr/share/emacs/22.1.1/etc/images/open.xpm 455to stock item gtk-open, use: 456 457 (\"etc/images/open\" . \"gtk-open\") 458 459Themes also have named icons. To map to one of those, use n: before the name: 460 461 (\"etc/images/diropen\" . \"n:system-file-manager\") 462 463The list elements are either the symbol name for the alist or the 464alist itself. 465 466If you don't want stock icons, set the variable to nil." 467 :version "22.2" 468 :type '(choice (const :tag "Don't use stock icons" nil) 469 (repeat (choice symbol 470 (cons (string :tag "Emacs icon") 471 (string :tag "Stock/named"))))) 472 :group 'pgtk) 473 474(defconst x-gtk-stock-cache (make-hash-table :weakness t :test 'equal)) 475 476(defun x-gtk-map-stock (file) 477 "Map icon with file name FILE to a Gtk+ stock name. 478This uses `icon-map-list' to map icon file names to stock icon names." 479 (when (stringp file) 480 (or (gethash file x-gtk-stock-cache) 481 (puthash 482 file 483 (save-match-data 484 (let* ((file-sans (file-name-sans-extension file)) 485 (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)" 486 file-sans) 487 (match-string 1 file-sans))) 488 (icon-map icon-map-list) 489 elem value) 490 (while (and (null value) icon-map) 491 (setq elem (car icon-map) 492 value (assoc-string (or key file-sans) 493 (if (symbolp elem) 494 (symbol-value elem) 495 elem)) 496 icon-map (cdr icon-map))) 497 (and value (cdr value)))) 498 x-gtk-stock-cache)))) 499 500(declare-function accelerate-menu "pgtkmenu.c" (&optional frame) t) 501 502(defun pgtk-menu-bar-open (&optional frame) 503 "Open the menu bar if it is shown. 504`popup-menu' is used if it is off." 505 (interactive "i") 506 (cond 507 ((and (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0))) 508 (fboundp 'accelerate-menu)) 509 (accelerate-menu frame)) 510 (t 511 (popup-menu (mouse-menu-bar-map) last-nonmenu-event)))) 512 513(provide 'pgtk-win) 514(provide 'term/pgtk-win) 515 516;;; pgtk-win.el ends here 517