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