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