summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/cus-edit.el10
-rw-r--r--lisp/faces.el11
-rw-r--r--lisp/frame.el55
-rw-r--r--lisp/international/mule-cmds.el2
-rw-r--r--lisp/loadup.el7
-rw-r--r--lisp/menu-bar.el1
-rw-r--r--lisp/mwheel.el8
-rw-r--r--lisp/net/browse-url.el13
-rw-r--r--lisp/net/eww.el8
-rw-r--r--lisp/select.el14
-rw-r--r--lisp/server.el17
-rw-r--r--lisp/simple.el2
-rw-r--r--lisp/startup.el2
-rw-r--r--lisp/term/pgtk-win.el501
-rw-r--r--lisp/url/url-privacy.el1
15 files changed, 605 insertions, 47 deletions
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 34a6db508d5..f91a7e228ed 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -2176,7 +2176,7 @@ and `face'."
;;; The `custom' Widget.
(defface custom-button
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns pgtk) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "lightgrey" :foreground "black"))
"Face for custom buffer buttons if `custom-raised-buttons' is non-nil."
@@ -2184,7 +2184,7 @@ and `face'."
:group 'custom-faces)
(defface custom-button-mouse
- '((((type x w32 ns) (class color))
+ '((((type x w32 ns pgtk) (class color))
:box (:line-width 2 :style released-button)
:background "grey90" :foreground "black")
(t
@@ -2209,7 +2209,7 @@ and `face'."
(if custom-raised-buttons 'custom-button-mouse 'highlight))
(defface custom-button-pressed
- '((((type x w32 ns) (class color))
+ '((((type x w32 ns pgtk) (class color))
:box (:line-width 2 :style pressed-button)
:background "lightgrey" :foreground "black")
(t :inverse-video t))
@@ -3458,6 +3458,10 @@ MS Windows.")
:sibling-args (:help-echo "\
GNUstep or Macintosh OS Cocoa interface.")
ns)
+ (const :format "PGTK "
+ :sibling-args (:help-echo "\
+Pure-GTK interface.")
+ ns)
(const :format "DOS "
:sibling-args (:help-echo "\
Plain MS-DOS.")
diff --git a/lisp/faces.el b/lisp/faces.el
index 9ec20c42987..5804f56378f 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1172,13 +1172,14 @@ an integer value."
(:height
'integerp)
(:stipple
- (and (memq (window-system frame) '(x ns)) ; No stipple on w32
- (mapcar #'list
+ (and (memq (window-system frame) '(x ns pgtk)) ; No stipple on w32
+ (mapcar (lambda (f)
+ (cons (file-name-base f) f))
(apply #'nconc
(mapcar (lambda (dir)
(and (file-readable-p dir)
(file-directory-p dir)
- (directory-files dir)))
+ (directory-files dir 'full)))
x-bitmap-file-path)))))
(:inherit
(cons '("none" . nil)
@@ -1516,7 +1517,7 @@ If FRAME is nil, the current FRAME is used."
match (cond ((eq req 'type)
(or (memq (window-system frame) options)
(and (memq 'graphic options)
- (memq (window-system frame) '(x w32 ns)))
+ (memq (window-system frame) '(x w32 ns pgtk)))
;; FIXME: This should be revisited to use
;; display-graphic-p, provided that the
;; color selection depends on the number
@@ -2822,7 +2823,7 @@ Note: Other faces cannot inherit from the cursor face."
'((default
:box (:line-width 1 :style released-button)
:foreground "black")
- (((type x w32 ns) (class color))
+ (((type x w32 ns pgtk) (class color))
:background "grey75")
(((type x) (class mono))
:background "grey"))
diff --git a/lisp/frame.el b/lisp/frame.el
index 2c73737a541..5e54d8d9af7 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -1633,6 +1633,7 @@ live frame and defaults to the selected one."
(declare-function x-frame-geometry "xfns.c" (&optional frame))
(declare-function w32-frame-geometry "w32fns.c" (&optional frame))
(declare-function ns-frame-geometry "nsfns.m" (&optional frame))
+(declare-function pgtk-frame-geometry "pgtkfns.c" (&optional frame))
(defun frame-geometry (&optional frame)
"Return geometric attributes of FRAME.
@@ -1682,6 +1683,8 @@ and width values are in pixels.
(w32-frame-geometry frame))
((eq frame-type 'ns)
(ns-frame-geometry frame))
+ ((eq frame-type 'pgtk)
+ (pgtk-frame-geometry frame))
(t
(list
'(outer-position 0 . 0)
@@ -1806,6 +1809,7 @@ of frames like calls to map a frame or change its visibility."
(declare-function x-frame-edges "xfns.c" (&optional frame type))
(declare-function w32-frame-edges "w32fns.c" (&optional frame type))
(declare-function ns-frame-edges "nsfns.m" (&optional frame type))
+(declare-function pgtk-frame-edges "pgtkfns.c" (&optional frame type))
(defun frame-edges (&optional frame type)
"Return coordinates of FRAME's edges.
@@ -1829,12 +1833,15 @@ FRAME."
(w32-frame-edges frame type))
((eq frame-type 'ns)
(ns-frame-edges frame type))
+ ((eq frame-type 'pgtk)
+ (pgtk-frame-edges frame type))
(t
(list 0 0 (frame-width frame) (frame-height frame))))))
(declare-function w32-mouse-absolute-pixel-position "w32fns.c")
(declare-function x-mouse-absolute-pixel-position "xfns.c")
(declare-function ns-mouse-absolute-pixel-position "nsfns.m")
+(declare-function pgtk-mouse-absolute-pixel-position "pgtkfns.c")
(defun mouse-absolute-pixel-position ()
"Return absolute position of mouse cursor in pixels.
@@ -1849,9 +1856,12 @@ position (0, 0) of the selected frame's terminal."
(w32-mouse-absolute-pixel-position))
((eq frame-type 'ns)
(ns-mouse-absolute-pixel-position))
+ ((eq frame-type 'pgtk)
+ (pgtk-mouse-absolute-pixel-position))
(t
(cons 0 0)))))
+(declare-function pgtk-set-mouse-absolute-pixel-position "pgtkfns.c" (x y))
(declare-function ns-set-mouse-absolute-pixel-position "nsfns.m" (x y))
(declare-function w32-set-mouse-absolute-pixel-position "w32fns.c" (x y))
(declare-function x-set-mouse-absolute-pixel-position "xfns.c" (x y))
@@ -1862,6 +1872,8 @@ The coordinates X and Y are interpreted in pixels relative to a
position (0, 0) of the selected frame's terminal."
(let ((frame-type (framep-on-display)))
(cond
+ ((eq frame-type 'pgtk)
+ (pgtk-set-mouse-absolute-pixel-position x y))
((eq frame-type 'ns)
(ns-set-mouse-absolute-pixel-position x y))
((eq frame-type 'x)
@@ -1960,6 +1972,7 @@ workarea attribute."
(declare-function x-frame-list-z-order "xfns.c" (&optional display))
(declare-function w32-frame-list-z-order "w32fns.c" (&optional display))
(declare-function ns-frame-list-z-order "nsfns.m" (&optional display))
+(declare-function pgtk-frame-list-z-order "pgtkfns.c" (&optional display))
(defun frame-list-z-order (&optional display)
"Return list of Emacs' frames, in Z (stacking) order.
@@ -1979,11 +1992,14 @@ Return nil if DISPLAY contains no Emacs frame."
((eq frame-type 'w32)
(w32-frame-list-z-order display))
((eq frame-type 'ns)
- (ns-frame-list-z-order display)))))
+ (ns-frame-list-z-order display))
+ ((eq frame-type 'pgtk)
+ (pgtk-frame-list-z-order display)))))
(declare-function x-frame-restack "xfns.c" (frame1 frame2 &optional above))
(declare-function w32-frame-restack "w32fns.c" (frame1 frame2 &optional above))
(declare-function ns-frame-restack "nsfns.m" (frame1 frame2 &optional above))
+(declare-function pgtk-frame-restack "pgtkfns.c" (frame1 frame2 &optional above))
(defun frame-restack (frame1 frame2 &optional above)
"Restack FRAME1 below FRAME2.
@@ -2013,7 +2029,9 @@ Some window managers may refuse to restack windows."
((eq frame-type 'w32)
(w32-frame-restack frame1 frame2 above))
((eq frame-type 'ns)
- (ns-frame-restack frame1 frame2 above))))
+ (ns-frame-restack frame1 frame2 above))
+ ((eq frame-type 'pgtk)
+ (pgtk-frame-restack frame1 frame2 above))))
(error "Cannot restack frames")))
(defun frame-size-changed-p (&optional frame)
@@ -2060,7 +2078,7 @@ frame's display)."
((eq frame-type 'w32)
(with-no-warnings
(> w32-num-mouse-buttons 0)))
- ((memq frame-type '(x ns))
+ ((memq frame-type '(x ns pgtk))
t) ;; We assume X and NeXTstep *always* have a pointing device
(t
(or (and (featurep 'xt-mouse)
@@ -2086,7 +2104,7 @@ frames and several different fonts at once. This is true for displays
that use a window system such as X, and false for text-only terminals.
DISPLAY can be a display name, a frame, or nil (meaning the selected
frame's display)."
- (not (null (memq (framep-on-display display) '(x w32 ns)))))
+ (not (null (memq (framep-on-display display) '(x w32 ns pgtk)))))
(defun display-images-p (&optional display)
"Return non-nil if DISPLAY can display images.
@@ -2114,7 +2132,7 @@ frame's display)."
;; a Windows DOS Box.
(with-no-warnings
(not (null dos-windows-version))))
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
t)
(t
nil))))
@@ -2124,7 +2142,7 @@ frame's display)."
This means that, for example, DISPLAY can differentiate between
the keybinding RET and [return]."
(let ((frame-type (framep-on-display display)))
- (or (memq frame-type '(x w32 ns pc))
+ (or (memq frame-type '(x w32 ns pc pgtk))
;; MS-DOS and MS-Windows terminals have built-in support for
;; function (symbol) keys
(memq system-type '(ms-dos windows-nt)))))
@@ -2137,7 +2155,7 @@ DISPLAY should be either a frame or a display name (a string).
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
(x-display-screens display))
(t
1))))
@@ -2157,7 +2175,7 @@ with DISPLAY. To get information for each physical monitor, use
`display-monitor-attributes-list'."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
(x-display-pixel-height display))
(t
(frame-height (if (framep display) display (selected-frame)))))))
@@ -2177,7 +2195,7 @@ with DISPLAY. To get information for each physical monitor, use
`display-monitor-attributes-list'."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
(x-display-pixel-width display))
(t
(frame-width (if (framep display) display (selected-frame)))))))
@@ -2215,7 +2233,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this
refers to the height in millimeters for all physical monitors
associated with DISPLAY. To get information for each physical
monitor, use `display-monitor-attributes-list'."
- (and (memq (framep-on-display display) '(x w32 ns))
+ (and (memq (framep-on-display display) '(x w32 ns pgtk))
(or (cddr (assoc (or display (frame-parameter nil 'display))
display-mm-dimensions-alist))
(cddr (assoc t display-mm-dimensions-alist))
@@ -2236,7 +2254,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this
refers to the width in millimeters for all physical monitors
associated with DISPLAY. To get information for each physical
monitor, use `display-monitor-attributes-list'."
- (and (memq (framep-on-display display) '(x w32 ns))
+ (and (memq (framep-on-display display) '(x w32 ns pgtk))
(or (cadr (assoc (or display (frame-parameter nil 'display))
display-mm-dimensions-alist))
(cadr (assoc t display-mm-dimensions-alist))
@@ -2254,7 +2272,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
(x-display-backing-store display))
(t
'not-useful))))
@@ -2267,7 +2285,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
(x-display-save-under display))
(t
'not-useful))))
@@ -2280,7 +2298,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
(x-display-planes display))
((eq frame-type 'pc)
4)
@@ -2295,7 +2313,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
(x-display-color-cells display))
((eq frame-type 'pc)
16)
@@ -2312,7 +2330,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns))
+ ((memq frame-type '(x w32 ns pgtk))
(x-display-visual-class display))
((and (memq frame-type '(pc t))
(tty-display-color-p display))
@@ -2326,6 +2344,8 @@ If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(&optional display))
(declare-function ns-display-monitor-attributes-list "nsfns.m"
(&optional terminal))
+(declare-function pgtk-display-monitor-attributes-list "pgtkfns.c"
+ (&optional terminal))
(defun display-monitor-attributes-list (&optional display)
"Return a list of physical monitor attributes on DISPLAY.
@@ -2343,6 +2363,7 @@ of attribute keys and values as follows:
mm-size -- Width and height in millimeters in the form of
(WIDTH HEIGHT)
frames -- List of frames dominated by the physical monitor
+ scale-factor (*) -- Scale factor (float)
name (*) -- Name of the physical monitor as a string
source (*) -- Source of multi-monitor information as a string
@@ -2374,6 +2395,8 @@ monitors."
(w32-display-monitor-attributes-list display))
((eq frame-type 'ns)
(ns-display-monitor-attributes-list display))
+ ((eq frame-type 'pgtk)
+ (pgtk-display-monitor-attributes-list display))
(t
(let ((geometry (list 0 0 (display-pixel-width display)
(display-pixel-height display))))
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index 089decb83c8..2b94a2845f7 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -88,7 +88,7 @@
(bindings--define-key map [separator-3] menu-bar-separator)
(bindings--define-key map [set-terminal-coding-system]
'(menu-item "For Terminal" set-terminal-coding-system
- :enable (null (memq initial-window-system '(x w32 ns)))
+ :enable (null (memq initial-window-system '(x w32 ns pgtk)))
:help "How to encode terminal output"))
(bindings--define-key map [set-keyboard-coding-system]
'(menu-item "For Keyboard" set-keyboard-coding-system
diff --git a/lisp/loadup.el b/lisp/loadup.el
index e8ecb67d564..c6bd930cdf7 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -334,6 +334,13 @@
(load "international/mule-util")
(load "international/ucs-normalize")
(load "term/ns-win"))))
+(if (featurep 'pgtk)
+ (progn
+ (load "term/common-win")
+ ;; Don't load ucs-normalize.el unless uni-*.el files were
+ ;; already produced, because it needs uni-*.el files that might
+ ;; not be built early enough during bootstrap.
+ (load "term/pgtk-win")))
(if (fboundp 'x-create-frame)
;; Do it after loading term/foo-win.el since the value of the
;; mouse-wheel-*-event vars depends on those files being loaded or not.
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index 1a81f1a3d06..b9ca57f5c49 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -2540,6 +2540,7 @@ See `menu-bar-mode' for more information."
(declare-function x-menu-bar-open "term/x-win" (&optional frame))
(declare-function w32-menu-bar-open "term/w32-win" (&optional frame))
+(declare-function pgtk-menu-bar-open "term/pgtk-win" (&optional frame))
(defun lookup-key-ignore-too-long (map key)
"Call `lookup-key' and convert numeric values to nil."
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 51410e3ef4c..cb1997801b6 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -55,7 +55,7 @@
(mouse-wheel-mode 1)))
(defcustom mouse-wheel-down-event
- (if (or (featurep 'w32-win) (featurep 'ns-win))
+ (if (or (featurep 'w32-win) (featurep 'ns-win) (featurep 'pgtk))
'wheel-up
'mouse-4)
"Event used for scrolling down."
@@ -64,7 +64,7 @@
:set 'mouse-wheel-change-button)
(defcustom mouse-wheel-up-event
- (if (or (featurep 'w32-win) (featurep 'ns-win))
+ (if (or (featurep 'w32-win) (featurep 'ns-win) (featurep 'pgtk))
'wheel-down
'mouse-5)
"Event used for scrolling up."
@@ -221,13 +221,13 @@ Also see `mouse-wheel-tilt-scroll'."
"Function that does the job of scrolling right.")
(defvar mouse-wheel-left-event
- (if (or (featurep 'w32-win) (featurep 'ns-win))
+ (if (or (featurep 'w32-win) (featurep 'ns-win) (featurep 'pgtk))
'wheel-left
'mouse-6)
"Event used for scrolling left.")
(defvar mouse-wheel-right-event
- (if (or (featurep 'w32-win) (featurep 'ns-win))
+ (if (or (featurep 'w32-win) (featurep 'ns-win) (featurep 'pgtk))
'wheel-right
'mouse-7)
"Event used for scrolling right.")
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index 3af37e412d9..1fafed32e6c 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -892,8 +892,17 @@ If ARGS are omitted, the default is to pass
;; When connected to various displays, be careful to use the display of
;; the currently selected frame, rather than the original start display,
;; which may not even exist any more.
- (if (stringp (frame-parameter nil 'display))
- (setenv "DISPLAY" (frame-parameter nil 'display)))
+ (let ((dpy (frame-parameter nil 'display))
+ classname)
+ (if (stringp dpy)
+ (cond
+ ((featurep 'pgtk)
+ (setq classname (pgtk-backend-display-class))
+ (if (equal classname "GdkWaylandDisplay")
+ (setenv "WAYLAND_DISPLAY" dpy)
+ (setenv "DISPLAY" dpy)))
+ (t
+ (setenv "DISPLAY" dpy)))))
(if (functionp function)
(apply function url args)
(error "No suitable browser for URL %s" url))))
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 70ebc1d2ec6..46e211171e6 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -239,7 +239,7 @@ parameter, and should return the (possibly) transformed URL."
:version "29.1")
(defface eww-form-submit
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns pgtk) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "#808080" :foreground "black"))
"Face for eww buffer buttons."
@@ -247,7 +247,7 @@ parameter, and should return the (possibly) transformed URL."
:group 'eww)
(defface eww-form-file
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns pgtk) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "#808080" :foreground "black"))
"Face for eww buffer buttons."
@@ -255,7 +255,7 @@ parameter, and should return the (possibly) transformed URL."
:group 'eww)
(defface eww-form-checkbox
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns pgtk) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "lightgrey" :foreground "black"))
"Face for eww buffer buttons."
@@ -263,7 +263,7 @@ parameter, and should return the (possibly) transformed URL."
:group 'eww)
(defface eww-form-select
- '((((type x w32 ns) (class color)) ; Like default mode line
+ '((((type x w32 ns pgtk) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "lightgrey" :foreground "black"))
"Face for eww buffer buttons."
diff --git a/lisp/select.el b/lisp/select.el
index 3c9f961f6db..a77a005cd3d 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -140,24 +140,27 @@ MS-Windows does not have a \"primary\" selection."
(defcustom x-select-request-type nil
"Data type request for X selection.
The value is one of the following data types, a list of them, or nil:
- `COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT'
+ `COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT', `text/plain\\;charset=utf-8'
If the value is one of the above symbols, try only the specified type.
If the value is a list of them, try each of them in the specified
order until succeed.
-The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)."
+The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING
+text/plain\\;charset=utf-8)."
:type '(choice (const :tag "Default" nil)
(const COMPOUND_TEXT)
(const UTF8_STRING)
(const STRING)
(const TEXT)
+ (const text/plain\;charset=utf-8)
(set :tag "List of values"
(const COMPOUND_TEXT)
(const UTF8_STRING)
(const STRING)
- (const TEXT)))
+ (const TEXT)
+ (const text/plain\;charset=utf-8)))
:group 'killing)
(defun gui--selection-value-internal (type)
@@ -165,9 +168,9 @@ The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)."
Call `gui-get-selection' with an appropriate DATA-TYPE argument
decided by `x-select-request-type'. The return value is already
decoded. If `gui-get-selection' signals an error, return nil."
- (let ((request-type (if (eq window-system 'x)
+ (let ((request-type (if (memq window-system '(x pgtk))
(or x-select-request-type
- '(UTF8_STRING COMPOUND_TEXT STRING))
+ '(UTF8_STRING COMPOUND_TEXT STRING text/plain\;charset=utf-8))
'STRING))
text)
(with-demoted-errors "gui-get-selection: %S"
@@ -309,6 +312,7 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'."
selection-coding-system
(pcase data-type
('UTF8_STRING 'utf-8)
+ ('text/plain\;charset=utf-8 'utf-8)
('COMPOUND_TEXT 'compound-text-with-extensions)
('C_STRING nil)
('STRING 'iso-8859-1)
diff --git a/lisp/server.el b/lisp/server.el
index d9986562377..947311a2322 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -900,12 +900,17 @@ This handles splitting the command if it would be bigger than
)
(cond (w
- (server--create-frame
- nowait proc
- `((display . ,display)
- ,@(if parent-id
- `((parent-id . ,(string-to-number parent-id))))
- ,@parameters)))
+ (condition-case nil
+ (server--create-frame
+ nowait proc
+ `((display . ,display)
+ ,@(if parent-id
+ `((parent-id . ,(string-to-number parent-id))))
+ ,@parameters))
+ (error
+ (server-log "Window system unsupported" proc)
+ (server-send-string proc "-window-system-unsupported \n")
+ nil)))
(t
(server-log "Window system unsupported" proc)
diff --git a/lisp/simple.el b/lisp/simple.el
index ad6d28cb14d..a192c4601bc 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -9616,7 +9616,7 @@ call `normal-erase-is-backspace-mode' (which see) instead."
(if (if (eq normal-erase-is-backspace 'maybe)
(and (not noninteractive)
(or (memq system-type '(ms-dos windows-nt))
- (memq window-system '(w32 ns))
+ (memq window-system '(w32 ns pgtk))
(and (eq window-system 'x)
(fboundp 'x-backspace-delete-keys-p)
(x-backspace-delete-keys-p))
diff --git a/lisp/startup.el b/lisp/startup.el
index 505d7b83f48..80253211617 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1980,6 +1980,8 @@ we put it on this frame."
;; frame visible.
(if (eq (window-system) 'w32)
(sit-for 0 t))
+ (if (eq (window-system) 'pgtk)
+ (sit-for 0.1 t))
(dolist (frame (append (frame-list) (list (selected-frame))))
(if (and (frame-visible-p frame)
(not (window-minibuffer-p (frame-selected-window frame))))
diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el
new file mode 100644
index 00000000000..3df450070c2
--- /dev/null
+++ b/lisp/term/pgtk-win.el
@@ -0,0 +1,501 @@
+;;; xterm.el --- define function key sequences and standard colors for xterm -*- lexical-binding: t -*-
+
+;; Copyright (C) 1995, 2001-2020 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))
+(or (featurep 'pgtk)
+ (error "%s: Loading pgtk-win.el but not compiled for pure Gtk+-3."
+ 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)
+
+(defgroup pgtk nil
+ "Pure-GTK specific features."
+ :group 'environment)
+
+;;;; Command line argument handling.
+
+(defvar x-invocation-args)
+;; Set in term/common-win.el; currently unused by Gtk's x-open-connection.
+(defvar x-command-line-resources)
+
+;; pgtkterm.c.
+(defvar pgtk-input-file)
+
+(defun pgtk-handle-nxopen (_switch &optional temp)
+ (setq unread-command-events (append unread-command-events
+ (if temp '(pgtk-open-temp-file)
+ '(pgtk-open-file)))
+ pgtk-input-file (append pgtk-input-file (list (pop x-invocation-args)))))
+
+(defun pgtk-handle-nxopentemp (switch)
+ (pgtk-handle-nxopen switch t))
+
+(defun pgtk-ignore-1-arg (_switch)
+ (setq x-invocation-args (cdr x-invocation-args)))
+
+;;;; File handling.
+
+(declare-function pgtk-hide-emacs "pgtkfns.c" (on))
+
+
+(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)
+(global-set-key [C-drag-n-drop] 'pgtk-drag-n-drop-other-frame)
+(global-set-key [M-drag-n-drop] 'pgtk-drag-n-drop-as-text)
+(global-set-key [C-M-drag-n-drop] 'pgtk-drag-n-drop-as-text-other-frame)
+
+;;;; Frame-related functions.
+
+;; pgtkterm.c
+(defvar pgtk-alternate-modifier)
+(defvar pgtk-right-alternate-modifier)
+(defvar pgtk-right-command-modifier)
+(defvar pgtk-right-control-modifier)
+
+;; You say tomAYto, I say tomAHto..
+(with-no-warnings
+ (defvaralias 'pgtk-option-modifier 'pgtk-alternate-modifier)
+ (defvaralias 'pgtk-right-option-modifier 'pgtk-right-alternate-modifier))
+
+(defun pgtk-do-hide-emacs ()
+ (interactive)
+ (pgtk-hide-emacs t))
+
+(declare-function pgtk-hide-others "pgtkfns.c" ())
+
+(defun pgtk-do-hide-others ()
+ (interactive)
+ (pgtk-hide-others))
+
+(declare-function pgtk-emacs-info-panel "pgtkfns.c" ())
+
+(defun pgtk-do-emacs-info-panel ()
+ (interactive)
+ (pgtk-emacs-info-panel))
+
+(defun pgtk-next-frame ()
+ "Switch to next visible frame."
+ (interactive)
+ (other-frame 1))
+
+(defun pgtk-prev-frame ()
+ "Switch to previous visible frame."
+ (interactive)
+ (other-frame -1))
+
+;; Frame will be focused anyway, so select it
+;; (if this is not done, mode line is dimmed until first interaction)
+;; FIXME: Sounds like we're working around a bug in the underlying code.
+(add-hook 'after-make-frame-functions 'select-frame)
+
+(defvar tool-bar-mode)
+(declare-function tool-bar-mode "tool-bar" (&optional arg))
+
+;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
+;; see https://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html .
+(defun pgtk-toggle-toolbar (&optional frame)
+ "Switches the tool bar on and off in frame FRAME.
+ If FRAME is nil, the change applies to the selected frame."
+ (interactive)
+ (modify-frame-parameters
+ frame (list (cons 'tool-bar-lines
+ (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
+ 0 1)) ))
+ (if (not tool-bar-mode) (tool-bar-mode t)))
+
+
+;;;; Dialog-related functions.
+
+;; Ask user for confirm before printing. Due to Kevin Rodgers.
+(defun pgtk-print-buffer ()
+ "Interactive front-end to `print-buffer': asks for user confirmation first."
+ (interactive)
+ (if (and (called-interactively-p 'interactive)
+ (or (listp last-nonmenu-event)
+ (and (char-or-string-p (event-basic-type last-command-event))
+ (memq 'super (event-modifiers last-command-event)))))
+ (let ((last-nonmenu-event (if (listp last-nonmenu-event)
+ last-nonmenu-event
+ ;; Fake it:
+ `(mouse-1 POSITION 1))))
+ (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
+ (print-buffer)
+ (error "Canceled")))
+ (print-buffer)))
+
+;;;; Font support.
+
+;; Needed for font listing functions under both backend and normal
+(setq scalable-fonts-allowed t)
+
+;; Default fontset. 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
+(defvar pgtk-standard-fontset-spec
+ ;; Only some code supports this so far, so use uglier XLFD version
+ ;; "-pgtk-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
+ (mapconcat 'identity
+ '("-*-Monospace-*-*-*-*-10-*-*-*-*-*-fontset-standard"
+ "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1")
+ ",")
+ "String of fontset spec of the standard fontset.
+This defines a fontset consisting of the Courier and other fonts.
+See the documentation of `create-fontset-from-fontset-spec' for the format.")
+
+
+;;;; Pasteboard support.
+
+(define-obsolete-function-alias 'pgtk-store-cut-buffer-internal
+ 'gui-set-selection "24.1")
+
+
+(defun pgtk-copy-including-secondary ()
+ (interactive)
+ (call-interactively 'kill-ring-save)
+ (gui-set-selection 'SECONDARY (buffer-substring (point) (mark t))))
+
+(defun pgtk-paste-secondary ()
+ (interactive)
+ (insert (gui-get-selection 'SECONDARY)))
+
+
+(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" (owner name value))
+
+;; Do the actual pure-GTK Windows 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 Emacs for pure-GTK windowing."
+ (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.
+ (or (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 pgtk-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 time_object 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 time_stamp 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 an event of PGTK_PREEDIT_TEXT_EVENT.
+It contains colors and texts."
+ (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)))
+
+
+(add-hook 'after-init-hook
+ (function
+ (lambda ()
+ (when (eq window-system 'pgtk)
+ (pgtk-use-im-context pgtk-use-im-context-on-new-connection)))))
+
+
+;;;
+
+(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))))
+
+
+(provide 'pgtk-win)
+(provide 'term/pgtk-win)
+
+;;; pgtk-win.el ends here
diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el
index 58ae6efbfc1..ebba87ebbb5 100644
--- a/lisp/url/url-privacy.el
+++ b/lisp/url/url-privacy.el
@@ -48,6 +48,7 @@
(pcase (or window-system 'tty)
('x "X11")
('ns "OpenStep")
+ ('pgtk "PureGTK")
('tty "TTY")
(_ nil)))))
View Lorry Controller Status