summaryrefslogtreecommitdiff
path: root/lisp/term/pgtk-win.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/term/pgtk-win.el')
-rw-r--r--lisp/term/pgtk-win.el429
1 files changed, 429 insertions, 0 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-08 02:53:49 +0000