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