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