Allow dropping more data types on PGTK

* lisp/loadup.el (featurep): Load `pgtk-dnd'.
* lisp/pgtk-dnd.el: New file.
(pgtk-dnd-test-function, pgtk-dnd-types-alist)
(pgtk-dnd-known-types, pgtk-dnd-use-offix-drop)
(pgtk-dnd-current-state, pgtk-get-selection-internal)
(pgtk-register-dnd-targets, pgtk-dnd-empty-state)
(pgtk-dnd-init-frame, pgtk-dnd-get-state-cons-for-frame)
(pgtk-dnd-get-state-for-frame, pgtk-dnd-default-test-function)
(pgtk-dnd-current-type, pgtk-dnd-forget-drop)
(pgtk-dnd-maybe-call-test-function, pgtk-dnd-save-state)
(pgtk-dnd-handle-moz-url, pgtk-dnd-insert-utf8-text)
(pgtk-dnd-insert-utf16-text, pgtk-dnd-insert-ctext)
(pgtk-dnd-handle-uri-list, pgtk-dnd-handle-file-name)
(pgtk-dnd-choose-type, pgtk-dnd-drop-data)
(pgtk-dnd-handle-drag-n-drop-event, pgtk-update-drop-status)
(pgtk-drop-finish, pgtk-dnd-handle-gdk, pgtk-dnd): New variables
and functions and library.

* lisp/term/pgtk-win.el (special-event-map): Load
`drag-n-drop-event'.
(after-make-frame-functions): Register DND after make frame
functions.

* src/emacs.c (main): Stop calling empty init_pgtkterm function.

* src/pgtkselect.c (Fpgtk_register_dnd_targets, Fpgtk_drop_finish)
(Fpgtk_update_drop_status): New functions.
(syms_of_pgtkselect): Register new functions.
* src/pgtkterm.c (struct event_queue_t): Fix coding style of
definition.
(symbol_to_drag_action, drag_action_to_symbol)
(pgtk_update_drop_status, pgtk_finish_drop): New functions.
(drag_data_received): Delete function.
(pgtk_set_event_handler): Register for DND correctly.
(syms_of_pgtkterm): New defsyms for DND types.
(init_pgtkterm): Delete function.

* src/pgtkterm.h: Update prototypes, fix prototype coding style.

1 files changed, 400 insertions, 0 deletions

diff --git a/lisp/pgtk-dnd.el b/lisp/pgtk-dnd.el
new file mode 100644
index 00000000000..2aaf4c4e977
--- /dev/null
+++ b/lisp/pgtk-dnd.el
@@ -0,0 +1,400 @@
+;;; pgtk-dnd.el --- drag and drop support for GDK -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; Maintainer: emacs-devel@gnu.org
+;; Keywords: window, drag, drop
+;; Package: emacs
+
+;; Significant portions taken from x-dnd.el.
+
+;; 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:
+
+;; This file provides the receiving side of the GDK drag and drop
+;; mechanism.
+
+;;; Code:
+
+(require 'dnd)
+
+;;; Customizable variables
+(defcustom pgtk-dnd-test-function #'pgtk-dnd-default-test-function
+  "The function drag and drop uses to determine if to accept or reject a drop.
+The function takes three arguments, WINDOW, ACTION and TYPES.
+WINDOW is where the mouse is when the function is called.  WINDOW
+may be a frame if the mouse isn't over a real window (i.e. menu
+bar, tool bar or scroll bar).  ACTION is the suggested action
+from the drag and drop source, one of the symbols move, copy,
+link or ask.  TYPES is a vector of available types for the drop.
+
+Each element of TYPE should either be a string (containing the
+name of the type's X atom), or a symbol, whose name will be used.
+
+The function shall return nil to reject the drop or a cons with
+two values, the wanted action as car and the wanted type as cdr.
+The wanted action can be copy, move, link, ask or private.
+
+The default value for this variable is `pgtk-dnd-default-test-function'."
+  :version "22.1"
+  :type 'symbol
+  :group 'pgtk)
+
+(defcustom pgtk-dnd-types-alist
+  `((,(purecopy "text/uri-list") . pgtk-dnd-handle-uri-list)
+    (,(purecopy "FILE_NAME") . pgtk-dnd-handle-file-name)
+    (,(purecopy "UTF8_STRING") . pgtk-dnd-insert-utf8-text)
+    (,(purecopy "text/plain;charset=UTF-8") . pgtk-dnd-insert-utf8-text)
+    (,(purecopy "text/plain;charset=utf-8") . pgtk-dnd-insert-utf8-text)
+    (,(purecopy "text/plain") . dnd-insert-text)
+    (,(purecopy "COMPOUND_TEXT") . pgtk-dnd-insert-ctext)
+    (,(purecopy "STRING") . dnd-insert-text)
+    (,(purecopy "TEXT")   . dnd-insert-text))
+  "Which function to call to handle a drop of that type.
+If the type for the drop is not present, or the function is nil,
+the drop is rejected.  The function takes three arguments, WINDOW, ACTION
+and DATA.  WINDOW is where the drop occurred, ACTION is the action for
+this drop (copy, move, link, private or ask) as determined by a previous
+call to `pgtk-dnd-test-function'.  DATA is the drop data.
+The function shall return the action used (copy, move, link or private)
+if drop is successful, nil if not."
+  :version "22.1"
+  :type 'alist
+  :group 'pgtk)
+
+(defcustom pgtk-dnd-known-types
+  (mapcar 'purecopy '("text/uri-list"
+                      "FILE_NAME"
+                      "UTF8_STRING"
+                      "text/plain;charset=UTF-8"
+                      "text/plain;charset=utf-8"
+                      "text/plain"
+                      "COMPOUND_TEXT"
+                      "STRING"
+                      "TEXT"))
+  "The types accepted by default for dropped data.
+The types are chosen in the order they appear in the list."
+  :version "22.1"
+  :type '(repeat string)
+  :group 'pgtk)
+
+(defcustom pgtk-dnd-use-offix-drop 'files
+  "If non-nil, use the OffiX protocol to drop files and text.
+This allows dropping (via `dired-mouse-drag-files' or
+`mouse-drag-and-drop-region-cross-program') on some old Java
+applets and old KDE programs.  Turning this off allows dropping
+only text on some other programs such as xterm and urxvt.
+
+If the symbol `files', use the OffiX protocol when dropping
+files, and the fallback drop method (which is used with programs
+like xterm) for text."
+  :version "29.1"
+  :type '(choice (const :tag "Don't use the OffiX protocol for drag-and-drop" nil)
+                 (const :tag "Only use the OffiX protocol to drop files" files)
+                 (const :tag "Use the OffiX protocol for both files and text" t))
+  :group 'pgtk)
+
+;; Internal variables
+
+(defvar pgtk-dnd-current-state nil
+  "The current state for a drop.
+This is an alist with one entry for each display.  The value for each display
+is a vector that contains the state for drag and drop for that display.
+Elements in the vector are:
+Last buffer drag was in,
+last window drag was in,
+types available for drop,
+the action suggested by the source,
+the type we want for the drop,
+the action we want for the drop,
+any protocol specific data.")
+
+(declare-function pgtk-get-selection-internal "pgtkselect.c")
+(declare-function pgtk-register-dnd-targets "pgtkselect.c")
+
+(defvar pgtk-dnd-empty-state [nil nil nil nil nil nil nil])
+
+(defun pgtk-dnd-init-frame (&optional frame)
+  "Setup drag and drop for FRAME (i.e. create appropriate properties)."
+  (when (eq 'pgtk (window-system frame))
+    (pgtk-register-dnd-targets frame pgtk-dnd-known-types)))
+
+(defun pgtk-dnd-get-state-cons-for-frame (frame-or-window)
+  "Return the entry in `pgtk-dnd-current-state' for a frame or window."
+  (let* ((frame (if (framep frame-or-window) frame-or-window
+		  (window-frame frame-or-window)))
+	 (display (frame-parameter frame 'display)))
+    (if (not (assoc display pgtk-dnd-current-state))
+	(push (cons display (copy-sequence pgtk-dnd-empty-state))
+	      pgtk-dnd-current-state))
+    (assoc display pgtk-dnd-current-state)))
+
+(defun pgtk-dnd-get-state-for-frame (frame-or-window)
+  "Return the state in `pgtk-dnd-current-state' for a frame or window."
+  (cdr (pgtk-dnd-get-state-cons-for-frame frame-or-window)))
+
+(defun pgtk-dnd-default-test-function (_window _action types)
+  "The default test function for drag and drop.
+WINDOW is where the mouse is when this function is called.  It may be
+a frame if the mouse is over the menu bar, scroll bar or tool bar.
+ACTION is the suggested action from the source, and TYPES are the
+types the drop data can have.  This function only accepts drops with
+types in `pgtk-dnd-known-types'.  It always returns the action `copy'."
+  (let ((type (pgtk-dnd-choose-type types)))
+    (when type (cons 'copy type))))
+
+(defun pgtk-dnd-current-type (frame-or-window)
+  "Return the type we want the DND data to be in for the current drop.
+FRAME-OR-WINDOW is the frame or window that the mouse is over."
+  (aref (pgtk-dnd-get-state-for-frame frame-or-window) 4))
+
+(defun pgtk-dnd-forget-drop (frame-or-window)
+  "Remove all state for the last drop.
+FRAME-OR-WINDOW is the frame or window that the mouse is over."
+  (setcdr (pgtk-dnd-get-state-cons-for-frame frame-or-window)
+	  (copy-sequence pgtk-dnd-empty-state)))
+
+(defun pgtk-dnd-maybe-call-test-function (window action)
+  "Call `pgtk-dnd-test-function' if something has changed.
+WINDOW is the window the mouse is over.  ACTION is the suggested
+action from the source.  If nothing has changed, return the last
+action and type we got from `pgtk-dnd-test-function'."
+  (let ((buffer (when (window-live-p window)
+		  (window-buffer window)))
+	(current-state (pgtk-dnd-get-state-for-frame window)))
+    (unless (and (equal buffer (aref current-state 0))
+                 (equal window (aref current-state 1))
+                 (equal action (aref current-state 3)))
+      (save-current-buffer
+	(when buffer (set-buffer buffer))
+	(let* ((action-type (funcall pgtk-dnd-test-function
+				     window
+				     action
+				     (aref current-state 2)))
+	       (handler (cdr (assoc (cdr action-type) pgtk-dnd-types-alist))))
+	  ;; Ignore action-type if we have no handler.
+	  (setq current-state
+		(pgtk-dnd-save-state window
+				  action
+				  (when handler action-type)))))))
+  (let ((current-state (pgtk-dnd-get-state-for-frame window)))
+    (cons (aref current-state 5)
+	  (aref current-state 4))))
+
+(defun pgtk-dnd-save-state (window action action-type &optional types extra-data)
+  "Save the state of the current drag and drop.
+WINDOW is the window the mouse is over.  ACTION is the action suggested
+by the source.  ACTION-TYPE is the result of calling `pgtk-dnd-test-function'.
+If given, TYPES are the types for the drop data that the source supports.
+EXTRA-DATA is data needed for a specific protocol."
+  (let ((current-state (pgtk-dnd-get-state-for-frame window)))
+    (aset current-state 5 (car action-type))
+    (aset current-state 4 (cdr action-type))
+    (aset current-state 3 action)
+    (when types (aset current-state 2 types))
+    (when extra-data (aset current-state 6 extra-data))
+    (aset current-state 1 window)
+    (aset current-state 0 (and (window-live-p window) (window-buffer window)))
+    (setcdr (pgtk-dnd-get-state-cons-for-frame window) current-state)))
+
+
+(defun pgtk-dnd-handle-moz-url (window action data)
+  "Handle one item of type text/x-moz-url.
+WINDOW is the window where the drop happened.  ACTION is ignored.
+DATA is the moz-url, which is formatted as two strings separated by \\r\\n.
+The first string is the URL, the second string is the title of that URL.
+DATA is encoded in utf-16.  Decode the URL and call `pgtk-dnd-handle-uri-list'."
+  ;; Mozilla and applications based on it use text/unicode, but it is
+  ;; impossible to tell if it is le or be.  Use what the machine Emacs
+  ;; runs on uses.  This loses if dropping between machines
+  ;; with different endian-ness, but it is the best we can do.
+  (let* ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le))
+	 (string (decode-coding-string data coding))
+	 (strings (split-string string "[\r\n]" t))
+	 ;; Can one drop more than one moz-url ??  Assume not.
+	 (url (car strings)))
+    (pgtk-dnd-handle-uri-list window action url)))
+
+(defun pgtk-dnd-insert-utf8-text (window action text)
+  "Decode the UTF-8 text and insert it at point.
+TEXT is the text as a string, WINDOW is the window where the drop happened."
+  (dnd-insert-text window action (decode-coding-string text 'utf-8)))
+
+(defun pgtk-dnd-insert-utf16-text (window action text)
+  "Decode the UTF-16 text and insert it at point.
+TEXT is the text as a string, WINDOW is the window where the drop happened."
+  ;; See comment in pgtk-dnd-handle-moz-url about coding.
+  (let ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le)))
+    (dnd-insert-text window action (decode-coding-string text coding))))
+
+(defun pgtk-dnd-insert-ctext (window action text)
+  "Decode the compound text and insert it at point.
+TEXT is the text as a string, WINDOW is the window where the drop happened."
+  (dnd-insert-text window action
+		   (decode-coding-string text
+					 'compound-text-with-extensions)))
+
+(defun pgtk-dnd-handle-uri-list (window action string)
+  "Split an uri-list into separate URIs and call `dnd-handle-one-url'.
+WINDOW is the window where the drop happened.
+STRING is the uri-list as a string.  The URIs are separated by \\r\\n."
+  (let ((uri-list (split-string string "[\0\r\n]" t))
+	retval)
+    (dolist (bf uri-list)
+      ;; If one URL is handled, treat as if the whole drop succeeded.
+      (let ((did-action (dnd-handle-one-url window action bf)))
+	(when did-action (setq retval did-action))))
+    retval))
+
+(defun pgtk-dnd-handle-file-name (window action string)
+  "Convert file names to URLs and call `dnd-handle-one-url'.
+WINDOW is the window where the drop happened.
+STRING is the file names as a string, separated by nulls."
+  (let ((uri-list (split-string string "[\0\r\n]" t))
+	(coding (or file-name-coding-system
+		    default-file-name-coding-system))
+	retval)
+    (dolist (bf uri-list)
+      ;; If one URL is handled, treat as if the whole drop succeeded.
+      (if coding (setq bf (encode-coding-string bf coding)))
+      (let* ((file-uri (concat "file://"
+			       (mapconcat 'url-hexify-string
+					  (split-string bf "/") "/")))
+	     (did-action (dnd-handle-one-url window action file-uri)))
+	(when did-action (setq retval did-action))))
+    retval))
+
+
+(defun pgtk-dnd-choose-type (types &optional known-types)
+  "Choose which type we want to receive for the drop.
+TYPES are the types the source of the drop offers, a vector of type names
+as strings or symbols.  Select among the types in `pgtk-dnd-known-types' or
+KNOWN-TYPES if given, and return that type name.
+If no suitable type is found, return nil."
+  (let* ((known-list (or known-types pgtk-dnd-known-types))
+	 (first-known-type (car known-list))
+	 (types-array types)
+	 (found (when first-known-type
+		  (catch 'done
+		    (dotimes (i (length types-array))
+		      (let* ((type (aref types-array i))
+			     (typename (if (symbolp type)
+					   (symbol-name type) type)))
+			(when (equal first-known-type typename)
+			  (throw 'done first-known-type))))
+		    nil))))
+
+    (if (and (not found) (cdr known-list))
+	(pgtk-dnd-choose-type types (cdr known-list))
+      found)))
+
+(defun pgtk-dnd-drop-data (event frame window data type)
+  "Drop one data item onto a frame.
+EVENT is the client message for the drop, FRAME is the frame the drop
+occurred on.  WINDOW is the window of FRAME where the drop happened.
+DATA is the data received from the source, and type is the type for DATA,
+see `pgtk-dnd-types-alist').
+
+Returns the action used (move, copy, link, private) if drop was successful,
+nil if not."
+  (let* ((type-info (assoc type pgtk-dnd-types-alist))
+	 (handler (cdr type-info))
+	 (state (pgtk-dnd-get-state-for-frame frame))
+	 (action (aref state 5))
+	 (w (posn-window (event-start event))))
+    (when handler
+      (if (and (window-live-p w)
+	       (not (window-minibuffer-p w))
+	       (not (window-dedicated-p w)))
+	  ;; If dropping in an ordinary window which we could use,
+	  ;; let dnd-open-file-other-window specify what to do.
+	  (progn
+	    (when (and (not mouse-yank-at-point)
+                       ;; If dropping on top of the mode line, insert
+                       ;; the text at point instead.
+                       (posn-point (event-start event)))
+	      (goto-char (posn-point (event-start event))))
+	    (funcall handler window action data))
+	;; If we can't display the file here,
+	;; make a new window for it.
+	(let ((dnd-open-file-other-window t))
+	  (select-frame frame)
+	  (funcall handler window action data))))))
+
+(defun pgtk-dnd-handle-drag-n-drop-event (event)
+  "Receive drag and drop events (X client messages).
+Currently XDND, Motif and old KDE 1.x protocols are recognized."
+  (interactive "e")
+  (let* ((client-message (car (cdr (cdr event))))
+	 (window (posn-window (event-start event)))
+         (frame (if (framep window)
+                    window
+                  (window-frame window))))
+    (pgtk-dnd-handle-gdk event frame window client-message)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;  GDK protocol.
+
+(declare-function pgtk-update-drop-status "pgtkselect.c")
+(declare-function pgtk-drop-finish "pgtkselect.c")
+
+(defun pgtk-dnd-handle-gdk (event frame window client-message)
+  "Handle drag-n-drop EVENT on FRAME.
+WINDOW should be the window the event happened on top of.
+CLIENT-MESSAGE is the detailed description of the drag-and-drop
+message."
+  (cond
+   ;; We can't handle `drag-leave' here, since that signal is also
+   ;; sent right before `drag-drop', and there is no reliable way to
+   ;; distinguish the two.
+   ((eq (car client-message) 'lambda) ; drag-motion
+    (let ((state (pgtk-dnd-get-state-for-frame frame)))
+      (unless (aref state 0) ;; This is actually an entry.
+        (pgtk-dnd-save-state window nil nil
+                             (pgtk-get-selection-internal
+                              (nth 1 client-message) 'TARGETS)
+                             t)
+        (setq state (pgtk-dnd-get-state-for-frame frame)))
+      (let* ((action (nth 3 client-message))
+             (time (nth 2 client-message))
+             (action-type (pgtk-dnd-maybe-call-test-function window
+                                                             action)))
+        (pgtk-update-drop-status (car action-type) time)
+        (dnd-handle-movement (event-start event)))))
+   ((eq (car client-message) 'quote) ; drag-drop
+    (let* ((timestamp (nth 2 client-message))
+           (value (and (pgtk-dnd-current-type window)
+                       (pgtk-get-selection-internal
+                        (nth 1 client-message)
+                        (intern (pgtk-dnd-current-type window))
+                        timestamp)))
+           action)
+      (unwind-protect
+          (setq action (when value
+                         (condition-case info
+			     (pgtk-dnd-drop-data
+                              event frame window value
+			      (pgtk-dnd-current-type window))
+			   (error
+			    (message "Error: %s" info)
+			    nil))))
+        (pgtk-drop-finish action timestamp (eq action 'move))
+        (pgtk-dnd-forget-drop window))))))
+
+(provide 'pgtk-dnd)
+
+;;; pgtk-dnd.el ends here