lisp/term/ns-win.el

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