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
  45 (if (not (featurep 'ns))
  46     (error "%s: Loading ns-win.el but not compiled for GNUstep/MacOS"
  47            (invocation-name)))
  48
  49 (eval-when-compile (require 'cl))
  50
  51 ;; Documentation-purposes only: actually loaded in loadup.el
  52 (require 'frame)
  53 (require 'mouse)
  54 (require 'faces)
  55 (require 'easymenu)
  56 (require 'menu-bar)
  57 (require 'fontset)
  58
  59 ;; Not needed?
  60 ;;(require 'ispell)
  61
  62 (defgroup ns nil
  63   "GNUstep/Mac OS X specific features."
  64   :group 'environment)
  65
  66 ;; nsterm.m
  67 (defvar ns-version-string)
  68 (defvar ns-alternate-modifier)
  69 (defvar ns-right-alternate-modifier)
  70
  71 ;;;; Command line argument handling.
  72
  73 (defvar ns-invocation-args nil)
  74 (defvar ns-command-line-resources nil)
  75
  76 ;; Handler for switches of the form "-switch value" or "-switch".
  77 (defun ns-handle-switch (switch &optional numeric)
  78   (let ((aelt (assoc switch command-line-ns-option-alist)))
  79     (if aelt
  80         (setq default-frame-alist
  81               (cons (cons (nth 3 aelt)
  82                           (if numeric
  83                               (string-to-number (pop ns-invocation-args))
  84                             (or (nth 4 aelt) (pop ns-invocation-args))))
  85                     default-frame-alist)))))
  86
  87 ;; Handler for switches of the form "-switch n"
  88 (defun ns-handle-numeric-switch (switch)
  89   (ns-handle-switch switch t))
  90
  91 ;; Make -iconic apply only to the initial frame!
  92 (defun ns-handle-iconic (switch)
  93   (setq initial-frame-alist
  94         (cons '(visibility . icon) initial-frame-alist)))
  95
  96 ;; Handle the -name option, set the name of the initial frame.
  97 (defun ns-handle-name-switch (switch)
  98   (or (consp ns-invocation-args)
  99       (error "%s: missing argument to `%s' option" (invocation-name) switch))
 100   (setq initial-frame-alist (cons (cons 'name (pop ns-invocation-args))
 101                                   initial-frame-alist)))
 102
 103 ;; Set (but not used?) in frame.el.
 104 (defvar x-display-name nil
 105   "The name of the window display on which Emacs was started.
 106 On X, the display name of individual X frames is recorded in the
 107 `display' frame parameter.")
 108
 109 ;; nsterm.m.
 110 (defvar ns-input-file)
 111
 112 (defun ns-handle-nxopen (switch)
 113   (setq unread-command-events (append unread-command-events '(ns-open-file))
 114         ns-input-file (append ns-input-file (list (pop ns-invocation-args)))))
 115
 116 (defun ns-handle-nxopentemp (switch)
 117   (setq unread-command-events (append unread-command-events
 118                                       '(ns-open-temp-file))
 119         ns-input-file (append ns-input-file (list (pop ns-invocation-args)))))
 120
 121 (defun ns-ignore-1-arg (switch)
 122   (setq ns-invocation-args (cdr ns-invocation-args)))
 123 (defun ns-ignore-2-arg (switch)
 124   (setq ns-invocation-args (cddr ns-invocation-args)))
 125
 126 (defun ns-handle-args (args)
 127   "Process Nextstep-related command line options.
 128 This is run before the user's startup file is loaded.
 129 The options in ARGS are copied to `ns-invocation-args'.
 130 The Nextstep-related settings are then applied using the handlers
 131 defined in `command-line-ns-option-alist'.
 132 The return value is ARGS minus the number of arguments processed."
 133   ;; We use ARGS to accumulate the args that we don't handle here, to return.
 134   (setq ns-invocation-args args
 135         args nil)
 136   (while ns-invocation-args
 137     (let* ((this-switch (pop ns-invocation-args))
 138            (orig-this-switch this-switch)
 139            completion argval aelt handler)
 140       ;; Check for long options with attached arguments
 141       ;; and separate out the attached option argument into argval.
 142       (if (string-match "^--[^=]*=" this-switch)
 143           (setq argval (substring this-switch (match-end 0))
 144                 this-switch (substring this-switch 0 (1- (match-end 0)))))
 145       ;; Complete names of long options.
 146       (if (string-match "^--" this-switch)
 147           (progn
 148             (setq completion (try-completion this-switch
 149                                              command-line-ns-option-alist))
 150             (if (eq completion t)
 151                 ;; Exact match for long option.
 152                 nil
 153               (if (stringp completion)
 154                   (let ((elt (assoc completion command-line-ns-option-alist)))
 155                     ;; Check for abbreviated long option.
 156                     (or elt
 157                         (error "Option `%s' is ambiguous" this-switch))
 158                     (setq this-switch completion))))))
 159       (setq aelt (assoc this-switch command-line-ns-option-alist))
 160       (if aelt (setq handler (nth 2 aelt)))
 161       (if handler
 162           (if argval
 163               (let ((ns-invocation-args
 164                      (cons argval ns-invocation-args)))
 165                 (funcall handler this-switch))
 166             (funcall handler this-switch))
 167         (setq args (cons orig-this-switch args)))))
 168   (nreverse args))
 169
 170 (defun ns-parse-geometry (geom)
 171   "Parse a Nextstep-style geometry string GEOM.
 172 Returns an alist of the form ((top . TOP), (left . LEFT) ... ).
 173 The properties returned may include `top', `left', `height', and `width'."
 174   (when (string-match "\\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\)\
 175 \\( \\([0-9]+\\) ?\\)?\\)?\\)?"
 176                       geom)
 177     (apply
 178      'append
 179      (list
 180       (list (cons 'top (string-to-number (match-string 1 geom))))
 181       (if (match-string 3 geom)
 182           (list (cons 'left (string-to-number (match-string 3 geom)))))
 183       (if (match-string 5 geom)
 184           (list (cons 'height (string-to-number (match-string 5 geom)))))
 185       (if (match-string 7 geom)
 186           (list (cons 'width (string-to-number (match-string 7 geom)))))))))
 187
 188 ;;;; Keyboard mapping.
 189
 190 ;; These tell read-char how to convert these special chars to ASCII.
 191 (put 'S-tab 'ascii-character (logior 16 ?\t))
 192
 193 (defvar ns-alternatives-map
 194   (let ((map (make-sparse-keymap)))
 195     ;; Map certain keypad keys into ASCII characters
 196     ;; that people usually expect.
 197     (define-key map [S-tab] [25])
 198     (define-key map [M-backspace] [?\M-\d])
 199     (define-key map [M-delete] [?\M-\d])
 200     (define-key map [M-tab] [?\M-\t])
 201     (define-key map [M-linefeed] [?\M-\n])
 202     (define-key map [M-clear] [?\M-\C-l])
 203     (define-key map [M-return] [?\M-\C-m])
 204     (define-key map [M-escape] [?\M-\e])
 205     map)
 206   "Keymap of alternative meanings for some keys under Nextstep.")
 207
 208 ;; Here are some Nextstep-like bindings for command key sequences.
 209 (define-key global-map [?\s-,] 'customize)
 210 (define-key global-map [?\s-'] 'next-multiframe-window)
 211 (define-key global-map [?\s-`] 'other-frame)
 212 (define-key global-map [?\s--] 'center-line)
 213 (define-key global-map [?\s-:] 'ispell)
 214 (define-key global-map [?\s-\;] 'ispell-next)
 215 (define-key global-map [?\s-?] 'info)
 216 (define-key global-map [?\s-^] 'kill-some-buffers)
 217 (define-key global-map [?\s-&] 'kill-this-buffer)
 218 (define-key global-map [?\s-C] 'ns-popup-color-panel)
 219 (define-key global-map [?\s-D] 'dired)
 220 (define-key global-map [?\s-E] 'edit-abbrevs)
 221 (define-key global-map [?\s-L] 'shell-command)
 222 (define-key global-map [?\s-M] 'manual-entry)
 223 (define-key global-map [?\s-S] 'ns-write-file-using-panel)
 224 (define-key global-map [?\s-a] 'mark-whole-buffer)
 225 (define-key global-map [?\s-c] 'ns-copy-including-secondary)
 226 (define-key global-map [?\s-d] 'isearch-repeat-backward)
 227 (define-key global-map [?\s-e] 'isearch-yank-kill)
 228 (define-key global-map [?\s-f] 'isearch-forward)
 229 (define-key global-map [?\s-g] 'isearch-repeat-forward)
 230 (define-key global-map [?\s-h] 'ns-do-hide-emacs)
 231 (define-key global-map [?\s-H] 'ns-do-hide-others)
 232 (define-key global-map [?\s-j] 'exchange-point-and-mark)
 233 (define-key global-map [?\s-k] 'kill-this-buffer)
 234 (define-key global-map [?\s-l] 'goto-line)
 235 (define-key global-map [?\s-m] 'iconify-frame)
 236 (define-key global-map [?\s-n] 'make-frame)
 237 (define-key global-map [?\s-o] 'ns-open-file-using-panel)
 238 (define-key global-map [?\s-p] 'ns-print-buffer)
 239 (define-key global-map [?\s-q] 'save-buffers-kill-emacs)
 240 (define-key global-map [?\s-s] 'save-buffer)
 241 (define-key global-map [?\s-t] 'ns-popup-font-panel)
 242 (define-key global-map [?\s-u] 'revert-buffer)
 243 (define-key global-map [?\s-v] 'yank)
 244 (define-key global-map [?\s-w] 'delete-frame)
 245 (define-key global-map [?\s-x] 'kill-region)
 246 (define-key global-map [?\s-y] 'ns-paste-secondary)
 247 (define-key global-map [?\s-z] 'undo)
 248 (define-key global-map [?\s-|] 'shell-command-on-region)
 249 (define-key global-map [s-kp-bar] 'shell-command-on-region)
 250 ;; (as in Terminal.app)
 251 (define-key global-map [s-right] 'ns-next-frame)
 252 (define-key global-map [s-left] 'ns-prev-frame)
 253
 254 (define-key global-map [home] 'beginning-of-buffer)
 255 (define-key global-map [end] 'end-of-buffer)
 256 (define-key global-map [kp-home] 'beginning-of-buffer)
 257 (define-key global-map [kp-end] 'end-of-buffer)
 258 (define-key global-map [kp-prior] 'scroll-down)
 259 (define-key global-map [kp-next] 'scroll-up)
 260
 261 ;;; Allow shift-clicks to work similarly to under Nextstep
 262 (define-key global-map [S-mouse-1] 'mouse-save-then-kill)
 263 (global-unset-key [S-down-mouse-1])
 264
 265
 266 ;; Special Nextstep-generated events are converted to function keys.  Here
 267 ;; are the bindings for them.
 268 (define-key global-map [ns-power-off] 'save-buffers-kill-emacs)
 269 (define-key global-map [ns-open-file] 'ns-find-file)
 270 (define-key global-map [ns-open-temp-file] [ns-open-file])
 271 (define-key global-map [ns-drag-file] 'ns-insert-file)
 272 (define-key global-map [ns-drag-color] 'ns-set-foreground-at-mouse)
 273 (define-key global-map [S-ns-drag-color] 'ns-set-background-at-mouse)
 274 (define-key global-map [ns-drag-text] 'ns-insert-text)
 275 (define-key global-map [ns-change-font] 'ns-respond-to-change-font)
 276 (define-key global-map [ns-open-file-line] 'ns-open-file-select-line)
 277 (define-key global-map [ns-spi-service-call] 'ns-spi-service-call)
 278 (define-key global-map [ns-new-frame] 'make-frame)
 279 (define-key global-map [ns-toggle-toolbar] 'ns-toggle-toolbar)
 280 (define-key global-map [ns-show-prefs] 'customize)
 281
 282
 283 ;; Set up a number of aliases and other layers to pretend we're using
 284 ;; the Choi/Mitsuharu Carbon port.
 285
 286 (defvaralias 'mac-allow-anti-aliasing 'ns-antialias-text)
 287 (defvaralias 'mac-command-modifier 'ns-command-modifier)
 288 (defvaralias 'mac-control-modifier 'ns-control-modifier)
 289 (defvaralias 'mac-option-modifier 'ns-option-modifier)
 290 (defvaralias 'mac-right-option-modifier 'ns-right-option-modifier)
 291 (defvaralias 'mac-function-modifier 'ns-function-modifier)
 292 (declare-function ns-do-applescript "nsfns.m" (script))
 293 (defalias 'do-applescript 'ns-do-applescript)
 294
 295 (defun x-setup-function-keys (frame)
 296   "Set up `function-key-map' on the graphical frame FRAME."
 297   (unless (terminal-parameter frame 'x-setup-function-keys)
 298     (with-selected-frame frame
 299       (setq interprogram-cut-function 'x-select-text
 300             interprogram-paste-function 'x-cut-buffer-or-selection-value)
 301       (let ((map (copy-keymap ns-alternatives-map)))
 302         (set-keymap-parent map (keymap-parent local-function-key-map))
 303         (set-keymap-parent local-function-key-map map))
 304       (setq system-key-alist
 305             (list
 306              (cons (logior (lsh 0 16)   1) 'ns-power-off)
 307              (cons (logior (lsh 0 16)   2) 'ns-open-file)
 308              (cons (logior (lsh 0 16)   3) 'ns-open-temp-file)
 309              (cons (logior (lsh 0 16)   4) 'ns-drag-file)
 310              (cons (logior (lsh 0 16)   5) 'ns-drag-color)
 311              (cons (logior (lsh 0 16)   6) 'ns-drag-text)
 312              (cons (logior (lsh 0 16)   7) 'ns-change-font)
 313              (cons (logior (lsh 0 16)   8) 'ns-open-file-line)
 314 ;             (cons (logior (lsh 0 16)   9) 'ns-insert-working-text)
 315 ;             (cons (logior (lsh 0 16)  10) 'ns-delete-working-text)
 316              (cons (logior (lsh 0 16)  11) 'ns-spi-service-call)
 317              (cons (logior (lsh 0 16)  12) 'ns-new-frame)
 318              (cons (logior (lsh 0 16)  13) 'ns-toggle-toolbar)
 319              (cons (logior (lsh 0 16)  14) 'ns-show-prefs)
 320              (cons (logior (lsh 1 16)  32) 'f1)
 321              (cons (logior (lsh 1 16)  33) 'f2)
 322              (cons (logior (lsh 1 16)  34) 'f3)
 323              (cons (logior (lsh 1 16)  35) 'f4)
 324              (cons (logior (lsh 1 16)  36) 'f5)
 325              (cons (logior (lsh 1 16)  37) 'f6)
 326              (cons (logior (lsh 1 16)  38) 'f7)
 327              (cons (logior (lsh 1 16)  39) 'f8)
 328              (cons (logior (lsh 1 16)  40) 'f9)
 329              (cons (logior (lsh 1 16)  41) 'f10)
 330              (cons (logior (lsh 1 16)  42) 'f11)
 331              (cons (logior (lsh 1 16)  43) 'f12)
 332              (cons (logior (lsh 1 16)  44) 'kp-insert)
 333              (cons (logior (lsh 1 16)  45) 'kp-delete)
 334              (cons (logior (lsh 1 16)  46) 'kp-home)
 335              (cons (logior (lsh 1 16)  47) 'kp-end)
 336              (cons (logior (lsh 1 16)  48) 'kp-prior)
 337              (cons (logior (lsh 1 16)  49) 'kp-next)
 338              (cons (logior (lsh 1 16)  50) 'print-screen)
 339              (cons (logior (lsh 1 16)  51) 'scroll-lock)
 340              (cons (logior (lsh 1 16)  52) 'pause)
 341              (cons (logior (lsh 1 16)  53) 'system)
 342              (cons (logior (lsh 1 16)  54) 'break)
 343              (cons (logior (lsh 1 16)  56) 'please-tell-carl-what-this-key-is-called-56)
 344              (cons (logior (lsh 1 16)  61) 'please-tell-carl-what-this-key-is-called-61)
 345              (cons (logior (lsh 1 16)  62) 'please-tell-carl-what-this-key-is-called-62)
 346              (cons (logior (lsh 1 16)  63) 'please-tell-carl-what-this-key-is-called-63)
 347              (cons (logior (lsh 1 16)  64) 'please-tell-carl-what-this-key-is-called-64)
 348              (cons (logior (lsh 1 16)  69) 'please-tell-carl-what-this-key-is-called-69)
 349              (cons (logior (lsh 1 16)  70) 'please-tell-carl-what-this-key-is-called-70)
 350              (cons (logior (lsh 1 16)  71) 'please-tell-carl-what-this-key-is-called-71)
 351              (cons (logior (lsh 1 16)  72) 'please-tell-carl-what-this-key-is-called-72)
 352              (cons (logior (lsh 1 16)  73) 'please-tell-carl-what-this-key-is-called-73)
 353              (cons (logior (lsh 2 16)   3) 'kp-enter)
 354              (cons (logior (lsh 2 16)   9) 'kp-tab)
 355              (cons (logior (lsh 2 16)  28) 'kp-quit)
 356              (cons (logior (lsh 2 16)  35) 'kp-hash)
 357              (cons (logior (lsh 2 16)  42) 'kp-multiply)
 358              (cons (logior (lsh 2 16)  43) 'kp-add)
 359              (cons (logior (lsh 2 16)  44) 'kp-separator)
 360              (cons (logior (lsh 2 16)  45) 'kp-subtract)
 361              (cons (logior (lsh 2 16)  46) 'kp-decimal)
 362              (cons (logior (lsh 2 16)  47) 'kp-divide)
 363              (cons (logior (lsh 2 16)  48) 'kp-0)
 364              (cons (logior (lsh 2 16)  49) 'kp-1)
 365              (cons (logior (lsh 2 16)  50) 'kp-2)
 366              (cons (logior (lsh 2 16)  51) 'kp-3)
 367              (cons (logior (lsh 2 16)  52) 'kp-4)
 368              (cons (logior (lsh 2 16)  53) 'kp-5)
 369              (cons (logior (lsh 2 16)  54) 'kp-6)
 370              (cons (logior (lsh 2 16)  55) 'kp-7)
 371              (cons (logior (lsh 2 16)  56) 'kp-8)
 372              (cons (logior (lsh 2 16)  57) 'kp-9)
 373              (cons (logior (lsh 2 16)  60) 'kp-less)
 374              (cons (logior (lsh 2 16)  61) 'kp-equal)
 375              (cons (logior (lsh 2 16)  62) 'kp-more)
 376              (cons (logior (lsh 2 16)  64) 'kp-at)
 377              (cons (logior (lsh 2 16)  92) 'kp-backslash)
 378              (cons (logior (lsh 2 16)  96) 'kp-backtick)
 379              (cons (logior (lsh 2 16) 124) 'kp-bar)
 380              (cons (logior (lsh 2 16) 126) 'kp-tilde)
 381              (cons (logior (lsh 2 16) 157) 'kp-mu)
 382              (cons (logior (lsh 2 16) 165) 'kp-yen)
 383              (cons (logior (lsh 2 16) 167) 'kp-paragraph)
 384              (cons (logior (lsh 2 16) 172) 'left)
 385              (cons (logior (lsh 2 16) 173) 'up)
 386              (cons (logior (lsh 2 16) 174) 'right)
 387              (cons (logior (lsh 2 16) 175) 'down)
 388              (cons (logior (lsh 2 16) 176) 'kp-ring)
 389              (cons (logior (lsh 2 16) 201) 'kp-square)
 390              (cons (logior (lsh 2 16) 204) 'kp-cube)
 391              (cons (logior (lsh 3 16)   8) 'backspace)
 392              (cons (logior (lsh 3 16)   9) 'tab)
 393              (cons (logior (lsh 3 16)  10) 'linefeed)
 394              (cons (logior (lsh 3 16)  11) 'clear)
 395              (cons (logior (lsh 3 16)  13) 'return)
 396              (cons (logior (lsh 3 16)  18) 'pause)
 397              (cons (logior (lsh 3 16)  25) 'S-tab)
 398              (cons (logior (lsh 3 16)  27) 'escape)
 399              (cons (logior (lsh 3 16) 127) 'delete)
 400              )))
 401     (set-terminal-parameter frame 'x-setup-function-keys t)))
 402
 403
 404 ;; Add a couple of menus and rearrange some others; easiest just to redo toplvl
 405 ;; Note keymap defns must be given last-to-first
 406 (define-key global-map [menu-bar] (make-sparse-keymap "menu-bar"))
 407
 408 (setq menu-bar-final-items
 409       (cond ((eq system-type 'darwin)
 410              '(buffer windows services help-menu))
 411             ;; Otherwise, GNUstep.
 412             (t
 413              '(buffer windows services hide-app quit))))
 414
 415 ;; Add standard top-level items to GNUstep menu.
 416 (unless (eq system-type 'darwin)
 417   (define-key global-map [menu-bar quit] '("Quit" . save-buffers-kill-emacs))
 418   (define-key global-map [menu-bar hide-app] '("Hide" . ns-do-hide-emacs)))
 419
 420 (define-key global-map [menu-bar services]
 421   (cons "Services" (make-sparse-keymap "Services")))
 422 (define-key global-map [menu-bar buffer]
 423   (cons "Buffers" global-buffers-menu-map))
 424 ;;  (cons "Buffers" (make-sparse-keymap "Buffers")))
 425 (define-key global-map [menu-bar tools] (cons "Tools" menu-bar-tools-menu))
 426 (define-key global-map [menu-bar options] (cons "Options" menu-bar-options-menu))
 427 (define-key global-map [menu-bar edit] (cons "Edit" menu-bar-edit-menu))
 428 (define-key global-map [menu-bar file] (cons "File" menu-bar-file-menu))
 429
 430 ;; If running under GNUstep, rename "Help" to "Info"
 431 (cond ((eq system-type 'darwin)
 432        (define-key global-map [menu-bar help-menu]
 433          (cons "Help" menu-bar-help-menu)))
 434       (t
 435        (let ((contents (reverse (cdr menu-bar-help-menu))))
 436          (setq menu-bar-help-menu
 437                (append (list 'keymap) (cdr contents) (list "Info"))))
 438        (define-key global-map [menu-bar help-menu]
 439          (cons "Info" menu-bar-help-menu))))
 440
 441 (if (not (eq system-type 'darwin))
 442     ;; in OS X it's in the app menu already
 443     (define-key menu-bar-help-menu [info-panel]
 444       '("About Emacs..." . ns-do-emacs-info-panel)))
 445
 446 ;;;; Edit menu: Modify slightly
 447
 448 ;; Substitute a Copy function that works better under X (for GNUstep).
 449 (easy-menu-remove-item global-map '("menu-bar" "edit") 'copy)
 450 (define-key-after menu-bar-edit-menu [copy]
 451   '(menu-item "Copy" ns-copy-including-secondary
 452     :enable mark-active
 453     :help "Copy text in region between mark and current position")
 454   'cut)
 455
 456 ;; Change to same precondition as select-and-paste, as we don't have
 457 ;; `x-selection-exists-p'.
 458 (easy-menu-remove-item global-map '("menu-bar" "edit") 'paste)
 459 (define-key-after menu-bar-edit-menu [paste]
 460   '(menu-item "Paste" yank
 461     :enable (and (cdr yank-menu) (not buffer-read-only))
 462     :help "Paste (yank) text most recently cut/copied")
 463   'copy)
 464
 465 ;; Change text to be more consistent with surrounding menu items `paste', etc.
 466 (easy-menu-remove-item global-map '("menu-bar" "edit") 'paste-from-menu)
 467 (define-key-after menu-bar-edit-menu [select-paste]
 468   '(menu-item "Select and Paste" yank-menu
 469     :enable (and (cdr yank-menu) (not buffer-read-only))
 470     :help "Choose a string from the kill ring and paste it")
 471   'paste)
 472
 473 ;; Separate undo from cut/paste section, add spell for platform consistency.
 474 (define-key-after menu-bar-edit-menu [separator-undo] '("--") 'undo)
 475 (define-key-after menu-bar-edit-menu [spell] '("Spell" . ispell-menu-map) 'fill)
 476
 477
 478 ;;;; Services
 479 (declare-function ns-perform-service "nsfns.m" (service send))
 480
 481 (defun ns-define-service (path)
 482   (let ((mapping [menu-bar services])
 483         (service (mapconcat 'identity path "/"))
 484         (name (intern
 485                (subst-char-in-string
 486                 ?\s ?-
 487                 (mapconcat 'identity (cons "ns-service" path) "-")))))
 488     ;; This defines the function.
 489     (defalias name
 490       (lexical-let ((service service))
 491         (lambda (arg)
 492           (interactive "p")
 493           (let* ((in-string
 494                   (cond ((stringp arg) arg)
 495                         (mark-active
 496                          (buffer-substring (region-beginning) (region-end)))))
 497                  (out-string (ns-perform-service service in-string)))
 498             (cond
 499              ((stringp arg) out-string)
 500              ((and out-string (or (not in-string)
 501                                   (not (string= in-string out-string))))
 502               (if mark-active (delete-region (region-beginning) (region-end)))
 503               (insert out-string)
 504               (setq deactivate-mark nil)))))))
 505     (cond
 506      ((lookup-key global-map mapping)
 507       (while (cdr path)
 508         (setq mapping (vconcat mapping (list (intern (car path)))))
 509         (if (not (keymapp (lookup-key global-map mapping)))
 510             (define-key global-map mapping
 511               (cons (car path) (make-sparse-keymap (car path)))))
 512         (setq path (cdr path)))
 513       (setq mapping (vconcat mapping (list (intern (car path)))))
 514       (define-key global-map mapping (cons (car path) name))))
 515     name))
 516
 517 ;; nsterm.m
 518 (defvar ns-input-spi-name)
 519 (defvar ns-input-spi-arg)
 520
 521 (declare-function dnd-open-file "dnd" (uri action))
 522
 523 (defun ns-spi-service-call ()
 524   "Respond to a service request."
 525   (interactive)
 526   (cond ((string-equal ns-input-spi-name "open-selection")
 527          (switch-to-buffer (generate-new-buffer "*untitled*"))
 528          (insert ns-input-spi-arg))
 529         ((string-equal ns-input-spi-name "open-file")
 530          (dnd-open-file ns-input-spi-arg nil))
 531         ((string-equal ns-input-spi-name "mail-selection")
 532          (compose-mail)
 533          (rfc822-goto-eoh)
 534          (forward-line 1)
 535          (insert ns-input-spi-arg))
 536         ((string-equal ns-input-spi-name "mail-to")
 537          (compose-mail ns-input-spi-arg))
 538         (t (error (concat "Service " ns-input-spi-name " not recognized")))))
 539
 540
 541 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 542
 543
 544
 545 ;; Composed key sequence handling for Nextstep system input methods.
 546 ;; (On Nextstep systems, input methods are provided for CJK
 547 ;; characters, etc. which require multiple keystrokes, and during
 548 ;; entry a partial ("working") result is typically shown in the
 549 ;; editing window.)
 550
 551 (defface ns-working-text-face
 552   '((t :underline t))
 553   "Face used to highlight working text during compose sequence insert."
 554   :group 'ns)
 555
 556 (defvar ns-working-overlay nil
 557   "Overlay used to highlight working text during compose sequence insert.
 558 When text is in th echo area, this just stores the length of the working text.")
 559
 560 (defvar ns-working-text)                ; nsterm.m
 561
 562 ;; Test if in echo area, based on mac-win.el 2007/08/26 unicode-2.
 563 ;; This will fail if called from a NONASCII_KEYSTROKE event on the global map.
 564 (defun ns-in-echo-area ()
 565   "Whether, for purposes of inserting working composition text, the minibuffer
 566 is currently being used."
 567   (or isearch-mode
 568       (and cursor-in-echo-area (current-message))
 569       ;; Overlay strings are not shown in some cases.
 570       (get-char-property (point) 'invisible)
 571       (and (not (bobp))
 572            (or (and (get-char-property (point) 'display)
 573                     (eq (get-char-property (1- (point)) 'display)
 574                         (get-char-property (point) 'display)))
 575                (and (get-char-property (point) 'composition)
 576                     (eq (get-char-property (1- (point)) 'composition)
 577                         (get-char-property (point) 'composition)))))))
 578
 579 ;; The 'interactive' here stays for subinvocations, so the ns-in-echo-area
 580 ;; always returns nil for some reason.  If this WASN'T the case, we could
 581 ;; map this to [ns-insert-working-text] and eliminate Fevals in nsterm.m.
 582 ;; These functions test whether in echo area and delegate accordingly.
 583 (defun ns-put-working-text ()
 584   (interactive)
 585   (if (ns-in-echo-area) (ns-echo-working-text) (ns-insert-working-text)))
 586 (defun ns-unput-working-text ()
 587   (interactive)
 588   (ns-delete-working-text))
 589
 590 (defun ns-insert-working-text ()
 591   "Insert contents of `ns-working-text' as UTF-8 string and mark with
 592 `ns-working-overlay'.  Any previously existing working text is cleared first.
 593 The overlay is assigned the face `ns-working-text-face'."
 594   ;; FIXME: if buffer is read-only, don't try to insert anything
 595   ;;  and if text is bound to a command, execute that instead (Bug#1453)
 596   (interactive)
 597   (ns-delete-working-text)
 598   (let ((start (point)))
 599     (insert ns-working-text)
 600     (overlay-put (setq ns-working-overlay (make-overlay start (point)
 601                                                         (current-buffer) nil t))
 602                  'face 'ns-working-text-face)))
 603
 604 (defun ns-echo-working-text ()
 605   "Echo contents of `ns-working-text' in message display area.
 606 See `ns-insert-working-text'."
 607   (ns-delete-working-text)
 608   (let* ((msg (current-message))
 609          (msglen (length msg))
 610          message-log-max)
 611     (setq ns-working-overlay (length ns-working-text))
 612     (setq msg (concat msg ns-working-text))
 613     (put-text-property msglen (+ msglen ns-working-overlay)
 614                        'face 'ns-working-text-face msg)
 615     (message "%s" msg)))
 616
 617 (defun ns-delete-working-text()
 618   "Delete working text and clear `ns-working-overlay'."
 619   (interactive)
 620   (cond
 621    ((and (overlayp ns-working-overlay)
 622          ;; Still alive?
 623          (overlay-buffer ns-working-overlay))
 624     (with-current-buffer (overlay-buffer ns-working-overlay)
 625       (delete-region (overlay-start ns-working-overlay)
 626                      (overlay-end ns-working-overlay))
 627       (delete-overlay ns-working-overlay)))
 628    ((integerp ns-working-overlay)
 629     (let ((msg (current-message))
 630           message-log-max)
 631       (setq msg (substring msg 0 (- (length msg) ns-working-overlay)))
 632       (message "%s" msg))))
 633   (setq ns-working-overlay nil))
 634
 635
 636 (declare-function ns-convert-utf8-nfd-to-nfc "nsfns.m" (str))
 637
 638 ;;;; OS X file system Unicode UTF-8 NFD (decomposed form) support
 639 ;; Lisp code based on utf-8m.el, by Seiji Zenitani, Eiji Honjoh, and
 640 ;; Carsten Bormann.
 641 (if (eq system-type 'darwin)
 642     (progn
 643
 644       (defun ns-utf8-nfd-post-read-conversion (length)
 645         "Calls `ns-convert-utf8-nfd-to-nfc' to compose char sequences."
 646         (save-excursion
 647           (save-restriction
 648             (narrow-to-region (point) (+ (point) length))
 649             (let ((str (buffer-string)))
 650               (delete-region (point-min) (point-max))
 651               (insert (ns-convert-utf8-nfd-to-nfc str))
 652               (- (point-max) (point-min))
 653               ))))
 654
 655       (define-coding-system 'utf-8-nfd
 656         "UTF-8 NFD (decomposed) encoding."
 657         :coding-type 'utf-8
 658         :mnemonic ?U
 659         :charset-list '(unicode)
 660         :post-read-conversion 'ns-utf8-nfd-post-read-conversion)
 661       (set-file-name-coding-system 'utf-8-nfd)))
 662
 663
 664
 665 ;;;; Inter-app communications support.
 666
 667 (defvar ns-input-text)                  ; nsterm.m
 668
 669 (defun ns-insert-text ()
 670   "Insert contents of `ns-input-text' at point."
 671   (interactive)
 672   (insert ns-input-text)
 673   (setq ns-input-text nil))
 674
 675 (defun ns-insert-file ()
 676   "Insert contents of file `ns-input-file' like insert-file but with less
 677 prompting.  If file is a directory perform a `find-file' on it."
 678   (interactive)
 679   (let ((f))
 680     (setq f (car ns-input-file))
 681     (setq ns-input-file (cdr ns-input-file))
 682     (if (file-directory-p f)
 683         (find-file f)
 684       (push-mark (+ (point) (car (cdr (insert-file-contents f))))))))
 685
 686 (defvar ns-select-overlay nil
 687   "Overlay used to highlight areas in files requested by Nextstep apps.")
 688 (make-variable-buffer-local 'ns-select-overlay)
 689
 690 (defvar ns-input-line)                  ; nsterm.m
 691
 692 (defun ns-open-file-select-line ()
 693   "Open a buffer containing the file `ns-input-file'.
 694 Lines are highlighted according to `ns-input-line'."
 695   (interactive)
 696   (ns-find-file)
 697   (cond
 698    ((and ns-input-line (buffer-modified-p))
 699     (if ns-select-overlay
 700         (setq ns-select-overlay (delete-overlay ns-select-overlay)))
 701     (deactivate-mark)
 702     (goto-char (point-min))
 703     (forward-line (1- (if (consp ns-input-line)
 704                           (min (car ns-input-line) (cdr ns-input-line))
 705                         ns-input-line))))
 706    (ns-input-line
 707     (if (not ns-select-overlay)
 708         (overlay-put (setq ns-select-overlay (make-overlay (point-min)
 709                                                            (point-min)))
 710                      'face 'highlight))
 711     (let ((beg (save-excursion
 712                  (goto-char (point-min))
 713                  (line-beginning-position
 714                   (if (consp ns-input-line)
 715                       (min (car ns-input-line) (cdr ns-input-line))
 716                     ns-input-line))))
 717           (end (save-excursion
 718                  (goto-char (point-min))
 719                  (line-beginning-position
 720                   (1+ (if (consp ns-input-line)
 721                           (max (car ns-input-line) (cdr ns-input-line))
 722                         ns-input-line))))))
 723       (move-overlay ns-select-overlay beg end)
 724       (deactivate-mark)
 725       (goto-char beg)))
 726    (t
 727     (if ns-select-overlay
 728         (setq ns-select-overlay (delete-overlay ns-select-overlay))))))
 729
 730 (defun ns-unselect-line ()
 731   "Removes any Nextstep highlight a buffer may contain."
 732   (if ns-select-overlay
 733       (setq ns-select-overlay (delete-overlay ns-select-overlay))))
 734
 735 (add-hook 'first-change-hook 'ns-unselect-line)
 736
 737
 738
 739 ;;;; Preferences handling.
 740 (declare-function ns-get-resource "nsfns.m" (owner name))
 741
 742 (defun get-lisp-resource (arg1 arg2)
 743   (let ((res (ns-get-resource arg1 arg2)))
 744     (cond
 745      ((not res) 'unbound)
 746      ((string-equal (upcase res) "YES") t)
 747      ((string-equal (upcase res) "NO")  nil)
 748      (t (read res)))))
 749
 750 ;; nsterm.m
 751
 752 (declare-function ns-read-file-name "nsfns.m"
 753                   (prompt &optional dir isLoad init))
 754
 755 ;;;; File handling.
 756
 757 (defun ns-open-file-using-panel ()
 758   "Pop up open-file panel, and load the result in a buffer."
 759   (interactive)
 760   ;; Prompt dir defaultName isLoad initial.
 761   (setq ns-input-file (ns-read-file-name "Select File to Load" nil t nil))
 762   (if ns-input-file
 763       (and (setq ns-input-file (list ns-input-file)) (ns-find-file))))
 764
 765 (defun ns-write-file-using-panel ()
 766   "Pop up save-file panel, and save buffer in resulting name."
 767   (interactive)
 768   (let (ns-output-file)
 769     ;; Prompt dir defaultName isLoad initial.
 770     (setq ns-output-file (ns-read-file-name "Save As" nil nil nil))
 771     (message ns-output-file)
 772     (if ns-output-file (write-file ns-output-file))))
 773
 774 (defcustom ns-pop-up-frames 'fresh
 775   "Non-nil means open files upon request from the Workspace in a new frame.
 776 If t, always do so.  Any other non-nil value means open a new frame
 777 unless the current buffer is a scratch buffer."
 778   :type '(choice (const :tag "Never" nil)
 779                  (const :tag "Always" t)
 780                  (other :tag "Except for scratch buffer" fresh))
 781   :version "23.1"
 782   :group 'ns)
 783
 784 (declare-function ns-hide-emacs "nsfns.m" (on))
 785
 786 (defun ns-find-file ()
 787   "Do a `find-file' with the `ns-input-file' as argument."
 788   (interactive)
 789   (let ((f) (file) (bufwin1) (bufwin2))
 790     (setq f (file-truename (expand-file-name (car ns-input-file)
 791                                              command-line-default-directory)))
 792     (setq ns-input-file (cdr ns-input-file))
 793     (setq file (find-file-noselect f))
 794     (setq bufwin1 (get-buffer-window file 'visible))
 795     (setq bufwin2 (get-buffer-window "*scratch*" 'visibile))
 796     (cond
 797      (bufwin1
 798       (select-frame (window-frame bufwin1))
 799       (raise-frame (window-frame bufwin1))
 800       (select-window bufwin1))
 801      ((and (eq ns-pop-up-frames 'fresh) bufwin2)
 802       (ns-hide-emacs 'activate)
 803       (select-frame (window-frame bufwin2))
 804       (raise-frame (window-frame bufwin2))
 805       (select-window bufwin2)
 806       (find-file f))
 807      (ns-pop-up-frames
 808       (ns-hide-emacs 'activate)
 809       (let ((pop-up-frames t)) (pop-to-buffer file nil)))
 810      (t
 811       (ns-hide-emacs 'activate)
 812       (find-file f)))))
 813
 814
 815
 816 ;;;; Frame-related functions.
 817
 818 ;; Don't show the frame name; that's redundant with Nextstep.
 819 (setq-default mode-line-frame-identification '("  "))
 820
 821 ;; You say tomAYto, I say tomAHto..
 822 (defvaralias 'ns-option-modifier 'ns-alternate-modifier)
 823 (defvaralias 'ns-right-option-modifier 'ns-right-alternate-modifier)
 824
 825 (defun ns-do-hide-emacs ()
 826   (interactive)
 827   (ns-hide-emacs t))
 828
 829 (declare-function ns-hide-others "nsfns.m" ())
 830
 831 (defun ns-do-hide-others ()
 832   (interactive)
 833   (ns-hide-others))
 834
 835 (declare-function ns-emacs-info-panel "nsfns.m" ())
 836
 837 (defun ns-do-emacs-info-panel ()
 838   (interactive)
 839   (ns-emacs-info-panel))
 840
 841 (defun ns-next-frame ()
 842   "Switch to next visible frame."
 843   (interactive)
 844   (other-frame 1))
 845
 846 (defun ns-prev-frame ()
 847   "Switch to previous visible frame."
 848   (interactive)
 849   (other-frame -1))
 850
 851 ;; If no position specified, make new frame offset by 25 from current.
 852 (defvar parameters)                  ; dynamically bound in make-frame
 853 (add-hook 'before-make-frame-hook
 854           (lambda ()
 855             (let ((left (cdr (assq 'left (frame-parameters))))
 856                   (top (cdr (assq 'top (frame-parameters)))))
 857               (if (consp left) (setq left (cadr left)))
 858               (if (consp top) (setq top (cadr top)))
 859               (cond
 860                ((or (assq 'top parameters) (assq 'left parameters)))
 861                ((or (not left) (not top)))
 862                (t
 863                 (setq parameters (cons (cons 'left (+ left 25))
 864                                        (cons (cons 'top (+ top 25))
 865                                              parameters))))))))
 866
 867 ;; frame will be focused anyway, so select it
 868 ;; (if this is not done, modeline is dimmed until first interaction)
 869 (add-hook 'after-make-frame-functions 'select-frame)
 870
 871 (defvar tool-bar-mode)
 872 (declare-function tool-bar-mode "tool-bar" (&optional arg))
 873
 874 ;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
 875 ;; see http://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html .
 876 (defun ns-toggle-toolbar (&optional frame)
 877   "Switches the tool bar on and off in frame FRAME.
 878  If FRAME is nil, the change applies to the selected frame."
 879   (interactive)
 880   (modify-frame-parameters
 881    frame (list (cons 'tool-bar-lines
 882                        (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
 883                                    0 1)) ))
 884   (if (not tool-bar-mode) (tool-bar-mode t)))
 885
 886
 887
 888 ;;;; Dialog-related functions.
 889
 890
 891 ;; Ask user for confirm before printing.  Due to Kevin Rodgers.
 892 (defun ns-print-buffer ()
 893   "Interactive front-end to `print-buffer': asks for user confirmation first."
 894   (interactive)
 895   (if (and (called-interactively-p 'interactive)
 896            (or (listp last-nonmenu-event)
 897                (and (char-or-string-p (event-basic-type last-command-event))
 898                     (memq 'super (event-modifiers last-command-event)))))
 899       (let ((last-nonmenu-event (if (listp last-nonmenu-event)
 900                                     last-nonmenu-event
 901                                   ;; Fake it:
 902                                   `(mouse-1 POSITION 1))))
 903         (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
 904             (print-buffer)
 905           (error "Cancelled")))
 906     (print-buffer)))
 907
 908
 909 ;;;; Font support.
 910
 911 ;; Needed for font listing functions under both backend and normal
 912 (setq scalable-fonts-allowed t)
 913
 914 ;; Set to use font panel instead
 915 (declare-function ns-popup-font-panel "nsfns.m" (&optional frame))
 916 (defalias 'x-select-font 'ns-popup-font-panel "Pop up the font panel.
 917 This function has been overloaded in Nextstep.")
 918 (defalias 'mouse-set-font 'ns-popup-font-panel "Pop up the font panel.
 919 This function has been overloaded in Nextstep.")
 920
 921 ;; nsterm.m
 922 (defvar ns-input-font)
 923 (defvar ns-input-fontsize)
 924
 925 (defun ns-respond-to-change-font ()
 926   "Respond to changeFont: event, expecting `ns-input-font' and\n\
 927 `ns-input-fontsize' of new font."
 928   (interactive)
 929   (modify-frame-parameters (selected-frame)
 930                            (list (cons 'font ns-input-font)
 931                                  (cons 'fontsize ns-input-fontsize)))
 932   (set-frame-font ns-input-font))
 933
 934
 935 ;; Default fontset for Mac OS X.  This is mainly here to show how a fontset
 936 ;; can be set up manually.  Ordinarily, fontsets are auto-created whenever
 937 ;; a font is chosen by
 938 (defvar ns-standard-fontset-spec
 939   ;; Only some code supports this so far, so use uglier XLFD version
 940   ;; "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
 941   (mapconcat 'identity
 942              '("-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard"
 943                "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1"
 944                "han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1"
 945                "cyrillic:-*-Trebuchet$MS-*-*-*-*-10-*-*-*-*-*-iso10646-1")
 946              ",")
 947   "String of fontset spec of the standard fontset.
 948 This defines a fontset consisting of the Courier and other fonts that
 949 come with OS X.
 950 See the documentation of `create-fontset-from-fontset-spec' for the format.")
 951
 952 ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles.
 953 (if (fboundp 'new-fontset)
 954     (progn
 955       ;; Setup the default fontset.
 956       (create-default-fontset)
 957       ;; Create the standard fontset.
 958       (condition-case err
 959           (create-fontset-from-fontset-spec ns-standard-fontset-spec t)
 960         (error (display-warning
 961                 'initialization
 962                 (format "Creation of the standard fontset failed: %s" err)
 963                 :error)))))
 964
 965 (defvar ns-reg-to-script)               ; nsfont.m
 966
 967 ;; This maps font registries (not exposed by NS APIs for font selection) to
 968 ;; unicode scripts (which can be mapped to unicode character ranges which are).
 969 ;; See ../international/fontset.el
 970 (setq ns-reg-to-script
 971       '(("iso8859-1" . latin)
 972         ("iso8859-2" . latin)
 973         ("iso8859-3" . latin)
 974         ("iso8859-4" . latin)
 975         ("iso8859-5" . cyrillic)
 976         ("microsoft-cp1251" . cyrillic)
 977         ("koi8-r" . cyrillic)
 978         ("iso8859-6" . arabic)
 979         ("iso8859-7" . greek)
 980         ("iso8859-8" . hebrew)
 981         ("iso8859-9" . latin)
 982         ("iso8859-10" . latin)
 983         ("iso8859-11" . thai)
 984         ("tis620" . thai)
 985         ("iso8859-13" . latin)
 986         ("iso8859-14" . latin)
 987         ("iso8859-15" . latin)
 988         ("iso8859-16" . latin)
 989         ("viscii1.1-1" . latin)
 990         ("jisx0201" . kana)
 991         ("jisx0208" . han)
 992         ("jisx0212" . han)
 993         ("jisx0213" . han)
 994         ("gb2312.1980" . han)
 995         ("gb18030" . han)
 996         ("gbk-0" . han)
 997         ("big5" . han)
 998         ("cns11643" . han)
 999         ("sisheng_cwnn" . bopomofo)
1000         ("ksc5601.1987" . hangul)
1001         ("ethiopic-unicode" . ethiopic)
1002         ("is13194-devanagari" . indian-is13194)
1003         ("iso10646.indian-1" . devanagari)))
1004
1005
1006 ;;;; Pasteboard support.
1007
1008 (declare-function ns-get-cut-buffer-internal "nsselect.m" (buffer))
1009
1010 (defun ns-get-pasteboard ()
1011   "Returns the value of the pasteboard."
1012   (ns-get-cut-buffer-internal 'PRIMARY))
1013
1014 (declare-function ns-store-cut-buffer-internal "nsselect.m" (buffer string))
1015
1016 (defun ns-set-pasteboard (string)
1017   "Store STRING into the pasteboard of the Nextstep display server."
1018   ;; Check the data type of STRING.
1019   (if (not (stringp string)) (error "Nonstring given to pasteboard"))
1020   (ns-store-cut-buffer-internal 'PRIMARY string))
1021
1022 ;; We keep track of the last text selected here, so we can check the
1023 ;; current selection against it, and avoid passing back our own text
1024 ;; from x-cut-buffer-or-selection-value.
1025 (defvar ns-last-selected-text nil)
1026
1027 (defun x-select-text (text &optional push)
1028   "Select TEXT, a string, according to the window system.
1029
1030 On X, put TEXT in the primary X selection.  For backward
1031 compatibility with older X applications, set the value of X cut
1032 buffer 0 as well, and if the optional argument PUSH is non-nil,
1033 rotate the cut buffers.  If `x-select-enable-clipboard' is
1034 non-nil, copy the text to the X clipboard as well.
1035
1036 On Windows, make TEXT the current selection.  If
1037 `x-select-enable-clipboard' is non-nil, copy the text to the
1038 clipboard as well.  The argument PUSH is ignored.
1039
1040 On Nextstep, put TEXT in the pasteboard; PUSH is ignored."
1041   ;; Don't send the pasteboard too much text.
1042   ;; It becomes slow, and if really big it causes errors.
1043   (ns-set-pasteboard text)
1044   (setq ns-last-selected-text text))
1045
1046 ;; Return the value of the current Nextstep selection.  For
1047 ;; compatibility with older Nextstep applications, this checks cut
1048 ;; buffer 0 before retrieving the value of the primary selection.
1049 (defun x-cut-buffer-or-selection-value ()
1050   (let (text)
1051
1052     ;; Consult the selection, then the cut buffer.  Treat empty strings
1053     ;; as if they were unset.
1054     (or text (setq text (ns-get-pasteboard)))
1055     (if (string= text "") (setq text nil))
1056
1057     (cond
1058      ((not text) nil)
1059      ((eq text ns-last-selected-text) nil)
1060      ((string= text ns-last-selected-text)
1061       ;; Record the newer string, so subsequent calls can use the `eq' test.
1062       (setq ns-last-selected-text text)
1063       nil)
1064      (t
1065       (setq ns-last-selected-text text)))))
1066
1067 (defun ns-copy-including-secondary ()
1068   (interactive)
1069   (call-interactively 'kill-ring-save)
1070   (ns-store-cut-buffer-internal 'SECONDARY
1071                                 (buffer-substring (point) (mark t))))
1072 (defun ns-paste-secondary ()
1073   (interactive)
1074   (insert (ns-get-cut-buffer-internal 'SECONDARY)))
1075
1076
1077
1078 ;;;; Scrollbar handling.
1079
1080 (global-set-key [vertical-scroll-bar down-mouse-1] 'ns-handle-scroll-bar-event)
1081 (global-unset-key [vertical-scroll-bar mouse-1])
1082 (global-unset-key [vertical-scroll-bar drag-mouse-1])
1083
1084 (declare-function scroll-bar-scale "scroll-bar" (num-denom whole))
1085
1086 (defun ns-scroll-bar-move (event)
1087   "Scroll the frame according to a Nextstep scroller event."
1088   (interactive "e")
1089   (let* ((pos (event-end event))
1090          (window (nth 0 pos))
1091          (scale (nth 2 pos)))
1092     (with-current-buffer (window-buffer window)
1093       (cond
1094        ((eq (car scale) (cdr scale))
1095         (goto-char (point-max)))
1096        ((= (car scale) 0)
1097         (goto-char (point-min)))
1098        (t
1099         (goto-char (+ (point-min) 1
1100                       (scroll-bar-scale scale (- (point-max) (point-min)))))))
1101       (beginning-of-line)
1102       (set-window-start window (point))
1103       (vertical-motion (/ (window-height window) 2) window))))
1104
1105 (defun ns-handle-scroll-bar-event (event)
1106   "Handle scroll bar EVENT to emulate Nextstep style scrolling."
1107   (interactive "e")
1108   (let* ((position (event-start event))
1109          (bar-part (nth 4 position))
1110          (window (nth 0 position))
1111          (old-window (selected-window)))
1112     (cond
1113      ((eq bar-part 'ratio)
1114       (ns-scroll-bar-move event))
1115      ((eq bar-part 'handle)
1116       (if (eq window (selected-window))
1117           (track-mouse (ns-scroll-bar-move event))
1118         ;; track-mouse faster for selected window, slower for unselected.
1119         (ns-scroll-bar-move event)))
1120      (t
1121       (select-window window)
1122       (cond
1123        ((eq bar-part 'up)
1124         (goto-char (window-start window))
1125         (scroll-down 1))
1126        ((eq bar-part 'above-handle)
1127         (scroll-down))
1128        ((eq bar-part 'below-handle)
1129         (scroll-up))
1130        ((eq bar-part 'down)
1131         (goto-char (window-start window))
1132         (scroll-up 1)))
1133       (select-window old-window)))))
1134
1135
1136 ;;;; Color support.
1137
1138 (declare-function ns-list-colors "nsfns.m" (&optional frame))
1139
1140 (defvar x-colors (ns-list-colors)
1141   "List of basic colors available on color displays.
1142 For X, the list comes from the `rgb.txt' file,v 10.41 94/02/20.
1143 For Nextstep, this is a list of non-PANTONE colors returned by
1144 the operating system.")
1145
1146 (defun xw-defined-colors (&optional frame)
1147   "Internal function called by `defined-colors'."
1148   (or frame (setq frame (selected-frame)))
1149   (let ((all-colors x-colors)
1150         (this-color nil)
1151         (defined-colors nil))
1152     (while all-colors
1153       (setq this-color (car all-colors)
1154             all-colors (cdr all-colors))
1155       ;; (and (face-color-supported-p frame this-color t)
1156       (setq defined-colors (cons this-color defined-colors))) ;;)
1157     defined-colors))
1158
1159 ;; Functions for color panel + drag
1160 (defun ns-face-at-pos (pos)
1161   (let* ((frame (car pos))
1162          (frame-pos (cons (cadr pos) (cddr pos)))
1163          (window (window-at (car frame-pos) (cdr frame-pos) frame))
1164          (window-pos (coordinates-in-window-p frame-pos window))
1165          (buffer (window-buffer window))
1166          (edges (window-edges window)))
1167     (cond
1168      ((not window-pos)
1169       nil)
1170      ((eq window-pos 'mode-line)
1171       'modeline)
1172      ((eq window-pos 'vertical-line)
1173       'default)
1174      ((consp window-pos)
1175       (with-current-buffer buffer
1176         (let ((p (car (compute-motion (window-start window)
1177                                       (cons (nth 0 edges) (nth 1 edges))
1178                                       (window-end window)
1179                                       frame-pos
1180                                       (- (window-width window) 1)
1181                                       nil
1182                                       window))))
1183           (cond
1184            ((eq p (window-point window))
1185             'cursor)
1186            ((and mark-active (< (region-beginning) p) (< p (region-end)))
1187             'region)
1188            (t
1189             (let ((faces (get-char-property p 'face window)))
1190               (if (consp faces) (car faces) faces)))))))
1191      (t
1192       nil))))
1193
1194 (defvar ns-input-color)                 ; nsterm.m
1195
1196 (defun ns-set-foreground-at-mouse ()
1197   "Set the foreground color at the mouse location to `ns-input-color'."
1198   (interactive)
1199   (let* ((pos (mouse-position))
1200          (frame (car pos))
1201          (face (ns-face-at-pos pos)))
1202     (cond
1203      ((eq face 'cursor)
1204       (modify-frame-parameters frame (list (cons 'cursor-color
1205                                                  ns-input-color))))
1206      ((not face)
1207       (modify-frame-parameters frame (list (cons 'foreground-color
1208                                                  ns-input-color))))
1209      (t
1210       (set-face-foreground face ns-input-color frame)))))
1211
1212 (defun ns-set-background-at-mouse ()
1213   "Set the background color at the mouse location to `ns-input-color'."
1214   (interactive)
1215   (let* ((pos (mouse-position))
1216          (frame (car pos))
1217          (face (ns-face-at-pos pos)))
1218     (cond
1219      ((eq face 'cursor)
1220       (modify-frame-parameters frame (list (cons 'cursor-color
1221                                                  ns-input-color))))
1222      ((not face)
1223       (modify-frame-parameters frame (list (cons 'background-color
1224                                                  ns-input-color))))
1225      (t
1226       (set-face-background face ns-input-color frame)))))
1227
1228 ;; Set some options to be as Nextstep-like as possible.
1229 (setq frame-title-format t
1230       icon-title-format t)
1231
1232
1233 (defvar ns-initialized nil
1234   "Non-nil if Nextstep windowing has been initialized.")
1235
1236 (declare-function ns-list-services "nsfns.m" ())
1237 (declare-function x-open-connection "nsfns.m"
1238                   (display &optional xrm-string must-succeed))
1239
1240 ;; Do the actual Nextstep Windows setup here; the above code just
1241 ;; defines functions and variables that we use now.
1242 (defun ns-initialize-window-system ()
1243   "Initialize Emacs for Nextstep (Cocoa / GNUstep) windowing."
1244
1245   ;; PENDING: not needed?
1246   (setq command-line-args (ns-handle-args command-line-args))
1247
1248   (x-open-connection (system-name) nil t)
1249
1250   (dolist (service (ns-list-services))
1251       (if (eq (car service) 'undefined)
1252           (ns-define-service (cdr service))
1253         (define-key global-map (vector (car service))
1254           (ns-define-service (cdr service)))))
1255
1256   (if (and (eq (get-lisp-resource nil "NXAutoLaunch") t)
1257            (eq (get-lisp-resource nil "HideOnAutoLaunch") t))
1258       (add-hook 'after-init-hook 'ns-do-hide-emacs))
1259
1260   ;; FIXME: This will surely lead to "MODIFIED OUTSIDE CUSTOM" warnings.
1261   (menu-bar-mode (if (get-lisp-resource nil "Menus") 1 -1))
1262
1263   (setq ns-initialized t))
1264
1265 (add-to-list 'handle-args-function-alist '(ns . ns-handle-args))
1266 (add-to-list 'frame-creation-function-alist '(ns . x-create-frame-with-faces))
1267 (add-to-list 'window-system-initialization-alist '(ns . ns-initialize-window-system))
1268
1269
1270 (provide 'ns-win)
1271
1272 ;; arch-tag: eb138a45-4e2e-4d68-b1c9-a39665731644
1273 ;;; ns-win.el ends here