code.delx.au - gnu-emacs/blob - lisp/term/ns-win.el

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