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 (pop ns-input-file)))
 491          (file (find-file-noselect f))
 492          (bufwin1 (get-buffer-window file 'visible))
 493          (bufwin2 (get-buffer-window "*scratch*" 'visibile)))
 494     (cond
 495      (bufwin1
 496       (select-frame (window-frame bufwin1))
 497       (raise-frame (window-frame bufwin1))
 498       (select-window bufwin1))
 499      ((and (eq ns-pop-up-frames 'fresh) bufwin2)
 500       (ns-hide-emacs 'activate)
 501       (select-frame (window-frame bufwin2))
 502       (raise-frame (window-frame bufwin2))
 503       (select-window bufwin2)
 504       (find-file f))
 505      (ns-pop-up-frames
 506       (ns-hide-emacs 'activate)
 507       (let ((pop-up-frames t)) (pop-to-buffer file nil)))
 508      (t
 509       (ns-hide-emacs 'activate)
 510       (find-file f)))))
 511
 512 ;;;; Frame-related functions.
 513
 514 ;; Don't show the frame name; that's redundant with Nextstep.
 515 (setq-default mode-line-frame-identification '("  "))
 516
 517 ;; nsterm.m
 518 (defvar ns-alternate-modifier)
 519 (defvar ns-right-alternate-modifier)
 520 (defvar ns-right-command-modifier)
 521 (defvar ns-right-control-modifier)
 522
 523 ;; You say tomAYto, I say tomAHto..
 524 (defvaralias 'ns-option-modifier 'ns-alternate-modifier)
 525 (defvaralias 'ns-right-option-modifier 'ns-right-alternate-modifier)
 526
 527 (defun ns-do-hide-emacs ()
 528   (interactive)
 529   (ns-hide-emacs t))
 530
 531 (declare-function ns-hide-others "nsfns.m" ())
 532
 533 (defun ns-do-hide-others ()
 534   (interactive)
 535   (ns-hide-others))
 536
 537 (declare-function ns-emacs-info-panel "nsfns.m" ())
 538
 539 (defun ns-do-emacs-info-panel ()
 540   (interactive)
 541   (ns-emacs-info-panel))
 542
 543 (defun ns-next-frame ()
 544   "Switch to next visible frame."
 545   (interactive)
 546   (other-frame 1))
 547
 548 (defun ns-prev-frame ()
 549   "Switch to previous visible frame."
 550   (interactive)
 551   (other-frame -1))
 552
 553 ;; If no position specified, make new frame offset by 25 from current.
 554 (defvar parameters)                  ; dynamically bound in make-frame
 555 (add-hook 'before-make-frame-hook
 556           (lambda ()
 557             (let ((left (cdr (assq 'left (frame-parameters))))
 558                   (top (cdr (assq 'top (frame-parameters)))))
 559               (if (consp left) (setq left (cadr left)))
 560               (if (consp top) (setq top (cadr top)))
 561               (cond
 562                ((or (assq 'top parameters) (assq 'left parameters)))
 563                ((or (not left) (not top)))
 564                (t
 565                 (setq parameters (cons (cons 'left (+ left 25))
 566                                        (cons (cons 'top (+ top 25))
 567                                              parameters))))))))
 568
 569 ;; frame will be focused anyway, so select it
 570 ;; (if this is not done, modeline is dimmed until first interaction)
 571 (add-hook 'after-make-frame-functions 'select-frame)
 572
 573 (defvar tool-bar-mode)
 574 (declare-function tool-bar-mode "tool-bar" (&optional arg))
 575
 576 ;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
 577 ;; see http://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html .
 578 (defun ns-toggle-toolbar (&optional frame)
 579   "Switches the tool bar on and off in frame FRAME.
 580  If FRAME is nil, the change applies to the selected frame."
 581   (interactive)
 582   (modify-frame-parameters
 583    frame (list (cons 'tool-bar-lines
 584                        (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
 585                                    0 1)) ))
 586   (if (not tool-bar-mode) (tool-bar-mode t)))
 587
 588
 589 ;;;; Dialog-related functions.
 590
 591 ;; Ask user for confirm before printing.  Due to Kevin Rodgers.
 592 (defun ns-print-buffer ()
 593   "Interactive front-end to `print-buffer': asks for user confirmation first."
 594   (interactive)
 595   (if (and (called-interactively-p 'interactive)
 596            (or (listp last-nonmenu-event)
 597                (and (char-or-string-p (event-basic-type last-command-event))
 598                     (memq 'super (event-modifiers last-command-event)))))
 599       (let ((last-nonmenu-event (if (listp last-nonmenu-event)
 600                                     last-nonmenu-event
 601                                   ;; Fake it:
 602                                   `(mouse-1 POSITION 1))))
 603         (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
 604             (print-buffer)
 605           (error "Cancelled")))
 606     (print-buffer)))
 607
 608 ;;;; Font support.
 609
 610 ;; Needed for font listing functions under both backend and normal
 611 (setq scalable-fonts-allowed t)
 612
 613 ;; Set to use font panel instead
 614 (declare-function ns-popup-font-panel "nsfns.m" (&optional frame))
 615 (defalias 'x-select-font 'ns-popup-font-panel "Pop up the font panel.
 616 This function has been overloaded in Nextstep.")
 617 (defalias 'mouse-set-font 'ns-popup-font-panel "Pop up the font panel.
 618 This function has been overloaded in Nextstep.")
 619
 620 ;; nsterm.m
 621 (defvar ns-input-font)
 622 (defvar ns-input-fontsize)
 623
 624 (defun ns-respond-to-change-font ()
 625   "Respond to changeFont: event, expecting `ns-input-font' and\n\
 626 `ns-input-fontsize' of new font."
 627   (interactive)
 628   (modify-frame-parameters (selected-frame)
 629                            (list (cons 'font ns-input-font)
 630                                  (cons 'fontsize ns-input-fontsize)))
 631   (set-frame-font ns-input-font))
 632
 633
 634 ;; Default fontset for Mac OS X.  This is mainly here to show how a fontset
 635 ;; can be set up manually.  Ordinarily, fontsets are auto-created whenever
 636 ;; a font is chosen by
 637 (defvar ns-standard-fontset-spec
 638   ;; Only some code supports this so far, so use uglier XLFD version
 639   ;; "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
 640   (mapconcat 'identity
 641              '("-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard"
 642                "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1"
 643                "han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1"
 644                "cyrillic:-*-Trebuchet$MS-*-*-*-*-10-*-*-*-*-*-iso10646-1")
 645              ",")
 646   "String of fontset spec of the standard fontset.
 647 This defines a fontset consisting of the Courier and other fonts that
 648 come with OS X.
 649 See the documentation of `create-fontset-from-fontset-spec' for the format.")
 650
 651 ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles.
 652 (when (fboundp 'new-fontset)
 653   ;; Setup the default fontset.
 654   (create-default-fontset)
 655   ;; Create the standard fontset.
 656   (condition-case err
 657       (create-fontset-from-fontset-spec ns-standard-fontset-spec t)
 658     (error (display-warning
 659             'initialization
 660             (format "Creation of the standard fontset failed: %s" err)
 661             :error))))
 662
 663 (defvar ns-reg-to-script)               ; nsfont.m
 664
 665 ;; This maps font registries (not exposed by NS APIs for font selection) to
 666 ;; unicode scripts (which can be mapped to unicode character ranges which are).
 667 ;; See ../international/fontset.el
 668 (setq ns-reg-to-script
 669       '(("iso8859-1" . latin)
 670         ("iso8859-2" . latin)
 671         ("iso8859-3" . latin)
 672         ("iso8859-4" . latin)
 673         ("iso8859-5" . cyrillic)
 674         ("microsoft-cp1251" . cyrillic)
 675         ("koi8-r" . cyrillic)
 676         ("iso8859-6" . arabic)
 677         ("iso8859-7" . greek)
 678         ("iso8859-8" . hebrew)
 679         ("iso8859-9" . latin)
 680         ("iso8859-10" . latin)
 681         ("iso8859-11" . thai)
 682         ("tis620" . thai)
 683         ("iso8859-13" . latin)
 684         ("iso8859-14" . latin)
 685         ("iso8859-15" . latin)
 686         ("iso8859-16" . latin)
 687         ("viscii1.1-1" . latin)
 688         ("jisx0201" . kana)
 689         ("jisx0208" . han)
 690         ("jisx0212" . han)
 691         ("jisx0213" . han)
 692         ("gb2312.1980" . han)
 693         ("gb18030" . han)
 694         ("gbk-0" . han)
 695         ("big5" . han)
 696         ("cns11643" . han)
 697         ("sisheng_cwnn" . bopomofo)
 698         ("ksc5601.1987" . hangul)
 699         ("ethiopic-unicode" . ethiopic)
 700         ("is13194-devanagari" . indian-is13194)
 701         ("iso10646.indian-1" . devanagari)))
 702
 703
 704 ;;;; Pasteboard support.
 705
 706 (declare-function ns-get-cut-buffer-internal "nsselect.m" (buffer))
 707
 708 (defun ns-get-pasteboard ()
 709   "Returns the value of the pasteboard."
 710   (ns-get-cut-buffer-internal 'CLIPBOARD))
 711
 712 (declare-function ns-store-cut-buffer-internal "nsselect.m" (buffer string))
 713
 714 (defun ns-set-pasteboard (string)
 715   "Store STRING into the pasteboard of the Nextstep display server."
 716   ;; Check the data type of STRING.
 717   (if (not (stringp string)) (error "Nonstring given to pasteboard"))
 718   (ns-store-cut-buffer-internal 'CLIPBOARD string))
 719
 720 ;; We keep track of the last text selected here, so we can check the
 721 ;; current selection against it, and avoid passing back our own text
 722 ;; from x-selection-value.
 723 (defvar ns-last-selected-text nil)
 724
 725 ;; Return the value of the current Nextstep selection.  For
 726 ;; compatibility with older Nextstep applications, this checks cut
 727 ;; buffer 0 before retrieving the value of the primary selection.
 728 (defun x-selection-value ()
 729   (let (text)
 730     ;; Consult the selection.  Treat empty strings as if they were unset.
 731     (or text (setq text (ns-get-pasteboard)))
 732     (if (string= text "") (setq text nil))
 733     (cond
 734      ((not text) nil)
 735      ((eq text ns-last-selected-text) nil)
 736      ((string= text ns-last-selected-text)
 737       ;; Record the newer string, so subsequent calls can use the `eq' test.
 738       (setq ns-last-selected-text text)
 739       nil)
 740      (t
 741       (setq ns-last-selected-text text)))))
 742
 743 (defun ns-copy-including-secondary ()
 744   (interactive)
 745   (call-interactively 'kill-ring-save)
 746   (ns-store-cut-buffer-internal 'SECONDARY
 747                                 (buffer-substring (point) (mark t))))
 748 (defun ns-paste-secondary ()
 749   (interactive)
 750   (insert (ns-get-cut-buffer-internal 'SECONDARY)))
 751
 752
 753 ;;;; Scrollbar handling.
 754
 755 (global-set-key [vertical-scroll-bar down-mouse-1] 'ns-handle-scroll-bar-event)
 756 (global-unset-key [vertical-scroll-bar mouse-1])
 757 (global-unset-key [vertical-scroll-bar drag-mouse-1])
 758
 759 (declare-function scroll-bar-scale "scroll-bar" (num-denom whole))
 760
 761 (defun ns-scroll-bar-move (event)
 762   "Scroll the frame according to a Nextstep scroller event."
 763   (interactive "e")
 764   (let* ((pos (event-end event))
 765          (window (nth 0 pos))
 766          (scale (nth 2 pos)))
 767     (with-current-buffer (window-buffer window)
 768       (cond
 769        ((eq (car scale) (cdr scale))
 770         (goto-char (point-max)))
 771        ((= (car scale) 0)
 772         (goto-char (point-min)))
 773        (t
 774         (goto-char (+ (point-min) 1
 775                       (scroll-bar-scale scale (- (point-max) (point-min)))))))
 776       (beginning-of-line)
 777       (set-window-start window (point))
 778       (vertical-motion (/ (window-height window) 2) window))))
 779
 780 (defun ns-handle-scroll-bar-event (event)
 781   "Handle scroll bar EVENT to emulate Nextstep style scrolling."
 782   (interactive "e")
 783   (let* ((position (event-start event))
 784          (bar-part (nth 4 position))
 785          (window (nth 0 position))
 786          (old-window (selected-window)))
 787     (cond
 788      ((eq bar-part 'ratio)
 789       (ns-scroll-bar-move event))
 790      ((eq bar-part 'handle)
 791       (if (eq window (selected-window))
 792           (track-mouse (ns-scroll-bar-move event))
 793         ;; track-mouse faster for selected window, slower for unselected.
 794         (ns-scroll-bar-move event)))
 795      (t
 796       (select-window window)
 797       (cond
 798        ((eq bar-part 'up)
 799         (goto-char (window-start window))
 800         (scroll-down 1))
 801        ((eq bar-part 'above-handle)
 802         (scroll-down))
 803        ((eq bar-part 'below-handle)
 804         (scroll-up))
 805        ((eq bar-part 'down)
 806         (goto-char (window-start window))
 807         (scroll-up 1)))
 808       (select-window old-window)))))
 809
 810
 811 ;;;; Color support.
 812
 813 ;; Functions for color panel + drag
 814 (defun ns-face-at-pos (pos)
 815   (let* ((frame (car pos))
 816          (frame-pos (cons (cadr pos) (cddr pos)))
 817          (window (window-at (car frame-pos) (cdr frame-pos) frame))
 818          (window-pos (coordinates-in-window-p frame-pos window))
 819          (buffer (window-buffer window))
 820          (edges (window-edges window)))
 821     (cond
 822      ((not window-pos)
 823       nil)
 824      ((eq window-pos 'mode-line)
 825       'modeline)
 826      ((eq window-pos 'vertical-line)
 827       'default)
 828      ((consp window-pos)
 829       (with-current-buffer buffer
 830         (let ((p (car (compute-motion (window-start window)
 831                                       (cons (nth 0 edges) (nth 1 edges))
 832                                       (window-end window)
 833                                       frame-pos
 834                                       (- (window-width window) 1)
 835                                       nil
 836                                       window))))
 837           (cond
 838            ((eq p (window-point window))
 839             'cursor)
 840            ((and mark-active (< (region-beginning) p) (< p (region-end)))
 841             'region)
 842            (t
 843             (let ((faces (get-char-property p 'face window)))
 844               (if (consp faces) (car faces) faces)))))))
 845      (t
 846       nil))))
 847
 848 (defvar ns-input-color)                 ; nsterm.m
 849
 850 (defun ns-set-foreground-at-mouse ()
 851   "Set the foreground color at the mouse location to `ns-input-color'."
 852   (interactive)
 853   (let* ((pos (mouse-position))
 854          (frame (car pos))
 855          (face (ns-face-at-pos pos)))
 856     (cond
 857      ((eq face 'cursor)
 858       (modify-frame-parameters frame (list (cons 'cursor-color
 859                                                  ns-input-color))))
 860      ((not face)
 861       (modify-frame-parameters frame (list (cons 'foreground-color
 862                                                  ns-input-color))))
 863      (t
 864       (set-face-foreground face ns-input-color frame)))))
 865
 866 (defun ns-set-background-at-mouse ()
 867   "Set the background color at the mouse location to `ns-input-color'."
 868   (interactive)
 869   (let* ((pos (mouse-position))
 870          (frame (car pos))
 871          (face (ns-face-at-pos pos)))
 872     (cond
 873      ((eq face 'cursor)
 874       (modify-frame-parameters frame (list (cons 'cursor-color
 875                                                  ns-input-color))))
 876      ((not face)
 877       (modify-frame-parameters frame (list (cons 'background-color
 878                                                  ns-input-color))))
 879      (t
 880       (set-face-background face ns-input-color frame)))))
 881
 882 ;; Set some options to be as Nextstep-like as possible.
 883 (setq frame-title-format t
 884       icon-title-format t)
 885
 886
 887 (defvar ns-initialized nil
 888   "Non-nil if Nextstep windowing has been initialized.")
 889
 890 (declare-function ns-list-services "nsfns.m" ())
 891 (declare-function x-open-connection "nsfns.m"
 892                   (display &optional xrm-string must-succeed))
 893
 894 ;; Do the actual Nextstep Windows setup here; the above code just
 895 ;; defines functions and variables that we use now.
 896 (defun ns-initialize-window-system ()
 897   "Initialize Emacs for Nextstep (Cocoa / GNUstep) windowing."
 898
 899   ;; PENDING: not needed?
 900   (setq command-line-args (x-handle-args command-line-args))
 901
 902   (x-open-connection (system-name) nil t)
 903
 904   (dolist (service (ns-list-services))
 905       (if (eq (car service) 'undefined)
 906           (ns-define-service (cdr service))
 907         (define-key global-map (vector (car service))
 908           (ns-define-service (cdr service)))))
 909
 910   (if (and (eq (get-lisp-resource nil "NXAutoLaunch") t)
 911            (eq (get-lisp-resource nil "HideOnAutoLaunch") t))
 912       (add-hook 'after-init-hook 'ns-do-hide-emacs))
 913
 914   ;; FIXME: This will surely lead to "MODIFIED OUTSIDE CUSTOM" warnings.
 915   (menu-bar-mode (if (get-lisp-resource nil "Menus") 1 -1))
 916
 917   (setq ns-initialized t))
 918
 919 (add-to-list 'handle-args-function-alist '(ns . x-handle-args))
 920 (add-to-list 'frame-creation-function-alist '(ns . x-create-frame-with-faces))
 921 (add-to-list 'window-system-initialization-alist '(ns . ns-initialize-window-system))
 922
 923
 924 (provide 'ns-win)
 925
 926 ;;; ns-win.el ends here