1 ;;; ns-win.el --- lisp side of interface with NeXT/Open/GNUstep/MacOS X window system
3 ;; Copyright (C) 1993, 1994, 2005, 2006, 2007, 2008
4 ;; Free Software Foundation, Inc.
6 ;; Authors: Carl Edman, Christian Limpach, Scott Bender,
7 ;; Christophe de Dinechin, Adrian Robert
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; ns-win.el: this file is loaded from ../lisp/startup.el when it
28 ;; recognizes that Nextstep windows are to be used. Command line
29 ;; switches are parsed and those pertaining to Nextstep are processed
30 ;; and removed from the command line. The Nextstep display is opened
31 ;; and hooks are set for popping up the initial window.
33 ;; startup.el will then examine startup files, and eventually call the hooks
34 ;; which create the first window (s).
36 ;; A number of other Nextstep convenience functions are defined in
37 ;; this file, which works in close coordination with src/nsfns.m.
42 (if (not (featurep 'ns))
43 (error "%s: Loading ns-win.el but not compiled for GNUStep/MacOS"
46 (eval-when-compile (require 'cl))
48 ;; Documentation-purposes only: actually loaded in loadup.el
60 (defvar ns-version-string)
61 (defvar ns-expand-space)
62 (defvar ns-cursor-blink-rate)
63 (defvar ns-alternate-modifier)
65 ;;;; Command line argument handling.
67 (defvar ns-invocation-args nil)
68 (defvar ns-command-line-resources nil)
70 ;; Handler for switches of the form "-switch value" or "-switch".
71 (defun ns-handle-switch (switch &optional numeric)
72 (let ((aelt (assoc switch command-line-ns-option-alist)))
74 (setq default-frame-alist
75 (cons (cons (nth 3 aelt)
77 (string-to-number (pop ns-invocation-args))
78 (or (nth 4 aelt) (pop ns-invocation-args))))
79 default-frame-alist)))))
81 ;; Handler for switches of the form "-switch n"
82 (defun ns-handle-numeric-switch (switch)
83 (ns-handle-switch switch t))
85 ;; Make -iconic apply only to the initial frame!
86 (defun ns-handle-iconic (switch)
87 (setq initial-frame-alist
88 (cons '(visibility . icon) initial-frame-alist)))
90 ;; Handle the -name option, set the name of the initial frame.
91 (defun ns-handle-name-switch (switch)
92 (or (consp ns-invocation-args)
93 (error "%s: missing argument to `%s' option" (invocation-name) switch))
94 (setq initial-frame-alist (cons (cons 'name (pop ns-invocation-args))
95 initial-frame-alist)))
97 ;; Set (but not used?) in frame.el.
98 (defvar x-display-name nil
99 "The name of the Nextstep display on which Emacs was started.")
102 (defvar ns-input-file)
104 (defun ns-handle-nxopen (switch)
105 (setq unread-command-events (append unread-command-events '(ns-open-file))
106 ns-input-file (append ns-input-file (list (pop ns-invocation-args)))))
108 (defun ns-handle-nxopentemp (switch)
109 (setq unread-command-events (append unread-command-events
110 '(ns-open-temp-file))
111 ns-input-file (append ns-input-file (list (pop ns-invocation-args)))))
113 (defun ns-ignore-0-arg (switch))
114 (defun ns-ignore-1-arg (switch)
115 (setq ns-invocation-args (cdr ns-invocation-args)))
116 (defun ns-ignore-2-arg (switch)
117 (setq ns-invocation-args (cddr ns-invocation-args)))
119 (defun ns-handle-args (args)
120 "Process Nextstep-related command line options.
121 This is run before the user's startup file is loaded.
122 The options in ARGS are copied to `ns-invocation-args'.
123 The Nextstep-related settings are then applied using the handlers
124 defined in `command-line-ns-option-alist'.
125 The return value is ARGS minus the number of arguments processed."
126 ;; We use ARGS to accumulate the args that we don't handle here, to return.
127 (setq ns-invocation-args args
129 (while ns-invocation-args
130 (let* ((this-switch (pop ns-invocation-args))
131 (orig-this-switch this-switch)
132 completion argval aelt handler)
133 ;; Check for long options with attached arguments
134 ;; and separate out the attached option argument into argval.
135 (if (string-match "^--[^=]*=" this-switch)
136 (setq argval (substring this-switch (match-end 0))
137 this-switch (substring this-switch 0 (1- (match-end 0)))))
138 ;; Complete names of long options.
139 (if (string-match "^--" this-switch)
141 (setq completion (try-completion this-switch
142 command-line-ns-option-alist))
143 (if (eq completion t)
144 ;; Exact match for long option.
146 (if (stringp completion)
147 (let ((elt (assoc completion command-line-ns-option-alist)))
148 ;; Check for abbreviated long option.
150 (error "Option `%s' is ambiguous" this-switch))
151 (setq this-switch completion))))))
152 (setq aelt (assoc this-switch command-line-ns-option-alist))
153 (if aelt (setq handler (nth 2 aelt)))
156 (let ((ns-invocation-args
157 (cons argval ns-invocation-args)))
158 (funcall handler this-switch))
159 (funcall handler this-switch))
160 (setq args (cons orig-this-switch args)))))
163 (defun x-parse-geometry (geom)
164 "Parse a Nextstep-style geometry string STRING.
165 Returns an alist of the form ((top . TOP), (left . LEFT) ... ).
166 The properties returned may include `top', `left', `height', and `width'."
167 (when (string-match "\\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\)\
168 \\( \\([0-9]+\\) ?\\)?\\)?\\)?"
173 (list (cons 'top (string-to-number (match-string 1 geom))))
174 (if (match-string 3 geom)
175 (list (cons 'left (string-to-number (match-string 3 geom)))))
176 (if (match-string 5 geom)
177 (list (cons 'height (string-to-number (match-string 5 geom)))))
178 (if (match-string 7 geom)
179 (list (cons 'width (string-to-number (match-string 7 geom)))))))))
181 ;;;; Keyboard mapping.
183 ;; These tell read-char how to convert
184 ;; these special chars to ASCII.
185 (put 'backspace 'ascii-character 127)
186 (put 'delete 'ascii-character 127)
187 (put 'tab 'ascii-character ?\t)
188 (put 'S-tab 'ascii-character (logior 16 ?\t))
189 (put 'linefeed 'ascii-character ?\n)
190 (put 'clear 'ascii-character 12)
191 (put 'return 'ascii-character 13)
192 (put 'escape 'ascii-character ?\e)
194 ;; Map certain keypad keys into ASCII characters
195 ;; that people usually expect.
196 (define-key function-key-map [backspace] [127])
197 (define-key function-key-map [delete] [127])
198 (define-key function-key-map [tab] [?\t])
199 (define-key function-key-map [S-tab] [25])
200 (define-key function-key-map [linefeed] [?\n])
201 (define-key function-key-map [clear] [11])
202 (define-key function-key-map [return] [13])
203 (define-key function-key-map [escape] [?\e])
204 (define-key function-key-map [M-backspace] [?\M-\d])
205 (define-key function-key-map [M-delete] [?\M-\d])
206 (define-key function-key-map [M-tab] [?\M-\t])
207 (define-key function-key-map [M-linefeed] [?\M-\n])
208 (define-key function-key-map [M-clear] [?\M-\013])
209 (define-key function-key-map [M-return] [?\M-\015])
210 (define-key function-key-map [M-escape] [?\M-\e])
213 ;; Here are some Nextstep-like bindings for command key sequences.
214 (define-key global-map [?\s-,] 'ns-popup-prefs-panel)
215 (define-key global-map [?\s-'] 'next-multiframe-window)
216 (define-key global-map [?\s-`] 'other-frame)
217 (define-key global-map [?\s--] 'center-line)
218 (define-key global-map [?\s-:] 'ispell)
219 (define-key global-map [?\s-\;] 'ispell-next)
220 (define-key global-map [?\s-?] 'info)
221 (define-key global-map [?\s-^] 'kill-some-buffers)
222 (define-key global-map [?\s-&] 'kill-this-buffer)
223 (define-key global-map [?\s-C] 'ns-popup-color-panel)
224 (define-key global-map [?\s-D] 'dired)
225 (define-key global-map [?\s-E] 'edit-abbrevs)
226 (define-key global-map [?\s-L] 'shell-command)
227 (define-key global-map [?\s-M] 'manual-entry)
228 (define-key global-map [?\s-S] 'ns-write-file-using-panel)
229 (define-key global-map [?\s-a] 'mark-whole-buffer)
230 (define-key global-map [?\s-c] 'ns-copy-including-secondary)
231 (define-key global-map [?\s-d] 'isearch-repeat-backward)
232 (define-key global-map [?\s-e] 'isearch-yank-kill)
233 (define-key global-map [?\s-f] 'isearch-forward)
234 (define-key global-map [?\s-g] 'isearch-repeat-forward)
235 (define-key global-map [?\s-h] 'ns-do-hide-emacs)
236 (define-key global-map [?\s-H] 'ns-do-hide-others)
237 (define-key global-map [?\s-j] 'exchange-point-and-mark)
238 (define-key global-map [?\s-k] 'kill-this-buffer)
239 (define-key global-map [?\s-l] 'goto-line)
240 (define-key global-map [?\s-m] 'iconify-frame)
241 (define-key global-map [?\s-n] 'make-frame)
242 (define-key global-map [?\s-o] 'ns-open-file-using-panel)
243 (define-key global-map [?\s-p] 'ns-print-buffer)
244 (define-key global-map [?\s-q] 'save-buffers-kill-emacs)
245 (define-key global-map [?\s-s] 'save-buffer)
246 (define-key global-map [?\s-t] 'ns-popup-font-panel)
247 (define-key global-map [?\s-u] 'revert-buffer)
248 (define-key global-map [?\s-v] 'yank)
249 (define-key global-map [?\s-w] 'delete-frame)
250 (define-key global-map [?\s-x] 'kill-region)
251 (define-key global-map [?\s-y] 'ns-paste-secondary)
252 (define-key global-map [?\s-z] 'undo)
253 (define-key global-map [?\s-|] 'shell-command-on-region)
254 (define-key global-map [s-kp-bar] 'shell-command-on-region)
255 ;; (as in Terminal.app)
256 (define-key global-map [s-right] 'ns-next-frame)
257 (define-key global-map [s-left] 'ns-prev-frame)
259 (define-key global-map [home] 'beginning-of-buffer)
260 (define-key global-map [end] 'end-of-buffer)
261 (define-key global-map [kp-home] 'beginning-of-buffer)
262 (define-key global-map [kp-end] 'end-of-buffer)
263 (define-key global-map [kp-prior] 'scroll-down)
264 (define-key global-map [kp-next] 'scroll-up)
267 ;; Special Nextstep-generated events are converted to function keys. Here
268 ;; are the bindings for them.
269 (define-key global-map [ns-power-off]
270 (lambda () (interactive) (save-buffers-kill-emacs t)))
271 (define-key global-map [ns-open-file] 'ns-find-file)
272 (define-key global-map [ns-open-temp-file] [ns-open-file])
273 (define-key global-map [ns-drag-file] 'ns-insert-file)
274 (define-key global-map [ns-drag-color] 'ns-set-foreground-at-mouse)
275 (define-key global-map [S-ns-drag-color] 'ns-set-background-at-mouse)
276 (define-key global-map [ns-drag-text] 'ns-insert-text)
277 (define-key global-map [ns-change-font] 'ns-respond-to-change-font)
278 (define-key global-map [ns-open-file-line] 'ns-open-file-select-line)
279 (define-key global-map [ns-insert-working-text] 'ns-insert-working-text)
280 (define-key global-map [ns-delete-working-text] 'ns-delete-working-text)
281 (define-key global-map [ns-spi-service-call] 'ns-spi-service-call)
285 ;; Functions to set environment variables by running a subshell.
286 ;;; Idea based on Nextstep 4.2 distribution, this version of code
287 ;;; based on mac-read-environment-vars-from-shell () by David Reitter.
288 ;;; Mostly used only under ns-extended-platform-support-mode.
290 (defun ns-make-command-string (cmdlist)
291 (mapconcat 'identity cmdlist " ; "))
294 (defun ns-grabenv (&optional shell-path startup)
295 "Set the Emacs environment using the output of a shell command.
296 This runs a shell subprocess, and interpret its output as a
297 series of environment variables to insert into the emacs
299 SHELL-PATH gives the path to the shell; if nil, this defaults to
300 the current setting of `shell-file-name'.
301 STARTUP is a list of commands for the shell to execute; if nil,
302 this defaults to \"printenv\"."
305 (let ((shell-file-name (if shell-path shell-path shell-file-name))
306 (cmd (ns-make-command-string (if startup startup '("printenv")))))
307 (shell-command cmd t)
308 (while (search-forward-regexp "^\\([A-Za-z_0-9]+\\)=\\(.*\\)$" nil t)
309 (setenv (match-string 1)
310 (if (equal (match-string 1) "PATH")
311 (concat (getenv "PATH") ":" (match-string 2))
312 (match-string 2)))))))
314 ;; Set up a number of aliases and other layers to pretend we're using
315 ;; the Choi/Mitsuharu Carbon port.
317 (defvaralias 'mac-allow-anti-aliasing 'ns-antialias-text)
318 (defvaralias 'mac-command-modifier 'ns-command-modifier)
319 (defvaralias 'mac-control-modifier 'ns-control-modifier)
320 (defvaralias 'mac-option-modifier 'ns-option-modifier)
321 (defvaralias 'mac-function-modifier 'ns-function-modifier)
323 (defvar menu-bar-ns-file-menu) ; below
325 ;; Toggle some additional Nextstep-like features that may interfere
326 ;; with users' expectations coming from emacs on other platforms.
327 (define-minor-mode ns-extended-platform-support-mode
328 "Toggle Nextstep extended platform support features.
329 When this mode is active (no modeline indicator):
330 - File menu is altered slightly in keeping with conventions.
331 - Meta-up, meta-down are bound to scroll window up and down one line.
332 - Screen position is preserved in scrolling.
333 - Transient mark mode is activated"
337 (if ns-extended-platform-support-mode
339 (global-set-key [M-up] 'down-one)
340 (global-set-key [M-down] 'up-one)
341 ;; These conflict w/word-left, word-right.
342 ;;(global-set-key [M-left] 'left-one)
343 ;;(global-set-key [M-right] 'right-one)
345 (setq scroll-preserve-screen-position t)
346 (transient-mark-mode 1)
348 ;; Change file menu to simplify and add a couple of
349 ;; Nextstep-specific items
350 (easy-menu-remove-item global-map '("menu-bar") 'file)
351 (easy-menu-add-item global-map '(menu-bar)
352 (cons "File" menu-bar-ns-file-menu) 'edit))
354 ;; Undo everything above.
355 (global-unset-key [M-up])
356 (global-unset-key [M-down])
357 (setq scroll-preserve-screen-position nil)
358 (transient-mark-mode 0)
359 (easy-menu-remove-item global-map '("menu-bar") 'file)
360 (easy-menu-add-item global-map '(menu-bar)
361 (cons "File" menu-bar-file-menu) 'edit))))
364 (defun x-setup-function-keys (frame)
365 "Set up function Keys for Nextstep for frame FRAME."
366 (unless (terminal-parameter frame 'x-setup-function-keys)
367 (with-selected-frame frame
368 (setq interprogram-cut-function 'x-select-text
369 interprogram-paste-function 'x-cut-buffer-or-selection-value)
370 ;; (let ((map (copy-keymap x-alternatives-map)))
371 ;; (set-keymap-parent map (keymap-parent local-function-key-map))
372 ;; (set-keymap-parent local-function-key-map map))
373 (setq system-key-alist
375 (cons (logior (lsh 0 16) 1) 'ns-power-off)
376 (cons (logior (lsh 0 16) 2) 'ns-open-file)
377 (cons (logior (lsh 0 16) 3) 'ns-open-temp-file)
378 (cons (logior (lsh 0 16) 4) 'ns-drag-file)
379 (cons (logior (lsh 0 16) 5) 'ns-drag-color)
380 (cons (logior (lsh 0 16) 6) 'ns-drag-text)
381 (cons (logior (lsh 0 16) 7) 'ns-change-font)
382 (cons (logior (lsh 0 16) 8) 'ns-open-file-line)
383 (cons (logior (lsh 0 16) 9) 'ns-insert-working-text)
384 (cons (logior (lsh 0 16) 10) 'ns-delete-working-text)
385 (cons (logior (lsh 0 16) 11) 'ns-spi-service-call)
386 (cons (logior (lsh 1 16) 32) 'f1)
387 (cons (logior (lsh 1 16) 33) 'f2)
388 (cons (logior (lsh 1 16) 34) 'f3)
389 (cons (logior (lsh 1 16) 35) 'f4)
390 (cons (logior (lsh 1 16) 36) 'f5)
391 (cons (logior (lsh 1 16) 37) 'f6)
392 (cons (logior (lsh 1 16) 38) 'f7)
393 (cons (logior (lsh 1 16) 39) 'f8)
394 (cons (logior (lsh 1 16) 40) 'f9)
395 (cons (logior (lsh 1 16) 41) 'f10)
396 (cons (logior (lsh 1 16) 42) 'f11)
397 (cons (logior (lsh 1 16) 43) 'f12)
398 (cons (logior (lsh 1 16) 44) 'kp-insert)
399 (cons (logior (lsh 1 16) 45) 'kp-delete)
400 (cons (logior (lsh 1 16) 46) 'kp-home)
401 (cons (logior (lsh 1 16) 47) 'kp-end)
402 (cons (logior (lsh 1 16) 48) 'kp-prior)
403 (cons (logior (lsh 1 16) 49) 'kp-next)
404 (cons (logior (lsh 1 16) 50) 'print-screen)
405 (cons (logior (lsh 1 16) 51) 'scroll-lock)
406 (cons (logior (lsh 1 16) 52) 'pause)
407 (cons (logior (lsh 1 16) 53) 'system)
408 (cons (logior (lsh 1 16) 54) 'break)
409 (cons (logior (lsh 1 16) 56) 'please-tell-carl-what-this-key-is-called-56)
410 (cons (logior (lsh 1 16) 61) 'please-tell-carl-what-this-key-is-called-61)
411 (cons (logior (lsh 1 16) 62) 'please-tell-carl-what-this-key-is-called-62)
412 (cons (logior (lsh 1 16) 63) 'please-tell-carl-what-this-key-is-called-63)
413 (cons (logior (lsh 1 16) 64) 'please-tell-carl-what-this-key-is-called-64)
414 (cons (logior (lsh 1 16) 69) 'please-tell-carl-what-this-key-is-called-69)
415 (cons (logior (lsh 1 16) 70) 'please-tell-carl-what-this-key-is-called-70)
416 (cons (logior (lsh 1 16) 71) 'please-tell-carl-what-this-key-is-called-71)
417 (cons (logior (lsh 1 16) 72) 'please-tell-carl-what-this-key-is-called-72)
418 (cons (logior (lsh 1 16) 73) 'please-tell-carl-what-this-key-is-called-73)
419 (cons (logior (lsh 2 16) 3) 'kp-enter)
420 (cons (logior (lsh 2 16) 9) 'kp-tab)
421 (cons (logior (lsh 2 16) 28) 'kp-quit)
422 (cons (logior (lsh 2 16) 35) 'kp-hash)
423 (cons (logior (lsh 2 16) 42) 'kp-multiply)
424 (cons (logior (lsh 2 16) 43) 'kp-add)
425 (cons (logior (lsh 2 16) 44) 'kp-separator)
426 (cons (logior (lsh 2 16) 45) 'kp-subtract)
427 (cons (logior (lsh 2 16) 46) 'kp-decimal)
428 (cons (logior (lsh 2 16) 47) 'kp-divide)
429 (cons (logior (lsh 2 16) 48) 'kp-0)
430 (cons (logior (lsh 2 16) 49) 'kp-1)
431 (cons (logior (lsh 2 16) 50) 'kp-2)
432 (cons (logior (lsh 2 16) 51) 'kp-3)
433 (cons (logior (lsh 2 16) 52) 'kp-4)
434 (cons (logior (lsh 2 16) 53) 'kp-5)
435 (cons (logior (lsh 2 16) 54) 'kp-6)
436 (cons (logior (lsh 2 16) 55) 'kp-7)
437 (cons (logior (lsh 2 16) 56) 'kp-8)
438 (cons (logior (lsh 2 16) 57) 'kp-9)
439 (cons (logior (lsh 2 16) 60) 'kp-less)
440 (cons (logior (lsh 2 16) 61) 'kp-equal)
441 (cons (logior (lsh 2 16) 62) 'kp-more)
442 (cons (logior (lsh 2 16) 64) 'kp-at)
443 (cons (logior (lsh 2 16) 92) 'kp-backslash)
444 (cons (logior (lsh 2 16) 96) 'kp-backtick)
445 (cons (logior (lsh 2 16) 124) 'kp-bar)
446 (cons (logior (lsh 2 16) 126) 'kp-tilde)
447 (cons (logior (lsh 2 16) 157) 'kp-mu)
448 (cons (logior (lsh 2 16) 165) 'kp-yen)
449 (cons (logior (lsh 2 16) 167) 'kp-paragraph)
450 (cons (logior (lsh 2 16) 172) 'left)
451 (cons (logior (lsh 2 16) 173) 'up)
452 (cons (logior (lsh 2 16) 174) 'right)
453 (cons (logior (lsh 2 16) 175) 'down)
454 (cons (logior (lsh 2 16) 176) 'kp-ring)
455 (cons (logior (lsh 2 16) 201) 'kp-square)
456 (cons (logior (lsh 2 16) 204) 'kp-cube)
457 (cons (logior (lsh 3 16) 8) 'backspace)
458 (cons (logior (lsh 3 16) 9) 'tab)
459 (cons (logior (lsh 3 16) 10) 'linefeed)
460 (cons (logior (lsh 3 16) 11) 'clear)
461 (cons (logior (lsh 3 16) 13) 'return)
462 (cons (logior (lsh 3 16) 18) 'pause)
463 (cons (logior (lsh 3 16) 25) 'S-tab)
464 (cons (logior (lsh 3 16) 27) 'escape)
465 (cons (logior (lsh 3 16) 127) 'delete)
467 (set-terminal-parameter frame 'x-setup-function-keys t))))
471 ;;;; Miscellaneous mouse bindings.
473 ;;; Allow shift-clicks to work just like under Nextstep
474 (defun mouse-extend-region (event)
475 "Move point or mark so as to extend region.
476 This should be bound to a mouse click event type."
478 (mouse-minibuffer-check event)
479 (let ((posn (event-end event)))
480 (if (not (windowp (posn-window posn)))
481 (error "Cursor not in text area of window"))
482 (select-window (posn-window posn))
484 ((not (numberp (posn-point posn))))
485 ((or (not mark-active) (> (abs (- (posn-point posn) (point)))
486 (abs (- (posn-point posn) (mark)))))
487 (let ((point-save (point)))
490 (goto-char (posn-point posn))
492 (or transient-mark-mode
494 (goto-char point-save))))
496 (goto-char (posn-point posn))))))
498 (define-key global-map [S-mouse-1] 'mouse-extend-region)
499 (global-unset-key [S-down-mouse-1])
503 ;; Must come after keybindings.
505 (fmakunbound 'clipboard-yank)
506 (fmakunbound 'clipboard-kill-ring-save)
507 (fmakunbound 'clipboard-kill-region)
508 (fmakunbound 'menu-bar-enable-clipboard)
510 ;; Add a couple of menus and rearrange some others; easiest just to redo toplvl
511 ;; Note keymap defns must be given last-to-first
512 (define-key global-map [menu-bar] (make-sparse-keymap "menu-bar"))
514 (setq menu-bar-final-items
515 (cond ((eq system-type 'darwin)
516 '(buffer windows services help-menu))
517 ;; Otherwise, GNUstep.
519 '(buffer windows services hide-app quit))))
521 ;; Add standard top-level items to GNUstep menu.
522 (unless (eq system-type 'darwin)
523 (define-key global-map [menu-bar quit] '("Quit" . save-buffers-kill-emacs))
524 (define-key global-map [menu-bar hide-app] '("Hide" . ns-do-hide-emacs)))
526 (define-key global-map [menu-bar services]
527 (cons "Services" (make-sparse-keymap "Services")))
528 (define-key global-map [menu-bar windows] (make-sparse-keymap "Windows"))
529 (define-key global-map [menu-bar buffer]
530 (cons "Buffers" global-buffers-menu-map))
531 ;; (cons "Buffers" (make-sparse-keymap "Buffers")))
532 (define-key global-map [menu-bar tools] (cons "Tools" menu-bar-tools-menu))
533 (define-key global-map [menu-bar options] (cons "Options" menu-bar-options-menu))
534 (define-key global-map [menu-bar edit] (cons "Edit" menu-bar-edit-menu))
535 (define-key global-map [menu-bar file] (cons "File" menu-bar-file-menu))
537 ;; If running under GNUstep, rename "Help" to "Info"
538 (cond ((eq system-type 'darwin)
539 (define-key global-map [menu-bar help-menu]
540 (cons "Help" menu-bar-help-menu)))
542 (let ((contents (reverse (cdr menu-bar-help-menu))))
543 (setq menu-bar-help-menu
544 (append (list 'keymap) (cdr contents) (list "Info"))))
545 (define-key global-map [menu-bar help-menu]
546 (cons "Info" menu-bar-help-menu))))
548 (if (not (eq system-type 'darwin))
549 ;; in OS X it's in the app menu already
550 (define-key menu-bar-help-menu [info-panel]
551 '("About Emacs..." . ns-do-emacs-info-panel)))
554 ;;;; File menu, replaces standard under ns-extended-platform-support
555 (defvar menu-bar-ns-file-menu (make-sparse-keymap "File"))
556 (define-key menu-bar-ns-file-menu [one-window]
557 '("Remove Splits" . delete-other-windows))
558 (define-key menu-bar-ns-file-menu [split-window]
559 '("Split Window" . split-window-vertically))
561 (define-key menu-bar-ns-file-menu [separator-print] '("--"))
563 (defvar ns-ps-print-menu-map (make-sparse-keymap "Postscript Print"))
564 (define-key ns-ps-print-menu-map [ps-print-region]
565 '("Region (B+W)" . ps-print-region))
566 (define-key ns-ps-print-menu-map [ps-print-buffer]
567 '("Buffer (B+W)" . ps-print-buffer))
568 (define-key ns-ps-print-menu-map [ps-print-region-faces]
569 '("Region" . ps-print-region-with-faces))
570 (define-key ns-ps-print-menu-map [ps-print-buffer-faces]
571 '("Buffer" . ps-print-buffer-with-faces))
572 (define-key menu-bar-ns-file-menu [postscript-print]
573 (cons "Postscript Print" ns-ps-print-menu-map))
575 (define-key menu-bar-ns-file-menu [print-region]
576 '("Print Region" . print-region))
577 (define-key menu-bar-ns-file-menu [print-buffer]
578 '("Print Buffer" . ns-print-buffer))
580 (define-key menu-bar-ns-file-menu [separator-save] '("--"))
582 (define-key menu-bar-ns-file-menu [recover-session]
583 '("Recover Crashed Session" . recover-session))
584 (define-key menu-bar-ns-file-menu [revert-buffer]
585 '("Revert Buffer" . revert-buffer))
586 (define-key menu-bar-ns-file-menu [write-file]
587 '("Save Buffer As..." . ns-write-file-using-panel))
588 (define-key menu-bar-ns-file-menu [save-buffer] '("Save Buffer" . save-buffer))
590 (define-key menu-bar-ns-file-menu [kill-buffer]
591 '("Kill Current Buffer" . kill-this-buffer))
592 (define-key menu-bar-ns-file-menu [delete-this-frame]
593 '("Close Frame" . delete-frame))
595 (define-key menu-bar-ns-file-menu [separator-open] '("--"))
597 (define-key menu-bar-ns-file-menu [insert-file]
598 '("Insert File..." . insert-file))
599 (define-key menu-bar-ns-file-menu [dired]
600 '("Open Directory..." . ns-open-file-using-panel))
601 (define-key menu-bar-ns-file-menu [open-file]
602 '("Open File..." . ns-open-file-using-panel))
603 (define-key menu-bar-ns-file-menu [make-frame]
604 '("New Frame" . make-frame))
607 ;;;; Edit menu: Modify slightly
609 ;; Substitute a Copy function that works better under X (for GNUstep).
610 (easy-menu-remove-item global-map '("menu-bar" "edit") 'copy)
611 (define-key-after menu-bar-edit-menu [copy]
612 '(menu-item "Copy" ns-copy-including-secondary
614 :help "Copy text in region between mark and current position")
617 ;; Change to same precondition as select-and-paste, as we don't have
618 ;; `x-selection-exists-p'.
619 (easy-menu-remove-item global-map '("menu-bar" "edit") 'paste)
620 (define-key-after menu-bar-edit-menu [paste]
621 '(menu-item "Paste" yank
622 :enable (and (cdr yank-menu) (not buffer-read-only))
623 :help "Paste (yank) text most recently cut/copied")
626 ;; Change text to be more consistent with surrounding menu items `paste', etc.
627 (easy-menu-remove-item global-map '("menu-bar" "edit") 'paste-from-menu)
628 (define-key-after menu-bar-edit-menu [select-paste]
629 '(menu-item "Select and Paste" yank-menu
630 :enable (and (cdr yank-menu) (not buffer-read-only))
631 :help "Choose a string from the kill ring and paste it")
634 ;; Separate undo from cut/paste section, add spell for platform consistency.
635 (define-key-after menu-bar-edit-menu [separator-undo] '("--") 'undo)
636 (define-key-after menu-bar-edit-menu [spell] '("Spell" . ispell-menu-map) 'fill)
640 (defun menu-bar-select-frame (&optional frame)
642 (make-frame-visible last-command-event)
643 (raise-frame last-command-event)
644 (select-frame last-command-event))
646 (defun menu-bar-update-frames ()
647 ;; If user discards the Windows item, play along.
648 (when (lookup-key (current-global-map) [menu-bar windows])
649 (let ((frames (frame-list))
650 (frames-menu (make-sparse-keymap "Select Frame")))
653 (mapcar (lambda (frame)
655 (cdr (assq 'name (frame-parameters frame)))
656 'menu-bar-select-frame))
659 (define-key frames-menu [separator-frames] '("--"))
660 (define-key frames-menu [popup-color-panel]
661 '("Colors..." . ns-popup-color-panel))
662 (define-key frames-menu [popup-font-panel]
663 '("Font Panel..." . ns-popup-font-panel))
664 (define-key frames-menu [separator-arrange] '("--"))
665 (define-key frames-menu [arrange-all-frames]
666 '("Arrange All Frames" . ns-arrange-all-frames))
667 (define-key frames-menu [arrange-visible-frames]
668 '("Arrange Visible Frames" . ns-arrange-visible-frames))
669 ;; Don't use delete-frame as event name
670 ;; because that is a special event.
671 (define-key (current-global-map) [menu-bar windows]
672 (cons "Windows" frames-menu)))))
674 (defun force-menu-bar-update-buffers ()
675 ;; This is a hack to get around fact that we already checked
676 ;; frame-or-buffer-changed-p and reset it, so menu-bar-update-buffers
677 ;; does not pick up any change.
678 (menu-bar-update-buffers t))
680 (add-hook 'menu-bar-update-fab-hook 'menu-bar-update-frames)
681 (add-hook 'menu-bar-update-fab-hook 'force-menu-bar-update-buffers)
683 (defun menu-bar-update-frames-and-buffers ()
684 (if (frame-or-buffer-changed-p)
685 (run-hooks 'menu-bar-update-fab-hook)))
687 (setq menu-bar-update-hook
688 (delq 'menu-bar-update-buffers menu-bar-update-hook))
689 (add-hook 'menu-bar-update-hook 'menu-bar-update-frames-and-buffers)
691 (menu-bar-update-frames-and-buffers)
694 ;; ns-arrange functions contributed
695 ;; by Eberhard Mandler <mandler@dbag.ulm.DaimlerBenz.COM>
696 (defun ns-arrange-all-frames ()
697 "Arranges all frames according to topline"
699 (ns-arrange-frames t))
701 (defun ns-arrange-visible-frames ()
702 "Arranges all visible frames according to topline"
704 (ns-arrange-frames nil))
706 (defun ns-arrange-frames ( vis)
707 (let ((frame (next-frame))
708 (end-frame (selected-frame))
709 (inc-x 20) ;relative position of frames
711 (x-pos 100) ;start position
714 (while (not done) ;cycle through all frames
715 (if (not (or vis (eq (frame-visible-p frame) t)))
716 (setq x-pos x-pos); do nothing; true case
717 (set-frame-position frame x-pos y-pos)
718 (setq x-pos (+ x-pos inc-x))
719 (setq y-pos (+ y-pos inc-y))
722 (setq frame (next-frame))
723 (setq done (equal frame end-frame)))
724 (set-frame-position end-frame x-pos y-pos)
726 (select-frame frame)))
730 (declare-function ns-perform-service "nsfns.m" (service send))
732 (defun ns-define-service (path)
733 (let ((mapping [menu-bar services])
734 (service (mapconcat 'identity path "/"))
736 (subst-char-in-string
738 (mapconcat 'identity (cons "ns-service" path) "-")))))
739 ;; This defines the function.
741 (lexical-let ((service service))
745 (cond ((stringp arg) arg)
747 (buffer-substring (region-beginning) (region-end)))))
748 (out-string (ns-perform-service service in-string)))
750 ((stringp arg) out-string)
751 ((and out-string (or (not in-string)
752 (not (string= in-string out-string))))
753 (if mark-active (delete-region (region-beginning) (region-end)))
755 (setq deactivate-mark nil)))))))
757 ((lookup-key global-map mapping)
759 (setq mapping (vconcat mapping (list (intern (car path)))))
760 (if (not (keymapp (lookup-key global-map mapping)))
761 (define-key global-map mapping
762 (cons (car path) (make-sparse-keymap (car path)))))
763 (setq path (cdr path)))
764 (setq mapping (vconcat mapping (list (intern (car path)))))
765 (define-key global-map mapping (cons (car path) name))))
768 (precompute-menubar-bindings)
771 (defvar ns-input-spi-name)
772 (defvar ns-input-spi-arg)
774 (defun ns-spi-service-call ()
775 "Respond to a service request."
777 (cond ((string-equal ns-input-spi-name "open-selection")
778 (switch-to-buffer (generate-new-buffer "*untitled*"))
779 (insert ns-input-spi-arg))
780 ((string-equal ns-input-spi-name "open-file")
781 (dnd-open-file ns-input-spi-arg nil))
782 ((string-equal ns-input-spi-name "mail-selection")
786 (insert ns-input-spi-arg))
787 ((string-equal ns-input-spi-name "mail-to")
788 (compose-mail ns-input-spi-arg))
789 (t (error (concat "Service " ns-input-spi-name " not recognized")))))
792 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
796 ;;;; Composed key sequence handling for Nextstep system input methods.
797 ;;;; (On Nextstep systems, input methods are provided for CJK
798 ;;;; characters, etc. which require multiple keystrokes, and during
799 ;;;; entry a partial ("working") result is typically shown in the
800 ;;;; editing window.)
802 (defface ns-working-text-face
804 "Face used to highlight working text during compose sequence insert."
807 (defvar ns-working-overlay nil
808 "Overlay used to highlight working text during compose sequence insert.")
809 (make-variable-buffer-local 'ns-working-overlay)
810 (defvar ns-working-overlay-len 0
811 "Length of working text during compose sequence insert.")
812 (make-variable-buffer-local 'ns-working-overlay-len)
814 ;; Based on mac-win.el 2007/08/26 unicode-2. This will fail if called
815 ;; from an "interactive" function.
816 (defun ns-in-echo-area ()
817 "Whether, for purposes of inserting working composition text, the minibuffer
818 is currently being used."
820 (and cursor-in-echo-area (current-message))
821 ;; Overlay strings are not shown in some cases.
822 (get-char-property (point) 'invisible)
824 (or (and (get-char-property (point) 'display)
825 (eq (get-char-property (1- (point)) 'display)
826 (get-char-property (point) 'display)))
827 (and (get-char-property (point) 'composition)
828 (eq (get-char-property (1- (point)) 'composition)
829 (get-char-property (point) 'composition)))))))
831 ;; Currently not used, doesn't work because the 'interactive' here stays
832 ;; for subinvocations.
833 (defun ns-insert-working-text ()
835 (if (ns-in-echo-area) (ns-echo-working-text) (ns-put-working-text)))
837 (defvar ns-working-text) ; nsterm.m
839 (defun ns-put-working-text ()
840 "Insert contents of ns-working-text as UTF8 string and mark with
841 ns-working-overlay. Any previously existing working text is cleared first.
842 The overlay is assigned the face ns-working-text-face."
844 (if ns-working-overlay (ns-delete-working-text))
845 (let ((start (point)))
846 (insert ns-working-text)
847 (overlay-put (setq ns-working-overlay (make-overlay start (point)
848 (current-buffer) nil t))
849 'face 'ns-working-text-face)
850 (setq ns-working-overlay-len (+ ns-working-overlay-len (- (point) start)))))
852 (defun ns-echo-working-text ()
853 "Echo contents of ns-working-text in message display area.
854 See ns-insert-working-text."
855 (if ns-working-overlay (ns-unecho-working-text))
856 (let* ((msg (current-message))
857 (msglen (length msg))
859 (setq ns-working-overlay-len (length ns-working-text))
860 (setq msg (concat msg ns-working-text))
861 (put-text-property msglen (+ msglen ns-working-overlay-len) 'face 'ns-working-text-face msg)
863 (setq ns-working-overlay t)))
865 (defun ns-delete-working-text()
866 "Delete working text and clear ns-working-overlay."
868 (delete-backward-char ns-working-overlay-len)
869 (setq ns-working-overlay-len 0)
870 (delete-overlay ns-working-overlay))
872 (defun ns-unecho-working-text()
873 "Delete working text from echo area and clear ns-working-overlay."
874 (let ((msg (current-message))
876 (setq msg (substring msg 0 (- (length msg) ns-working-overlay-len)))
877 (setq ns-working-overlay-len 0)
878 (setq ns-working-overlay nil)))
881 (declare-function ns-convert-utf8-nfd-to-nfc "nsfns.m" (str))
883 ;;;; OS X file system Unicode UTF-8 NFD (decomposed form) support
884 ;; Lisp code based on utf-8m.el, by Seiji Zenitani, Eiji Honjoh, and
886 (if (eq system-type 'darwin)
889 (defun ns-utf8-nfd-post-read-conversion (length)
890 "Calls ns-convert-utf8-nfd-to-nfc to compose char sequences."
893 (narrow-to-region (point) (+ (point) length))
894 (let ((str (buffer-string)))
895 (delete-region (point-min) (point-max))
896 (insert (ns-convert-utf8-nfd-to-nfc str))
897 (- (point-max) (point-min))
900 (define-coding-system 'utf-8-nfd
901 "UTF-8 NFD (decomposed) encoding."
904 :charset-list '(unicode)
905 :post-read-conversion 'ns-utf8-nfd-post-read-conversion)
906 (set-file-name-coding-system 'utf-8-nfd)))
908 ;; PENDING: disable composition-based display for Indic scripts as it
909 ;; is not working well under Nextstep for some reason
910 (set-char-table-range composition-function-table
911 '(#x0900 . #x0DFF) nil)
914 ;;;; Inter-app communications support.
916 (defvar ns-input-text) ; nsterm.m
918 (defun ns-insert-text ()
919 "Insert contents of ns-input-text at point."
921 (insert ns-input-text)
922 (setq ns-input-text nil))
924 (defun ns-insert-file ()
925 "Insert contents of file ns-input-file like insert-file but with less
926 prompting. If file is a directory perform a find-file on it."
929 (setq f (car ns-input-file))
930 (setq ns-input-file (cdr ns-input-file))
931 (if (file-directory-p f)
933 (push-mark (+ (point) (car (cdr (insert-file-contents f))))))))
935 (defvar ns-select-overlay nil
936 "Overlay used to highlight areas in files requested by Nextstep apps.")
937 (make-variable-buffer-local 'ns-select-overlay)
939 (defvar ns-input-line) ; nsterm.m
941 (defun ns-open-file-select-line ()
942 "Open a buffer containing the file `ns-input-file'.
943 Lines are highlighted according to `ns-input-line'."
947 ((and ns-input-line (buffer-modified-p))
948 (if ns-select-overlay
949 (setq ns-select-overlay (delete-overlay ns-select-overlay)))
951 (goto-line (if (consp ns-input-line)
952 (min (car ns-input-line) (cdr ns-input-line))
955 (if (not ns-select-overlay)
956 (overlay-put (setq ns-select-overlay (make-overlay (point-min) (point-min)))
958 (let ((beg (save-excursion
959 (goto-line (if (consp ns-input-line)
960 (min (car ns-input-line) (cdr ns-input-line))
964 (goto-line (+ 1 (if (consp ns-input-line)
965 (max (car ns-input-line) (cdr ns-input-line))
968 (move-overlay ns-select-overlay beg end)
972 (if ns-select-overlay
973 (setq ns-select-overlay (delete-overlay ns-select-overlay))))))
975 (defun ns-unselect-line ()
976 "Removes any Nextstep highlight a buffer may contain."
977 (if ns-select-overlay
978 (setq ns-select-overlay (delete-overlay ns-select-overlay))))
980 (add-hook 'first-change-hook 'ns-unselect-line)
984 ;;;; Preferences handling.
985 (declare-function ns-get-resource "nsfns.m" (owner name))
987 (defun get-lisp-resource (arg1 arg2)
988 (let ((res (ns-get-resource arg1 arg2)))
991 ((string-equal (upcase res) "YES") t)
992 ((string-equal (upcase res) "NO") nil)
996 (defvar ns-command-modifier)
997 (defvar ns-control-modifier)
998 (defvar ns-function-modifier)
999 (defvar ns-antialias-text)
1000 (defvar ns-use-qd-smoothing)
1001 (defvar ns-use-system-highlight-color)
1003 (declare-function ns-set-resource "nsfns.m" (owner name value))
1004 (declare-function ns-font-name "nsfns.m" (name))
1005 (declare-function ns-read-file-name "nsfns.m"
1006 (prompt &optional dir isLoad init))
1008 (defun ns-save-preferences ()
1009 "Set all the defaults."
1011 ;; Global preferences
1012 (ns-set-resource nil "AlternateModifier" (symbol-name ns-alternate-modifier))
1013 (ns-set-resource nil "CommandModifier" (symbol-name ns-command-modifier))
1014 (ns-set-resource nil "ControlModifier" (symbol-name ns-control-modifier))
1015 (ns-set-resource nil "FunctionModifier" (symbol-name ns-function-modifier))
1016 (ns-set-resource nil "CursorBlinkRate"
1017 (if ns-cursor-blink-rate
1018 (number-to-string ns-cursor-blink-rate)
1020 (ns-set-resource nil "ExpandSpace"
1022 (number-to-string ns-expand-space)
1024 (ns-set-resource nil "GSFontAntiAlias" (if ns-antialias-text "YES" "NO"))
1025 (ns-set-resource nil "UseQuickdrawSmoothing"
1026 (if ns-use-qd-smoothing "YES" "NO"))
1027 (ns-set-resource nil "UseSystemHighlightColor"
1028 (if ns-use-system-highlight-color "YES" "NO"))
1029 ;; Default frame parameters
1030 (let ((p (frame-parameters))
1032 (if (setq v (assq 'font p))
1033 (ns-set-resource nil "Font" (ns-font-name (cdr v))))
1034 (if (setq v (assq 'fontsize p))
1035 (ns-set-resource nil "FontSize" (number-to-string (cdr v))))
1036 (if (setq v (assq 'foreground-color p))
1037 (ns-set-resource nil "Foreground" (cdr v)))
1038 (if (setq v (assq 'background-color p))
1039 (ns-set-resource nil "Background" (cdr v)))
1040 (if (setq v (assq 'cursor-color p))
1041 (ns-set-resource nil "CursorColor" (cdr v)))
1042 (if (setq v (assq 'cursor-type p))
1043 (ns-set-resource nil "CursorType" (if (symbolp (cdr v))
1044 (symbol-name (cdr v))
1046 (if (setq v (assq 'underline p))
1047 (ns-set-resource nil "Underline"
1052 (if (setq v (assq 'internal-border-width p))
1053 (ns-set-resource nil "InternalBorderWidth"
1054 (number-to-string (cdr v))))
1055 (if (setq v (assq 'vertical-scroll-bars p))
1056 (ns-set-resource nil "VerticalScrollBars"
1063 (if (setq v (assq 'height p))
1064 (ns-set-resource nil "Height" (number-to-string (cdr v))))
1065 (if (setq v (assq 'width p))
1066 (ns-set-resource nil "Width" (number-to-string (cdr v))))
1067 (if (setq v (assq 'top p))
1068 (ns-set-resource nil "Top" (number-to-string (cdr v))))
1069 (if (setq v (assq 'left p))
1070 (ns-set-resource nil "Left" (number-to-string (cdr v))))
1071 ;; These not fully supported
1072 (if (setq v (assq 'auto-raise p))
1073 (ns-set-resource nil "AutoRaise" (if (cdr v) "YES" "NO")))
1074 (if (setq v (assq 'auto-lower p))
1075 (ns-set-resource nil "AutoLower" (if (cdr v) "YES" "NO")))
1076 (if (setq v (assq 'menu-bar-lines p))
1077 (ns-set-resource nil "Menus" (if (cdr v) "YES" "NO")))
1079 (let ((fl (face-list)))
1081 (or (eq 'default (car fl))
1082 ;; dont save Default* since it causes all created faces to
1083 ;; inherit its values. The properties of the default face
1084 ;; have already been saved from the frame-parameters anyway.
1085 (let* ((name (symbol-name (car fl)))
1086 (font (face-font (car fl)))
1087 ;; (fontsize (face-fontsize (car fl)))
1088 (foreground (face-foreground (car fl)))
1089 (background (face-background (car fl)))
1090 (underline (face-underline-p (car fl)))
1091 (italic (face-italic-p (car fl)))
1092 (bold (face-bold-p (car fl)))
1093 (stipple (face-stipple (car fl))))
1094 ;; (ns-set-resource nil (concat name ".attributeFont")
1095 ;; (if font font nil))
1096 ;; (ns-set-resource nil (concat name ".attributeFontSize")
1097 ;; (if fontsize (number-to-string fontsize) nil))
1098 (ns-set-resource nil (concat name ".attributeForeground")
1099 (if foreground foreground nil))
1100 (ns-set-resource nil (concat name ".attributeBackground")
1101 (if background background nil))
1102 (ns-set-resource nil (concat name ".attributeUnderline")
1103 (if underline "YES" nil))
1104 (ns-set-resource nil (concat name ".attributeItalic")
1105 (if italic "YES" nil))
1106 (ns-set-resource nil (concat name ".attributeBold")
1107 (if bold "YES" nil))
1109 (or (stringp stipple)
1110 (setq stipple (prin1-to-string stipple))))
1111 (ns-set-resource nil (concat name ".attributeStipple")
1112 (if stipple stipple nil))))
1113 (setq fl (cdr fl)))))
1115 (declare-function menu-bar-options-save-orig "ns-win" () t)
1117 ;; call ns-save-preferences when menu-bar-options-save is called
1118 (fset 'menu-bar-options-save-orig (symbol-function 'menu-bar-options-save))
1119 (defun ns-save-options ()
1121 (menu-bar-options-save-orig)
1122 (ns-save-preferences))
1123 (fset 'menu-bar-options-save (symbol-function 'ns-save-options))
1128 (defun ns-open-file-using-panel ()
1129 "Pop up open-file panel, and load the result in a buffer."
1131 ;; Prompt dir defaultName isLoad initial.
1132 (setq ns-input-file (ns-read-file-name "Select File to Load" nil t nil))
1134 (and (setq ns-input-file (list ns-input-file)) (ns-find-file))))
1136 (defun ns-write-file-using-panel ()
1137 "Pop up save-file panel, and save buffer in resulting name."
1139 (let (ns-output-file)
1140 ;; Prompt dir defaultName isLoad initial.
1141 (setq ns-output-file (ns-read-file-name "Save As" nil nil nil))
1142 (message ns-output-file)
1143 (if ns-output-file (write-file ns-output-file))))
1145 (defvar ns-pop-up-frames 'fresh
1146 "*Non-nil means open files upon request from the Workspace in a new frame.
1147 If t, always do so. Any other non-nil value means open a new frame
1148 unless the current buffer is a scratch buffer.")
1150 (declare-function ns-hide-emacs "nsfns.m" (on))
1152 (defun ns-find-file ()
1153 "Do a find-file with the ns-input-file as argument."
1155 (let ((f) (file) (bufwin1) (bufwin2))
1156 (setq f (file-truename (car ns-input-file)))
1157 (setq ns-input-file (cdr ns-input-file))
1158 (setq file (find-file-noselect f))
1159 (setq bufwin1 (get-buffer-window file 'visible))
1160 (setq bufwin2 (get-buffer-window "*scratch*" 'visibile))
1163 (select-frame (window-frame bufwin1))
1164 (raise-frame (window-frame bufwin1))
1165 (select-window bufwin1))
1166 ((and (eq ns-pop-up-frames 'fresh) bufwin2)
1167 (ns-hide-emacs 'activate)
1168 (select-frame (window-frame bufwin2))
1169 (raise-frame (window-frame bufwin2))
1170 (select-window bufwin2)
1173 (ns-hide-emacs 'activate)
1174 (let ((pop-up-frames t)) (pop-to-buffer file nil)))
1176 (ns-hide-emacs 'activate)
1181 ;;;; Frame-related functions.
1183 ;; Don't show the frame name; that's redundant with Nextstep.
1184 (setq-default mode-line-frame-identification '(" "))
1186 ;; You say tomAYto, I say tomAHto..
1187 (defvaralias 'ns-option-modifier 'ns-alternate-modifier)
1189 (defun ns-do-hide-emacs ()
1193 (declare-function ns-hide-others "nsfns.m" ())
1195 (defun ns-do-hide-others ()
1199 (declare-function ns-emacs-info-panel "nsfns.m" ())
1201 (defun ns-do-emacs-info-panel ()
1203 (ns-emacs-info-panel))
1205 (defun ns-next-frame ()
1206 "Switch to next visible frame."
1209 (defun ns-prev-frame ()
1210 "Switch to previous visible frame."
1214 ;; If no position specified, make new frame offset by 25 from current.
1215 (defvar parameters) ; dynamically bound in make-frame
1217 (add-hook 'before-make-frame-hook
1219 (let ((left (cdr (assq 'left (frame-parameters))))
1220 (top (cdr (assq 'top (frame-parameters)))))
1221 (if (consp left) (setq left (cadr left)))
1222 (if (consp top) (setq top (cadr top)))
1224 ((or (assq 'top parameters) (assq 'left parameters)))
1225 ((or (not left) (not top)))
1227 (setq parameters (cons (cons 'left (+ left 25))
1228 (cons (cons 'top (+ top 25))
1231 ;; frame will be focused anyway, so select it
1232 (add-hook 'after-make-frame-functions 'select-frame)
1234 ;; (defun ns-win-suspend-error ()
1235 ;; (error "Suspending an emacs running under *Step/OS X makes no sense"))
1236 ;; (add-hook 'suspend-hook 'ns-win-suspend-error)
1237 ;; (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
1240 ;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
1241 ;; see http://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html .
1242 (defun ns-toggle-toolbar (&optional frame)
1243 "Switches the tool bar on and off in frame FRAME.
1244 If FRAME is nil, the change applies to the selected frame."
1246 (modify-frame-parameters
1247 frame (list (cons 'tool-bar-lines
1248 (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
1250 (if (not tool-bar-mode) (tool-bar-mode t)))
1252 (defvar ns-cursor-blink-mode) ; nsterm.m
1254 ;; Redefine from frame.el.
1255 (define-minor-mode blink-cursor-mode
1256 "Toggle blinking cursor mode.
1257 With a numeric argument, turn blinking cursor mode on if ARG is positive,
1258 otherwise turn it off. When blinking cursor mode is enabled, the
1259 cursor of the selected window blinks.
1261 Note that this command is effective only when Emacs
1262 displays through a window system, because then Emacs does its own
1263 cursor display. On a text-only terminal, this is not implemented."
1264 :init-value (not (or noninteractive
1266 (eq ns-cursor-blink-rate nil)))
1267 :initialize 'custom-initialize-safe-default
1270 (if blink-cursor-mode
1271 (setq ns-cursor-blink-mode t)
1272 (setq ns-cursor-blink-mode nil)))
1276 ;;;; Dialog-related functions.
1278 ;; Ask user for confirm before printing. Due to Kevin Rodgers.
1279 (defun ns-print-buffer ()
1280 "Interactive front-end to `print-buffer': asks for user confirmation first."
1282 (if (and (interactive-p)
1283 (or (listp last-nonmenu-event)
1284 (and (char-or-string-p (event-basic-type last-command-event))
1285 (memq 'super (event-modifiers last-command-event)))))
1286 (let ((last-nonmenu-event (if (listp last-nonmenu-event)
1289 `(mouse-1 POSITION 1))))
1290 (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
1292 (error "Cancelled")))
1295 (defun ns-yes-or-no-p (prompt)
1296 "Ask user a \"yes or no\" question using a Nextstep graphical panel.
1297 PROMPT is the prompt string."
1299 (setq last-nonmenu-event nil)
1300 (yes-or-no-p prompt))
1305 ;; Needed for font listing functions under both backend and normal
1306 (setq scalable-fonts-allowed t)
1308 ;; Set to use font panel instead
1309 (defalias 'generate-fontset-menu 'ns-popup-font-panel)
1310 (defalias 'mouse-set-font 'ns-popup-font-panel)
1313 (defvar ns-input-font)
1314 (defvar ns-input-fontsize)
1316 (defun ns-respond-to-change-font ()
1317 "Respond to changeFont: event, expecting ns-input-font and\n\
1318 ns-input-fontsize of new font."
1320 (modify-frame-parameters (selected-frame)
1321 (list (cons 'font ns-input-font)
1322 (cons 'fontsize ns-input-fontsize)))
1323 (set-frame-font ns-input-font))
1326 ;; Default fontset for Mac OS X. This is mainly here to show how a fontset
1327 ;; can be set up manually. Ordinarily, fontsets are auto-created whenever
1328 ;; a font is chosen by
1329 (defvar ns-standard-fontset-spec
1330 ;; Only some code supports this so far, so use uglier XLFD version
1331 ;; "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
1332 (mapconcat 'identity
1333 '("-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard"
1334 "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1"
1335 "han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1"
1336 "cyrillic:-*-Trebuchet$MS-*-*-*-*-10-*-*-*-*-*-iso10646-1")
1338 "String of fontset spec of the standard fontset.
1339 This defines a fontset consisting of the Courier and other fonts that
1341 See the documentation of `create-fontset-from-fontset-spec for the format.")
1343 ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles.
1344 (if (fboundp 'new-fontset)
1346 ;; Setup the default fontset.
1347 (setup-default-fontset)
1348 ;; Create the standard fontset.
1349 (create-fontset-from-fontset-spec ns-standard-fontset-spec t)))
1351 ;;(push (cons 'font "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard")
1352 ;; default-frame-alist)
1354 ;; Add some additional scripts to var we use for fontset generation.
1355 (setq script-representative-chars
1356 (cons '(kana #xff8a)
1357 (cons '(symbol #x2295 #x2287 #x25a1)
1358 script-representative-chars)))
1361 ;;;; Pasteboard support.
1363 (declare-function ns-get-cut-buffer-internal "nsselect.m" (buffer))
1365 (defun ns-get-pasteboard ()
1366 "Returns the value of the pasteboard."
1367 (ns-get-cut-buffer-internal 'PRIMARY))
1369 (declare-function ns-store-cut-buffer-internal "nsselect.m" (buffer string))
1371 (defun ns-set-pasteboard (string)
1372 "Store STRING into the pasteboard of the Nextstep display server."
1373 ;; Check the data type of STRING.
1374 (if (not (stringp string)) (error "Nonstring given to pasteboard"))
1375 (ns-store-cut-buffer-internal 'PRIMARY string))
1377 ;; We keep track of the last text selected here, so we can check the
1378 ;; current selection against it, and avoid passing back our own text
1379 ;; from x-cut-buffer-or-selection-value.
1380 (defvar ns-last-selected-text nil)
1382 (defun x-select-text (text &optional push)
1383 "Put TEXT, a string, on the pasteboard."
1384 ;; Don't send the pasteboard too much text.
1385 ;; It becomes slow, and if really big it causes errors.
1386 (ns-set-pasteboard text)
1387 (setq ns-last-selected-text text))
1389 ;; Return the value of the current Nextstep selection. For
1390 ;; compatibility with older Nextstep applications, this checks cut
1391 ;; buffer 0 before retrieving the value of the primary selection.
1392 (defun x-cut-buffer-or-selection-value ()
1395 ;; Consult the selection, then the cut buffer. Treat empty strings
1396 ;; as if they were unset.
1397 (or text (setq text (ns-get-pasteboard)))
1398 (if (string= text "") (setq text nil))
1402 ((eq text ns-last-selected-text) nil)
1403 ((string= text ns-last-selected-text)
1404 ;; Record the newer string, so subsequent calls can use the `eq' test.
1405 (setq ns-last-selected-text text)
1408 (setq ns-last-selected-text text)))))
1410 (defun ns-copy-including-secondary ()
1412 (call-interactively 'kill-ring-save)
1413 (ns-store-cut-buffer-internal 'SECONDARY
1414 (buffer-substring (point) (mark t))))
1415 (defun ns-paste-secondary ()
1417 (insert (ns-get-cut-buffer-internal 'SECONDARY)))
1419 ;; PENDING: not sure what to do here.. for now interprog- are set in
1420 ;; init-fn-keys, and unsure whether these x- settings have an effect.
1421 ;;(setq interprogram-cut-function 'x-select-text
1422 ;; interprogram-paste-function 'x-cut-buffer-or-selection-value)
1423 ;; These only needed if above not working.
1425 (set-face-background 'region "ns_selection_color")
1429 ;;;; Scrollbar handling.
1431 (global-set-key [vertical-scroll-bar down-mouse-1] 'ns-handle-scroll-bar-event)
1432 (global-unset-key [vertical-scroll-bar mouse-1])
1433 (global-unset-key [vertical-scroll-bar drag-mouse-1])
1435 (defun ns-scroll-bar-move (event)
1436 "Scroll the frame according to an Nextstep scroller event."
1438 (let* ((pos (event-end event))
1439 (window (nth 0 pos))
1440 (scale (nth 2 pos)))
1442 (set-buffer (window-buffer window))
1444 ((eq (car scale) (cdr scale))
1445 (goto-char (point-max)))
1447 (goto-char (point-min)))
1449 (goto-char (+ (point-min) 1
1450 (scroll-bar-scale scale (- (point-max) (point-min)))))))
1452 (set-window-start window (point))
1453 (vertical-motion (/ (window-height window) 2) window))))
1455 (defun ns-handle-scroll-bar-event (event)
1456 "Handle scroll bar EVENT to emulate Mac Toolbox style scrolling."
1458 (let* ((position (event-start event))
1459 (bar-part (nth 4 position))
1460 (window (nth 0 position))
1461 (old-window (selected-window)))
1463 ((eq bar-part 'ratio)
1464 (ns-scroll-bar-move event))
1465 ((eq bar-part 'handle)
1466 (if (eq window (selected-window))
1467 (track-mouse (ns-scroll-bar-move event))
1468 ;; track-mouse faster for selected window, slower for unselected.
1469 (ns-scroll-bar-move event)))
1471 (select-window window)
1474 (goto-char (window-start window))
1476 ((eq bar-part 'above-handle)
1478 ((eq bar-part 'below-handle)
1480 ((eq bar-part 'down)
1481 (goto-char (window-start window))
1483 (select-window old-window)))))
1488 (declare-function ns-list-colors "nsfns.m" (&optional frame))
1490 (defvar x-colors (ns-list-colors)
1491 "The list of colors defined in non-PANTONE color files.")
1492 (defvar colors x-colors
1493 "The list of colors defined in non-PANTONE color files.")
1495 (defun xw-defined-colors (&optional frame)
1496 "Return a list of colors supported for a particular frame.
1497 The argument FRAME specifies which frame to try.
1498 The value may be different for frames on different Nextstep displays."
1499 (or frame (setq frame (selected-frame)))
1500 (let ((all-colors x-colors)
1502 (defined-colors nil))
1504 (setq this-color (car all-colors)
1505 all-colors (cdr all-colors))
1506 ;; (and (face-color-supported-p frame this-color t)
1507 (setq defined-colors (cons this-color defined-colors))) ;;)
1510 (declare-function ns-set-alpha "nsfns.m" (color alpha))
1512 ;; Convenience and work-around for fact that set color fns now require named.
1513 (defun ns-set-background-alpha (alpha)
1514 "Sets alpha (opacity) of background.
1515 Set from 0.0 (fully transparent) to 1.0 (fully opaque; default).
1516 Note, tranparency works better on Tiger (10.4) and higher."
1517 (interactive "nSet background alpha to: ")
1518 (let ((bgcolor (cdr (assq 'background-color (frame-parameters)))))
1519 (set-frame-parameter (selected-frame)
1520 'background-color (ns-set-alpha bgcolor alpha))))
1522 ;; Functions for color panel + drag
1523 (defun ns-face-at-pos (pos)
1524 (let* ((frame (car pos))
1525 (frame-pos (cons (cadr pos) (cddr pos)))
1526 (window (window-at (car frame-pos) (cdr frame-pos) frame))
1527 (window-pos (coordinates-in-window-p frame-pos window))
1528 (buffer (window-buffer window))
1529 (edges (window-edges window)))
1533 ((eq window-pos 'mode-line)
1535 ((eq window-pos 'vertical-line)
1540 (let ((p (car (compute-motion (window-start window)
1541 (cons (nth 0 edges) (nth 1 edges))
1544 (- (window-width window) 1)
1548 ((eq p (window-point window))
1550 ((and mark-active (< (region-beginning) p) (< p (region-end)))
1553 (let ((faces (get-char-property p 'face window)))
1554 (if (consp faces) (car faces) faces)))))))
1558 (defvar ns-input-color) ; nsterm.m
1560 (defun ns-set-foreground-at-mouse ()
1561 "Set the foreground color at the mouse location to ns-input-color."
1563 (let* ((pos (mouse-position))
1565 (face (ns-face-at-pos pos)))
1568 (modify-frame-parameters frame (list (cons 'cursor-color
1571 (modify-frame-parameters frame (list (cons 'foreground-color
1574 (set-face-foreground face ns-input-color frame)))))
1576 (defun ns-set-background-at-mouse ()
1577 "Set the background color at the mouse location to ns-input-color."
1579 (let* ((pos (mouse-position))
1581 (face (ns-face-at-pos pos)))
1584 (modify-frame-parameters frame (list (cons 'cursor-color
1587 (modify-frame-parameters frame (list (cons 'background-color
1590 (set-face-background face ns-input-color frame)))))
1592 ;; Set some options to be as Nextstep-like as possible.
1593 (setq frame-title-format t
1594 icon-title-format t)
1596 ;; Set up browser connectivity.
1597 (defvar browse-url-generic-program)
1599 (setq browse-url-browser-function 'browse-url-generic)
1600 (setq browse-url-generic-program
1601 (cond ((eq system-type 'darwin) "open")
1602 ;; Otherwise, GNUstep.
1606 (defvar ns-initialized nil
1607 "Non-nil if Nextstep windowing has been initialized.")
1609 (declare-function ns-list-services "nsfns.m" ())
1611 ;; Do the actual Nextstep Windows setup here; the above code just
1612 ;; defines functions and variables that we use now.
1613 (defun ns-initialize-window-system ()
1614 "Initialize Emacs for Nextstep (Cocoa / GNUstep) windowing."
1616 ;; PENDING: not needed?
1617 (setq command-line-args (ns-handle-args command-line-args))
1619 (x-open-connection (system-name) nil t)
1621 (dolist (service (ns-list-services))
1622 (if (eq (car service) 'undefined)
1623 (ns-define-service (cdr service))
1624 (define-key global-map (vector (car service))
1625 (ns-define-service (cdr service)))))
1627 (if (and (eq (get-lisp-resource nil "NXAutoLaunch") t)
1628 (eq (get-lisp-resource nil "HideOnAutoLaunch") t))
1629 (add-hook 'after-init-hook 'ns-do-hide-emacs))
1631 ;; FIXME: This will surely lead to "MODIFIED OUTSIDE CUSTOM" warnings.
1632 (menu-bar-mode (if (get-lisp-resource nil "Menus") 1 -1))
1633 (mouse-wheel-mode 1)
1635 (setq ns-initialized t))
1637 (add-to-list 'handle-args-function-alist '(ns . ns-handle-args))
1638 (add-to-list 'frame-creation-function-alist '(ns . x-create-frame-with-faces))
1639 (add-to-list 'window-system-initialization-alist '(ns . ns-initialize-window-system))
1644 ;; arch-tag: eb138a45-4e2e-4d68-b1c9-a39665731644
1645 ;;; ns-win.el ends here