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