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