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