code.delx.au - gnu-emacs/blob - lisp/term/ns-win.el

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