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.el4
-rw-r--r--lisp/frame.el54
-rw-r--r--lisp/international/mule-cmds.el2
-rw-r--r--lisp/loadup.el7
-rw-r--r--lisp/mwheel.el8
-rw-r--r--lisp/net/eww.el8
-rw-r--r--lisp/startup.el4
-rw-r--r--lisp/term/pgtk-win.el429
-rw-r--r--lisp/url/url-privacy.el1
10 files changed, 496 insertions, 31 deletions
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index eceba8fa4d6..099b7daac5b 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -2172,7 +2172,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."
@@ -2180,7 +2180,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
@@ -2205,7 +2205,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))
@@ -3445,6 +3445,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 7355e1dd0a5..5e525e79531 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1487,7 +1487,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
@@ -2755,7 +2755,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 772ba3d8c47..a43e12f12ad 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -1601,6 +1601,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.
@@ -1650,6 +1651,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)
@@ -1696,6 +1699,7 @@ selected frame."
(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.
@@ -1719,12 +1723,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.
@@ -1739,9 +1746,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))
@@ -1752,6 +1762,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)
@@ -1850,6 +1862,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.
@@ -1869,11 +1882,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.
@@ -1903,7 +1919,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)
@@ -1950,7 +1968,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)
@@ -1976,7 +1994,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.
@@ -2004,7 +2022,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))))
@@ -2014,7 +2032,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)))))
@@ -2027,7 +2045,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))))
@@ -2047,7 +2065,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)))))))
@@ -2067,7 +2085,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)))))))
@@ -2105,7 +2123,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))
@@ -2126,7 +2144,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))
@@ -2144,7 +2162,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))))
@@ -2157,7 +2175,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))))
@@ -2170,7 +2188,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)
@@ -2185,7 +2203,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)
@@ -2202,7 +2220,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))
@@ -2216,6 +2234,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.
@@ -2264,6 +2284,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 d361971a1fc..e22876ba37c 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 4b711eed065..50ed5575156 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -336,6 +336,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/mwheel.el b/lisp/mwheel.el
index 1d9fe68075b..9dcdbe2de84 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -52,7 +52,7 @@
(when (bound-and-true-p mouse-wheel-mode) (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."
@@ -61,7 +61,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."
@@ -215,13 +215,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/eww.el b/lisp/net/eww.el
index 9ed01ecc473..743abb0c8ee 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -189,7 +189,7 @@ See also `eww-form-checkbox-selected-symbol'."
string))
(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."
@@ -197,7 +197,7 @@ See also `eww-form-checkbox-selected-symbol'."
: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."
@@ -205,7 +205,7 @@ See also `eww-form-checkbox-selected-symbol'."
: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."
@@ -213,7 +213,7 @@ See also `eww-form-checkbox-selected-symbol'."
: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/startup.el b/lisp/startup.el
index 9f67dfde124..e3c792edff0 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1312,7 +1312,7 @@ please check its value")
;; only because all other settings of no-blinking-cursor are here.
(unless (or noninteractive
emacs-basic-display
- (and (memq window-system '(x w32 ns))
+ (and (memq window-system '(x w32 ns pgtk))
(not (member (x-get-resource "cursorBlink" "CursorBlink")
'("no" "off" "false" "0")))))
(setq no-blinking-cursor t))
@@ -1962,6 +1962,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..203cce442d1
--- /dev/null
+++ b/lisp/term/pgtk-win.el
@@ -0,0 +1,429 @@
+;;;
+
+;;; 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.
+
+(defun x-file-dialog (prompt dir default_filename mustmatch only_dir_p)
+"Read file name, prompting with PROMPT in directory DIR.
+Use a file selection dialog. Select DEFAULT-FILENAME in the dialog's file
+selection box, if specified. If MUSTMATCH is non-nil, the returned file
+or directory must exist.
+
+This function is only defined on PGTK, MS Windows, and X Windows with the
+Motif or Gtk toolkits. With the Motif toolkit, ONLY-DIR-P is ignored.
+Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories."
+ (pgtk-read-file-name prompt dir mustmatch default_filename only_dir_p))
+
+(defun pgtk-open-file-using-panel ()
+ "Pop up open-file panel, and load the result in a buffer."
+ (interactive)
+ ;; Prompt dir defaultName isLoad initial.
+ (setq pgtk-input-file (pgtk-read-file-name "Select File to Load" nil t nil))
+ (if pgtk-input-file
+ (and (setq pgtk-input-file (list pgtk-input-file)) (pgtk-find-file))))
+
+(defun pgtk-write-file-using-panel ()
+ "Pop up save-file panel, and save buffer in resulting name."
+ (interactive)
+ (let (pgtk-output-file)
+ ;; Prompt dir defaultName isLoad initial.
+ (setq pgtk-output-file (pgtk-read-file-name "Save As" nil nil nil))
+ (message pgtk-output-file)
+ (if pgtk-output-file (write-file pgtk-output-file))))
+
+(defcustom pgtk-pop-up-frames 'fresh
+ "Non-nil means open files upon request from the Workspace in a new frame.
+If t, always do so. Any other non-nil value means open a new frame
+unless the current buffer is a scratch buffer."
+ :type '(choice (const :tag "Never" nil)
+ (const :tag "Always" t)
+ (other :tag "Except for scratch buffer" fresh))
+ :version "23.1"
+ :group 'pgtk)
+
+(declare-function pgtk-hide-emacs "pgtkfns.c" (on))
+
+(defun pgtk-find-file ()
+ "Do a `find-file' with the `pgtk-input-file' as argument."
+ (interactive)
+ (let* ((f (file-truename
+ (expand-file-name (pop pgtk-input-file)
+ command-line-default-directory)))
+ (file (find-file-noselect f))
+ (bufwin1 (get-buffer-window file 'visible))
+ (bufwin2 (get-buffer-window "*scratch*" 'visible)))
+ (cond
+ (bufwin1
+ (select-frame (window-frame bufwin1))
+ (raise-frame (window-frame bufwin1))
+ (select-window bufwin1))
+ ((and (eq pgtk-pop-up-frames 'fresh) bufwin2)
+ (pgtk-hide-emacs 'activate)
+ (select-frame (window-frame bufwin2))
+ (raise-frame (window-frame bufwin2))
+ (select-window bufwin2)
+ (find-file f))
+ (pgtk-pop-up-frames
+ (pgtk-hide-emacs 'activate)
+ (let ((pop-up-frames t)) (pop-to-buffer file nil)))
+ (t
+ (pgtk-hide-emacs 'activate)
+ (find-file f)))))
+
+
+(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..
+(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)
+
+;; Set to use font panel instead
+(declare-function pgtk-popup-font-panel "pgtkfns.c" (&optional frame))
+(defalias 'x-select-font 'pgtk-popup-font-panel "Pop up the font panel.
+This function has been overloaded in Nextstep.")
+(defalias 'mouse-set-font 'pgtk-popup-font-panel "Pop up the font panel.
+This function has been overloaded in Nextstep.")
+
+;; pgtkterm.c
+(defvar pgtk-input-font)
+(defvar pgtk-input-fontsize)
+
+(defun pgtk-respond-to-change-font ()
+ "Respond to changeFont: event, expecting `pgtk-input-font' and\n\
+`pgtk-input-fontsize' of new font."
+ (interactive)
+ (modify-frame-parameters (selected-frame)
+ (list (cons 'fontsize pgtk-input-fontsize)))
+ (modify-frame-parameters (selected-frame)
+ (list (cons 'font pgtk-input-font)))
+ (set-frame-font pgtk-input-font))
+
+
+;; 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"
+ "han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1"
+ "cyrillic:-*-Trebuchet$MS-*-*-*-*-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)))
+
+
+;;;; Color support.
+
+;; Functions for color panel + drag
+(defun pgtk-face-at-pos (pos)
+ (let* ((frame (car pos))
+ (frame-pos (cons (cadr pos) (cddr pos)))
+ (window (window-at (car frame-pos) (cdr frame-pos) frame))
+ (window-pos (coordinates-in-window-p frame-pos window))
+ (buffer (window-buffer window))
+ (edges (window-edges window)))
+ (cond
+ ((not window-pos)
+ nil)
+ ((eq window-pos 'mode-line)
+ 'mode-line)
+ ((eq window-pos 'vertical-line)
+ 'default)
+ ((consp window-pos)
+ (with-current-buffer buffer
+ (let ((p (car (compute-motion (window-start window)
+ (cons (nth 0 edges) (nth 1 edges))
+ (window-end window)
+ frame-pos
+ (- (window-width window) 1)
+ nil
+ window))))
+ (cond
+ ((eq p (window-point window))
+ 'cursor)
+ ((and mark-active (< (region-beginning) p) (< p (region-end)))
+ 'region)
+ (t
+ (let ((faces (get-char-property p 'face window)))
+ (if (consp faces) (car faces) faces)))))))
+ (t
+ nil))))
+
+(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")))
+
+
+;; Set some options to be as Nextstep-like as possible.
+(setq frame-title-format t
+ icon-title-format t)
+
+
+(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 (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))
+
+(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 716e3107424..f1cbb2620e1 100644
--- a/lisp/url/url-privacy.el
+++ b/lisp/url/url-privacy.el
@@ -46,6 +46,7 @@
(pcase (or window-system 'tty)
('x "X11")
('ns "OpenStep")
+ ('pgtk "PureGTK")
('tty "TTY")
(_ nil)))))
generated by cgit v1.2.3 (git 2.39.1) at 2025-07-21 23:08:15 +0000