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