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