lisp/term/ns-win.el

   1 ;;; ns-win.el --- lisp side of interface with NeXT/Open/GNUstep/macOS window system  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 1993-1994, 2005-2017 Free Software Foundation, Inc.
   4
   5 ;; Authors: Carl Edman
   6 ;;      Christian Limpach
   7 ;;      Scott Bender
   8 ;;      Christophe de Dinechin
   9 ;;      Adrian Robert
  10 ;; Keywords: terminals
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  26
  27 ;;; Commentary:
  28
  29 ;; ns-win.el: this file is loaded from ../lisp/startup.el when it
  30 ;; recognizes that Nextstep windows are to be used.  Command line
  31 ;; switches are parsed and those pertaining to Nextstep are processed
  32 ;; and removed from the command line.  The Nextstep display is opened
  33 ;; and hooks are set for popping up the initial window.
  34
  35 ;; startup.el will then examine startup files, and eventually call the hooks
  36 ;; which create the first window (s).
  37
  38 ;; A number of other Nextstep convenience functions are defined in
  39 ;; this file, which works in close coordination with src/nsfns.m.
  40
  41 ;;; Code:
  42 (eval-when-compile (require 'cl-lib))
  43 (or (featurep 'ns)
  44     (error "%s: Loading ns-win.el but not compiled for GNUstep/macOS"
  45            invocation-name))
  46
  47 ;; Documentation-purposes only: actually loaded in loadup.el.
  48 (require 'frame)
  49 (require 'mouse)
  50 (require 'faces)
  51 (require 'menu-bar)
  52 (require 'fontset)
  53 (require 'dnd)
  54 (require 'ucs-normalize)
  55
  56 (defgroup ns nil
  57   "GNUstep/macOS specific features."
  58   :group 'environment)
  59
  60 ;;;; Command line argument handling.
  61
  62 (defvar x-invocation-args)
  63 ;; Set in term/common-win.el; currently unused by Nextstep's x-open-connection.
  64 (defvar x-command-line-resources)
  65
  66 ;; nsterm.m.
  67 (defvar ns-input-file)
  68
  69 (defun ns-handle-nxopen (_switch &optional temp)
  70   (setq unread-command-events (append unread-command-events
  71                                       (if temp '(ns-open-temp-file)
  72                                         '(ns-open-file)))
  73         ns-input-file (append ns-input-file (list (pop x-invocation-args)))))
  74
  75 (defun ns-handle-nxopentemp (switch)
  76   (ns-handle-nxopen switch t))
  77
  78 (defun ns-ignore-1-arg (_switch)
  79   (setq x-invocation-args (cdr x-invocation-args)))
  80
  81 (defun ns-parse-geometry (geom)
  82   "Parse a Nextstep-style geometry string GEOM.
  83 Returns an alist of the form ((top . TOP), (left . LEFT) ... ).
  84 The properties returned may include `top', `left', `height', and `width'."
  85   (when (string-match "\\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\)\
  86 \\( \\([0-9]+\\) ?\\)?\\)?\\)?"
  87                       geom)
  88     (apply
  89      'append
  90      (list
  91       (list (cons 'top (string-to-number (match-string 1 geom))))
  92       (if (match-string 3 geom)
  93           (list (cons 'left (string-to-number (match-string 3 geom)))))
  94       (if (match-string 5 geom)
  95           (list (cons 'height (string-to-number (match-string 5 geom)))))
  96       (if (match-string 7 geom)
  97           (list (cons 'width (string-to-number (match-string 7 geom)))))))))
  98
  99 ;;;; Keyboard mapping.
 100
 101 (define-obsolete-variable-alias 'ns-alternatives-map 'x-alternatives-map "24.1")
 102
 103 ;; Here are some Nextstep-like bindings for command key sequences.
 104 (define-key global-map [?\s-,] 'customize)
 105 (define-key global-map [?\s-'] 'next-multiframe-window)
 106 (define-key global-map [?\s-`] 'other-frame)
 107 (define-key global-map [?\s-~] 'ns-prev-frame)
 108 (define-key global-map [?\s--] 'center-line)
 109 (define-key global-map [?\s-:] 'ispell)
 110 (define-key global-map [?\s-?] 'info)
 111 (define-key global-map [?\s-^] 'kill-some-buffers)
 112 (define-key global-map [?\s-&] 'kill-current-buffer)
 113 (define-key global-map [?\s-C] 'ns-popup-color-panel)
 114 (define-key global-map [?\s-D] 'dired)
 115 (define-key global-map [?\s-E] 'edit-abbrevs)
 116 (define-key global-map [?\s-L] 'shell-command)
 117 (define-key global-map [?\s-M] 'manual-entry)
 118 (define-key global-map [?\s-S] 'ns-write-file-using-panel)
 119 (define-key global-map [?\s-a] 'mark-whole-buffer)
 120 (define-key global-map [?\s-c] 'ns-copy-including-secondary)
 121 (define-key global-map [?\s-d] 'isearch-repeat-backward)
 122 (define-key global-map [?\s-e] 'isearch-yank-kill)
 123 (define-key global-map [?\s-f] 'isearch-forward)
 124 (define-key global-map [?\s-g] 'isearch-repeat-forward)
 125 (define-key global-map [?\s-h] 'ns-do-hide-emacs)
 126 (define-key global-map [?\s-H] 'ns-do-hide-others)
 127 (define-key global-map [?\M-\s-h] 'ns-do-hide-others)
 128 (define-key key-translation-map [?\M-\s-\u02D9] [?\M-\s-h])
 129 (define-key global-map [?\s-j] 'exchange-point-and-mark)
 130 (define-key global-map [?\s-k] 'kill-current-buffer)
 131 (define-key global-map [?\s-l] 'goto-line)
 132 (define-key global-map [?\s-m] 'iconify-frame)
 133 (define-key global-map [?\s-n] 'make-frame)
 134 (define-key global-map [?\s-o] 'ns-open-file-using-panel)
 135 (define-key global-map [?\s-p] 'ns-print-buffer)
 136 (define-key global-map [?\s-q] 'save-buffers-kill-emacs)
 137 (define-key global-map [?\s-s] 'save-buffer)
 138 (define-key global-map [?\s-t] 'ns-popup-font-panel)
 139 (define-key global-map [?\s-u] 'revert-buffer)
 140 (define-key global-map [?\s-v] 'yank)
 141 (define-key global-map [?\s-w] 'delete-frame)
 142 (define-key global-map [?\s-x] 'kill-region)
 143 (define-key global-map [?\s-y] 'ns-paste-secondary)
 144 (define-key global-map [?\s-z] 'undo)
 145 (define-key global-map [?\s-|] 'shell-command-on-region)
 146 (define-key global-map [s-kp-bar] 'shell-command-on-region)
 147 ;; (as in Terminal.app)
 148 (define-key global-map [s-right] 'ns-next-frame)
 149 (define-key global-map [s-left] 'ns-prev-frame)
 150
 151 (define-key global-map [home] 'beginning-of-buffer)
 152 (define-key global-map [end] 'end-of-buffer)
 153 (define-key global-map [kp-home] 'beginning-of-buffer)
 154 (define-key global-map [kp-end] 'end-of-buffer)
 155 (define-key global-map [kp-prior] 'scroll-down-command)
 156 (define-key global-map [kp-next] 'scroll-up-command)
 157
 158 ;; Allow shift-clicks to work similarly to under Nextstep.
 159 (define-key global-map [S-mouse-1] 'mouse-save-then-kill)
 160 (global-unset-key [S-down-mouse-1])
 161
 162 ;; Special Nextstep-generated events are converted to function keys.  Here
 163 ;; are the bindings for them.  Note, these keys are actually declared in
 164 ;; x-setup-function-keys in common-win.
 165 (define-key global-map [ns-power-off] 'save-buffers-kill-emacs)
 166 (define-key global-map [ns-open-file] 'ns-find-file)
 167 (define-key global-map [ns-open-temp-file] [ns-open-file])
 168 (define-key global-map [ns-change-font] 'ns-respond-to-change-font)
 169 (define-key global-map [ns-open-file-line] 'ns-open-file-select-line)
 170 (define-key global-map [ns-spi-service-call] 'ns-spi-service-call)
 171 (define-key global-map [ns-new-frame] 'make-frame)
 172 (define-key global-map [ns-toggle-toolbar] 'ns-toggle-toolbar)
 173 (define-key global-map [ns-show-prefs] 'customize)
 174
 175
 176 ;; Set up a number of aliases and other layers to pretend we're using
 177 ;; the Choi/Mitsuharu Carbon port.
 178
 179 (defvaralias 'mac-allow-anti-aliasing 'ns-antialias-text)
 180 (defvaralias 'mac-command-modifier 'ns-command-modifier)
 181 (defvaralias 'mac-right-command-modifier 'ns-right-command-modifier)
 182 (defvaralias 'mac-control-modifier 'ns-control-modifier)
 183 (defvaralias 'mac-right-control-modifier 'ns-right-control-modifier)
 184 (defvaralias 'mac-option-modifier 'ns-option-modifier)
 185 (defvaralias 'mac-right-option-modifier 'ns-right-option-modifier)
 186 (defvaralias 'mac-function-modifier 'ns-function-modifier)
 187 (declare-function ns-do-applescript "nsfns.m" (script))
 188 (defalias 'do-applescript 'ns-do-applescript)
 189
 190 ;;;; Services
 191 (declare-function ns-perform-service "nsfns.m" (service send))
 192
 193 (defun ns-define-service (path)
 194   (let ((mapping [menu-bar services])
 195         (service (mapconcat 'identity path "/"))
 196         (name (intern
 197                (subst-char-in-string
 198                 ?\s ?-
 199                 (mapconcat 'identity (cons "ns-service" path) "-")))))
 200     ;; This defines the function.
 201     (defalias name
 202       (lambda (arg)
 203         (interactive "p")
 204         (let* ((in-string
 205                 (cond ((stringp arg) arg)
 206                       (mark-active
 207                        (buffer-substring (region-beginning) (region-end)))))
 208                (out-string (ns-perform-service service in-string)))
 209           (cond
 210            ((stringp arg) out-string)
 211            ((and out-string (or (not in-string)
 212                                 (not (string= in-string out-string))))
 213             (if mark-active (delete-region (region-beginning) (region-end)))
 214             (insert out-string)
 215             (setq deactivate-mark nil))))))
 216     (cond
 217      ((lookup-key global-map mapping)
 218       (while (cdr path)
 219         (setq mapping (vconcat mapping (list (intern (car path)))))
 220         (if (not (keymapp (lookup-key global-map mapping)))
 221             (define-key global-map mapping
 222               (cons (car path) (make-sparse-keymap (car path)))))
 223         (setq path (cdr path)))
 224       (setq mapping (vconcat mapping (list (intern (car path)))))
 225       (define-key global-map mapping (cons (car path) name))))
 226     name))
 227
 228 ;; nsterm.m
 229 (defvar ns-input-spi-name)
 230 (defvar ns-input-spi-arg)
 231
 232 (declare-function dnd-open-file "dnd" (uri action))
 233
 234 ;; Handles multiline strings that are passed to the "open-file" service.
 235 (defun ns-open-file-service (filenames)
 236   "Open multiple files when selecting a multiline string FILENAMES."
 237   (let ((filelist (split-string filenames "[\n\r]+" t "[ \u00A0\t]+")))
 238     ;; The path strings are trimmed for spaces, nbsp and tabs.
 239     (dolist (filestring filelist)
 240       (dnd-open-file filestring nil))))
 241
 242
 243 (defun ns-spi-service-call ()
 244   "Respond to a service request."
 245   (interactive)
 246   (cond ((string-equal ns-input-spi-name "open-selection")
 247          (switch-to-buffer (generate-new-buffer "*untitled*"))
 248          (insert ns-input-spi-arg))
 249         ((string-equal ns-input-spi-name "open-file")
 250          (ns-open-file-service ns-input-spi-arg))
 251         ((string-equal ns-input-spi-name "mail-selection")
 252          (compose-mail)
 253          (rfc822-goto-eoh)
 254          (forward-line 1)
 255          (insert ns-input-spi-arg))
 256         ((string-equal ns-input-spi-name "mail-to")
 257          (compose-mail ns-input-spi-arg))
 258         (t (error "Service %s not recognized" ns-input-spi-name))))
 259
 260
 261 ;; Composed key sequence handling for Nextstep system input methods.
 262 ;; (On Nextstep systems, input methods are provided for CJK
 263 ;; characters, etc. which require multiple keystrokes, and during
 264 ;; entry a partial ("working") result is typically shown in the
 265 ;; editing window.)
 266
 267 (defface ns-working-text-face
 268   '((t :underline t))
 269   "Face used to highlight working text during compose sequence insert."
 270   :group 'ns)
 271
 272 (defvar ns-working-overlay nil
 273   "Overlay used to highlight working text during compose sequence insert.
 274 When text is in th echo area, this just stores the length of the working text.")
 275
 276 (defvar ns-working-text)                ; nsterm.m
 277
 278 ;; Test if in echo area, based on mac-win.el 2007/08/26 unicode-2.
 279 ;; This will fail if called from a NONASCII_KEYSTROKE event on the global map.
 280 (defun ns-in-echo-area ()
 281   "Whether, for purposes of inserting working composition text, the minibuffer
 282 is currently being used."
 283   (or isearch-mode
 284       (and cursor-in-echo-area (current-message))
 285       ;; Overlay strings are not shown in some cases.
 286       (get-char-property (point) 'invisible)
 287       (and (not (bobp))
 288            (or (and (get-char-property (point) 'display)
 289                     (eq (get-char-property (1- (point)) 'display)
 290                         (get-char-property (point) 'display)))
 291                (and (get-char-property (point) 'composition)
 292                     (eq (get-char-property (1- (point)) 'composition)
 293                         (get-char-property (point) 'composition)))))))
 294
 295 ;; The 'interactive' here stays for subinvocations, so the ns-in-echo-area
 296 ;; always returns nil for some reason.  If this WASN'T the case, we could
 297 ;; map this to [ns-insert-working-text] and eliminate Fevals in nsterm.m.
 298 ;; These functions test whether in echo area and delegate accordingly.
 299 (defun ns-put-working-text ()
 300   (interactive)
 301   (if (ns-in-echo-area) (ns-echo-working-text) (ns-insert-working-text)))
 302 (defun ns-unput-working-text ()
 303   (interactive)
 304   (ns-delete-working-text))
 305
 306 (defun ns-insert-working-text ()
 307   "Insert contents of `ns-working-text' as UTF-8 string and mark with
 308 `ns-working-overlay'.  Any previously existing working text is cleared first.
 309 The overlay is assigned the face `ns-working-text-face'."
 310   ;; FIXME: if buffer is read-only, don't try to insert anything
 311   ;;  and if text is bound to a command, execute that instead (Bug#1453)
 312   (interactive)
 313   (ns-delete-working-text)
 314   (let ((start (point)))
 315     (insert ns-working-text)
 316     (overlay-put (setq ns-working-overlay (make-overlay start (point)
 317                                                         (current-buffer) nil t))
 318                  'face 'ns-working-text-face)))
 319
 320 (defun ns-echo-working-text ()
 321   "Echo contents of `ns-working-text' in message display area.
 322 See `ns-insert-working-text'."
 323   (ns-delete-working-text)
 324   (let* ((msg (current-message))
 325          (msglen (length msg))
 326          message-log-max)
 327     (setq ns-working-overlay (length ns-working-text))
 328     (setq msg (concat msg ns-working-text))
 329     (put-text-property msglen (+ msglen ns-working-overlay)
 330                        'face 'ns-working-text-face msg)
 331     (message "%s" msg)))
 332
 333 (defun ns-delete-working-text()
 334   "Delete working text and clear `ns-working-overlay'."
 335   (interactive)
 336   (cond
 337    ((and (overlayp ns-working-overlay)
 338          ;; Still alive?
 339          (overlay-buffer ns-working-overlay))
 340     (with-current-buffer (overlay-buffer ns-working-overlay)
 341       (delete-region (overlay-start ns-working-overlay)
 342                      (overlay-end ns-working-overlay))
 343       (delete-overlay ns-working-overlay)))
 344    ((integerp ns-working-overlay)
 345     (let ((msg (current-message))
 346           message-log-max)
 347       (setq msg (substring msg 0 (- (length msg) ns-working-overlay)))
 348       (message "%s" msg))))
 349   (setq ns-working-overlay nil))
 350
 351
 352 ;; macOS file system Unicode UTF-8 NFD (decomposed form) support.
 353 (when (eq system-type 'darwin)
 354   ;; Used prior to Emacs 25.
 355   (define-coding-system-alias 'utf-8-nfd 'utf-8-hfs)
 356
 357   (set-file-name-coding-system 'utf-8-hfs))
 358
 359 ;;;; Inter-app communications support.
 360
 361 (defun ns-insert-file ()
 362   "Insert contents of file `ns-input-file' like insert-file but with less
 363 prompting.  If file is a directory perform a `find-file' on it."
 364   (interactive)
 365   (let ((f (pop ns-input-file)))
 366     (if (file-directory-p f)
 367         (find-file f)
 368       (push-mark (+ (point) (cadr (insert-file-contents f)))))))
 369
 370 (defvar ns-select-overlay nil
 371   "Overlay used to highlight areas in files requested by Nextstep apps.")
 372 (make-variable-buffer-local 'ns-select-overlay)
 373
 374 (defvar ns-input-line)                  ; nsterm.m
 375
 376 (defun ns-open-file-select-line ()
 377   "Open a buffer containing the file `ns-input-file'.
 378 Lines are highlighted according to `ns-input-line'."
 379   (interactive)
 380   (ns-find-file)
 381   (cond
 382    ((and ns-input-line (buffer-modified-p))
 383     (if ns-select-overlay
 384         (setq ns-select-overlay (delete-overlay ns-select-overlay)))
 385     (deactivate-mark)
 386     (goto-char (point-min))
 387     (forward-line (1- (if (consp ns-input-line)
 388                           (min (car ns-input-line) (cdr ns-input-line))
 389                         ns-input-line))))
 390    (ns-input-line
 391     (if (not ns-select-overlay)
 392         (overlay-put (setq ns-select-overlay (make-overlay (point-min)
 393                                                            (point-min)))
 394                      'face 'highlight))
 395     (let ((beg (save-excursion
 396                  (goto-char (point-min))
 397                  (line-beginning-position
 398                   (if (consp ns-input-line)
 399                       (min (car ns-input-line) (cdr ns-input-line))
 400                     ns-input-line))))
 401           (end (save-excursion
 402                  (goto-char (point-min))
 403                  (line-beginning-position
 404                   (1+ (if (consp ns-input-line)
 405                           (max (car ns-input-line) (cdr ns-input-line))
 406                         ns-input-line))))))
 407       (move-overlay ns-select-overlay beg end)
 408       (deactivate-mark)
 409       (goto-char beg)))
 410    (t
 411     (if ns-select-overlay
 412         (setq ns-select-overlay (delete-overlay ns-select-overlay))))))
 413
 414 (defun ns-unselect-line ()
 415   "Removes any Nextstep highlight a buffer may contain."
 416   (if ns-select-overlay
 417       (setq ns-select-overlay (delete-overlay ns-select-overlay))))
 418
 419 (add-hook 'first-change-hook 'ns-unselect-line)
 420
 421 ;;;; Preferences handling.
 422 (declare-function ns-get-resource "nsfns.m" (owner name))
 423
 424 (defun get-lisp-resource (arg1 arg2)
 425   (let ((res (ns-get-resource arg1 arg2)))
 426     (cond
 427      ((not res) 'unbound)
 428      ((string-equal (upcase res) "YES") t)
 429      ((string-equal (upcase res) "NO")  nil)
 430      (t (read res)))))
 431
 432 ;; nsterm.m
 433
 434 (declare-function ns-read-file-name "nsfns.m"
 435                   (prompt &optional dir mustmatch init dir_only_p))
 436
 437 ;;;; File handling.
 438
 439 (defun x-file-dialog (prompt dir default_filename mustmatch only_dir_p)
 440 "Read file name, prompting with PROMPT in directory DIR.
 441 Use a file selection dialog.  Select DEFAULT-FILENAME in the dialog's file
 442 selection box, if specified.  If MUSTMATCH is non-nil, the returned file
 443 or directory must exist.
 444
 445 This function is only defined on NS, MS Windows, and X Windows with the
 446 Motif or Gtk toolkits.  With the Motif toolkit, ONLY-DIR-P is ignored.
 447 Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories."
 448   (ns-read-file-name prompt dir mustmatch default_filename only_dir_p))
 449
 450 (defun ns-open-file-using-panel ()
 451   "Pop up open-file panel, and load the result in a buffer."
 452   (interactive)
 453   ;; Prompt dir defaultName isLoad initial.
 454   (setq ns-input-file (ns-read-file-name "Select File to Load" nil t nil))
 455   (if ns-input-file
 456       (and (setq ns-input-file (list ns-input-file)) (ns-find-file))))
 457
 458 (defun ns-write-file-using-panel ()
 459   "Pop up save-file panel, and save buffer in resulting name."
 460   (interactive)
 461   (let (ns-output-file)
 462     ;; Prompt dir defaultName isLoad initial.
 463     (setq ns-output-file (ns-read-file-name "Save As" nil nil nil))
 464     (message ns-output-file)
 465     (if ns-output-file (write-file ns-output-file))))
 466
 467 (defcustom ns-pop-up-frames 'fresh
 468   "Non-nil means open files upon request from the Workspace in a new frame.
 469 If t, always do so.  Any other non-nil value means open a new frame
 470 unless the current buffer is a scratch buffer."
 471   :type '(choice (const :tag "Never" nil)
 472                  (const :tag "Always" t)
 473                  (other :tag "Except for scratch buffer" fresh))
 474   :version "23.1"
 475   :group 'ns)
 476
 477 (declare-function ns-hide-emacs "nsfns.m" (on))
 478
 479 (defun ns-find-file ()
 480   "Do a `find-file' with the `ns-input-file' as argument."
 481   (interactive)
 482   (let* ((f (file-truename
 483              (expand-file-name (pop ns-input-file)
 484                                command-line-default-directory)))
 485          (file (find-file-noselect f))
 486          (bufwin1 (get-buffer-window file 'visible))
 487          (bufwin2 (get-buffer-window "*scratch*" 'visible)))
 488     (cond
 489      (bufwin1
 490       (select-frame (window-frame bufwin1))
 491       (raise-frame (window-frame bufwin1))
 492       (select-window bufwin1))
 493      ((and (eq ns-pop-up-frames 'fresh) bufwin2)
 494       (ns-hide-emacs 'activate)
 495       (select-frame (window-frame bufwin2))
 496       (raise-frame (window-frame bufwin2))
 497       (select-window bufwin2)
 498       (find-file f))
 499      (ns-pop-up-frames
 500       (ns-hide-emacs 'activate)
 501       (let ((pop-up-frames t)) (pop-to-buffer file nil)))
 502      (t
 503       (ns-hide-emacs 'activate)
 504       (find-file f)))))
 505
 506
 507 (defun ns-drag-n-drop (event &optional new-frame force-text)
 508   "Edit the files listed in the drag-n-drop EVENT.
 509 Switch to a buffer editing the last file dropped."
 510   (interactive "e")
 511   (let* ((window (posn-window (event-start event)))
 512          (arg (car (cdr (cdr event))))
 513          (type (car arg))
 514          (data (car (cdr arg)))
 515          (url-or-string (cond ((eq type 'file)
 516                                (concat "file:" data))
 517                               (t data))))
 518     (set-frame-selected-window nil window)
 519     (when new-frame
 520       (select-frame (make-frame)))
 521     (raise-frame)
 522     (setq window (selected-window))
 523     (if force-text
 524         (dnd-insert-text window 'private data)
 525       (dnd-handle-one-url window 'private url-or-string))))
 526
 527
 528 (defun ns-drag-n-drop-other-frame (event)
 529   "Edit the files listed in the drag-n-drop EVENT, in other frames.
 530 May create new frames, or reuse existing ones.  The frame editing
 531 the last file dropped is selected."
 532   (interactive "e")
 533   (ns-drag-n-drop event t))
 534
 535 (defun ns-drag-n-drop-as-text (event)
 536   "Drop the data in EVENT as text."
 537   (interactive "e")
 538   (ns-drag-n-drop event nil t))
 539
 540 (defun ns-drag-n-drop-as-text-other-frame (event)
 541   "Drop the data in EVENT as text in a new frame."
 542   (interactive "e")
 543   (ns-drag-n-drop event t t))
 544
 545 (global-set-key [drag-n-drop] 'ns-drag-n-drop)
 546 (global-set-key [C-drag-n-drop] 'ns-drag-n-drop-other-frame)
 547 (global-set-key [M-drag-n-drop] 'ns-drag-n-drop-as-text)
 548 (global-set-key [C-M-drag-n-drop] 'ns-drag-n-drop-as-text-other-frame)
 549
 550 ;;;; Frame-related functions.
 551
 552 ;; nsterm.m
 553 (defvar ns-alternate-modifier)
 554 (defvar ns-right-alternate-modifier)
 555 (defvar ns-right-command-modifier)
 556 (defvar ns-right-control-modifier)
 557
 558 ;; You say tomAYto, I say tomAHto..
 559 (defvaralias 'ns-option-modifier 'ns-alternate-modifier)
 560 (defvaralias 'ns-right-option-modifier 'ns-right-alternate-modifier)
 561
 562 (defun ns-do-hide-emacs ()
 563   (interactive)
 564   (ns-hide-emacs t))
 565
 566 (declare-function ns-hide-others "nsfns.m" ())
 567
 568 (defun ns-do-hide-others ()
 569   (interactive)
 570   (ns-hide-others))
 571
 572 (declare-function ns-emacs-info-panel "nsfns.m" ())
 573
 574 (defun ns-do-emacs-info-panel ()
 575   (interactive)
 576   (ns-emacs-info-panel))
 577
 578 (defun ns-next-frame ()
 579   "Switch to next visible frame."
 580   (interactive)
 581   (other-frame 1))
 582
 583 (defun ns-prev-frame ()
 584   "Switch to previous visible frame."
 585   (interactive)
 586   (other-frame -1))
 587
 588 ;; Frame will be focused anyway, so select it
 589 ;; (if this is not done, mode line is dimmed until first interaction)
 590 ;; FIXME: Sounds like we're working around a bug in the underlying code.
 591 (add-hook 'after-make-frame-functions 'select-frame)
 592
 593 (defvar tool-bar-mode)
 594 (declare-function tool-bar-mode "tool-bar" (&optional arg))
 595
 596 ;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
 597 ;; see https://lists.gnu.org/r/emacs-devel/2005-09/msg00681.html .
 598 (defun ns-toggle-toolbar (&optional frame)
 599   "Switches the tool bar on and off in frame FRAME.
 600  If FRAME is nil, the change applies to the selected frame."
 601   (interactive)
 602   (modify-frame-parameters
 603    frame (list (cons 'tool-bar-lines
 604                        (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
 605                                    0 1)) ))
 606   (if (not tool-bar-mode) (tool-bar-mode t)))
 607
 608
 609 ;;;; Dialog-related functions.
 610
 611 ;; Ask user for confirm before printing.  Due to Kevin Rodgers.
 612 (defun ns-print-buffer ()
 613   "Interactive front-end to `print-buffer': asks for user confirmation first."
 614   (interactive)
 615   (if (and (called-interactively-p 'interactive)
 616            (or (listp last-nonmenu-event)
 617                (and (char-or-string-p (event-basic-type last-command-event))
 618                     (memq 'super (event-modifiers last-command-event)))))
 619       (let ((last-nonmenu-event (if (listp last-nonmenu-event)
 620                                     last-nonmenu-event
 621                                   ;; Fake it:
 622                                   `(mouse-1 POSITION 1))))
 623         (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
 624             (print-buffer)
 625           (error "Canceled")))
 626     (print-buffer)))
 627
 628 ;;;; Font support.
 629
 630 ;; Needed for font listing functions under both backend and normal
 631 (setq scalable-fonts-allowed t)
 632
 633 ;; Set to use font panel instead
 634 (declare-function ns-popup-font-panel "nsfns.m" (&optional frame))
 635 (defalias 'x-select-font 'ns-popup-font-panel "Pop up the font panel.
 636 This function has been overloaded in Nextstep.")
 637 (defalias 'mouse-set-font 'ns-popup-font-panel "Pop up the font panel.
 638 This function has been overloaded in Nextstep.")
 639
 640 ;; nsterm.m
 641 (defvar ns-input-font)
 642 (defvar ns-input-fontsize)
 643
 644 (defun ns-respond-to-change-font ()
 645   "Respond to changeFont: event, expecting `ns-input-font' and\n\
 646 `ns-input-fontsize' of new font."
 647   (interactive)
 648   (modify-frame-parameters (selected-frame)
 649                            (list (cons 'fontsize ns-input-fontsize)))
 650   (modify-frame-parameters (selected-frame)
 651                            (list (cons 'font ns-input-font)))
 652   (set-frame-font ns-input-font))
 653
 654
 655 ;; Default fontset for macOS.  This is mainly here to show how a fontset
 656 ;; can be set up manually.  Ordinarily, fontsets are auto-created whenever
 657 ;; a font is chosen by
 658 (defvar ns-standard-fontset-spec
 659   ;; Only some code supports this so far, so use uglier XLFD version
 660   ;; "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
 661   (mapconcat 'identity
 662              '("-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard"
 663                "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1"
 664                "han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1"
 665                "cyrillic:-*-Trebuchet$MS-*-*-*-*-10-*-*-*-*-*-iso10646-1")
 666              ",")
 667   "String of fontset spec of the standard fontset.
 668 This defines a fontset consisting of the Courier and other fonts that
 669 come with macOS.
 670 See the documentation of `create-fontset-from-fontset-spec' for the format.")
 671
 672 (defvar ns-reg-to-script)               ; nsfont.m
 673
 674 ;; This maps font registries (not exposed by NS APIs for font selection) to
 675 ;; Unicode scripts (which can be mapped to Unicode character ranges which are).
 676 ;; See ../international/fontset.el
 677 (setq ns-reg-to-script
 678       '(("iso8859-1" . latin)
 679         ("iso8859-2" . latin)
 680         ("iso8859-3" . latin)
 681         ("iso8859-4" . latin)
 682         ("iso8859-5" . cyrillic)
 683         ("microsoft-cp1251" . cyrillic)
 684         ("koi8-r" . cyrillic)
 685         ("iso8859-6" . arabic)
 686         ("iso8859-7" . greek)
 687         ("iso8859-8" . hebrew)
 688         ("iso8859-9" . latin)
 689         ("iso8859-10" . latin)
 690         ("iso8859-11" . thai)
 691         ("tis620" . thai)
 692         ("iso8859-13" . latin)
 693         ("iso8859-14" . latin)
 694         ("iso8859-15" . latin)
 695         ("iso8859-16" . latin)
 696         ("viscii1.1-1" . latin)
 697         ("jisx0201" . kana)
 698         ("jisx0208" . han)
 699         ("jisx0212" . han)
 700         ("jisx0213" . han)
 701         ("gb2312.1980" . han)
 702         ("gb18030" . han)
 703         ("gbk-0" . han)
 704         ("big5" . han)
 705         ("cns11643" . han)
 706         ("sisheng_cwnn" . bopomofo)
 707         ("ksc5601.1987" . hangul)
 708         ("ethiopic-unicode" . ethiopic)
 709         ("is13194-devanagari" . indian-is13194)
 710         ("iso10646.indian-1" . devanagari)))
 711
 712
 713 ;;;; Pasteboard support.
 714
 715 (define-obsolete-function-alias 'ns-store-cut-buffer-internal
 716   'gui-set-selection "24.1")
 717
 718
 719 (defun ns-copy-including-secondary ()
 720   (interactive)
 721   (call-interactively 'kill-ring-save)
 722   (gui-set-selection 'SECONDARY (buffer-substring (point) (mark t))))
 723
 724 (defun ns-paste-secondary ()
 725   (interactive)
 726   (insert (gui-get-selection 'SECONDARY)))
 727
 728
 729 ;;;; Scrollbar handling.
 730
 731 (global-set-key [vertical-scroll-bar down-mouse-1] 'scroll-bar-toolkit-scroll)
 732 (global-set-key [horizontal-scroll-bar down-mouse-1] 'scroll-bar-toolkit-horizontal-scroll)
 733 (global-unset-key [vertical-scroll-bar mouse-1])
 734 (global-unset-key [vertical-scroll-bar drag-mouse-1])
 735 (global-unset-key [horizontal-scroll-bar mouse-1])
 736 (global-unset-key [horizontal-scroll-bar drag-mouse-1])
 737
 738
 739 ;;;; macOS-like defaults for trackpad and mouse wheel scrolling on
 740 ;;;; macOS 10.7+.
 741
 742 ;; FIXME: This doesn't look right.  Is there a better way to do this
 743 ;; that keeps customize happy?
 744 (when (featurep 'cocoa)
 745   (let ((appkit-version
 746          (progn (string-match "^appkit-\\([^\s-]*\\)" ns-version-string)
 747                 (string-to-number (match-string 1 ns-version-string)))))
 748     ;; Appkit 1138 ~= macOS 10.7.
 749     (when (>= appkit-version 1138)
 750       (setq mouse-wheel-scroll-amount '(1 ((shift) . 5) ((control))))
 751       (put 'mouse-wheel-scroll-amount 'customized-value
 752            (list (custom-quote (symbol-value 'mouse-wheel-scroll-amount))))
 753
 754       (setq mouse-wheel-progressive-speed nil)
 755       (put 'mouse-wheel-progressive-speed 'customized-value
 756            (list (custom-quote
 757                   (symbol-value 'mouse-wheel-progressive-speed)))))))
 758
 759
 760 ;;;; Color support.
 761
 762 ;; Functions for color panel + drag
 763 (defun ns-face-at-pos (pos)
 764   (let* ((frame (car pos))
 765          (frame-pos (cons (cadr pos) (cddr pos)))
 766          (window (window-at (car frame-pos) (cdr frame-pos) frame))
 767          (window-pos (coordinates-in-window-p frame-pos window))
 768          (buffer (window-buffer window))
 769          (edges (window-edges window)))
 770     (cond
 771      ((not window-pos)
 772       nil)
 773      ((eq window-pos 'mode-line)
 774       'mode-line)
 775      ((eq window-pos 'vertical-line)
 776       'default)
 777      ((consp window-pos)
 778       (with-current-buffer buffer
 779         (let ((p (car (compute-motion (window-start window)
 780                                       (cons (nth 0 edges) (nth 1 edges))
 781                                       (window-end window)
 782                                       frame-pos
 783                                       (- (window-width window) 1)
 784                                       nil
 785                                       window))))
 786           (cond
 787            ((eq p (window-point window))
 788             'cursor)
 789            ((and mark-active (< (region-beginning) p) (< p (region-end)))
 790             'region)
 791            (t
 792             (let ((faces (get-char-property p 'face window)))
 793               (if (consp faces) (car faces) faces)))))))
 794      (t
 795       nil))))
 796
 797 (defun ns-suspend-error ()
 798   ;; Don't allow suspending if any of the frames are NS frames.
 799   (if (memq 'ns (mapcar 'window-system (frame-list)))
 800       (error "Cannot suspend Emacs while an NS GUI frame exists")))
 801
 802
 803 ;; Set some options to be as Nextstep-like as possible.
 804 (setq frame-title-format t
 805       icon-title-format t)
 806
 807
 808 (defvar ns-initialized nil
 809   "Non-nil if Nextstep windowing has been initialized.")
 810
 811 (declare-function x-handle-args "common-win" (args))
 812 (declare-function ns-list-services "nsfns.m" ())
 813 (declare-function x-open-connection "nsfns.m"
 814                   (display &optional xrm-string must-succeed))
 815 (declare-function ns-set-resource "nsfns.m" (owner name value))
 816
 817 ;; Do the actual Nextstep Windows setup here; the above code just
 818 ;; defines functions and variables that we use now.
 819 (cl-defmethod window-system-initialization (&context (window-system ns)
 820                                             &optional _display)
 821   "Initialize Emacs for Nextstep (Cocoa / GNUstep) windowing."
 822   (cl-assert (not ns-initialized))
 823
 824   ;; PENDING: not needed?
 825   (setq command-line-args (x-handle-args command-line-args))
 826
 827   ;; Setup the default fontset.
 828   (create-default-fontset)
 829   ;; Create the standard fontset.
 830   (condition-case err
 831       (create-fontset-from-fontset-spec ns-standard-fontset-spec t)
 832     (error (display-warning
 833             'initialization
 834             (format "Creation of the standard fontset failed: %s" err)
 835             :error)))
 836
 837   (x-open-connection (system-name) x-command-line-resources t)
 838
 839   ;; Add GNUstep menu items Services, Hide and Quit.  Rename Help to Info
 840   ;; and put it first (i.e. omit from menu-bar-final-items.
 841   (if (featurep 'gnustep)
 842       (progn
 843         (setq menu-bar-final-items '(buffer services hide-app quit))
 844
 845         ;; If running under GNUstep, "Help" is moved and renamed "Info".
 846         (bindings--define-key global-map [menu-bar help-menu]
 847           (cons "Info" menu-bar-help-menu))
 848         (bindings--define-key global-map [menu-bar quit]
 849           '(menu-item "Quit" save-buffers-kill-emacs
 850                       :help "Save unsaved buffers, then exit"))
 851         (bindings--define-key global-map [menu-bar hide-app]
 852           '(menu-item "Hide" ns-do-hide-emacs
 853                       :help "Hide Emacs"))
 854         (bindings--define-key global-map [menu-bar services]
 855           (cons "Services" (make-sparse-keymap "Services")))))
 856
 857
 858   (dolist (service (ns-list-services))
 859       (if (eq (car service) 'undefined)
 860           (ns-define-service (cdr service))
 861         (define-key global-map (vector (car service))
 862           (ns-define-service (cdr service)))))
 863
 864   (if (and (eq (get-lisp-resource nil "NXAutoLaunch") t)
 865            (eq (get-lisp-resource nil "HideOnAutoLaunch") t))
 866       (add-hook 'after-init-hook 'ns-do-hide-emacs))
 867
 868   ;; FIXME: This will surely lead to "MODIFIED OUTSIDE CUSTOM" warnings.
 869   (menu-bar-mode (if (get-lisp-resource nil "Menus") 1 -1))
 870
 871   ;; For Darwin nothing except UTF-8 makes sense.
 872   (when (eq system-type 'darwin)
 873       (add-hook 'before-init-hook
 874                 #'(lambda ()
 875                     (setq locale-coding-system 'utf-8-unix)
 876                     (setq default-process-coding-system
 877                           '(utf-8-unix . utf-8-unix)))))
 878
 879   ;; Mac OS X Lion introduces PressAndHold, which is unsupported by this port.
 880   ;; See this thread for more details:
 881   ;; https://lists.gnu.org/r/emacs-devel/2011-06/msg00505.html
 882   (ns-set-resource nil "ApplePressAndHoldEnabled" "NO")
 883
 884   (x-apply-session-resources)
 885
 886   ;; Don't let Emacs suspend under NS.
 887   (add-hook 'suspend-hook 'ns-suspend-error)
 888
 889   (setq ns-initialized t))
 890
 891 ;; Any display name is OK.
 892 (add-to-list 'display-format-alist '(".*" . ns))
 893 (cl-defmethod handle-args-function (args &context (window-system ns))
 894   (x-handle-args args))
 895
 896 (cl-defmethod frame-creation-function (params &context (window-system ns))
 897   (x-create-frame-with-faces params))
 898
 899 (declare-function ns-own-selection-internal "nsselect.m" (selection value))
 900 (declare-function ns-disown-selection-internal "nsselect.m" (selection))
 901 (declare-function ns-selection-owner-p "nsselect.m" (&optional selection))
 902 (declare-function ns-selection-exists-p "nsselect.m" (&optional selection))
 903 (declare-function ns-get-selection "nsselect.m" (selection-symbol target-type))
 904
 905 (cl-defmethod gui-backend-set-selection (selection value
 906                                          &context (window-system ns))
 907   (if value (ns-own-selection-internal selection value)
 908     (ns-disown-selection-internal selection)))
 909
 910 (cl-defmethod gui-backend-selection-owner-p (selection
 911                                              &context (window-system ns))
 912   (ns-selection-owner-p selection))
 913
 914 (cl-defmethod gui-backend-selection-exists-p (selection
 915                                               &context (window-system ns))
 916   (ns-selection-exists-p selection))
 917
 918 (cl-defmethod gui-backend-get-selection (selection-symbol target-type
 919                                          &context (window-system ns))
 920   (ns-get-selection selection-symbol target-type))
 921
 922 (provide 'ns-win)
 923 (provide 'term/ns-win)
 924
 925 ;;; ns-win.el ends here