* ns-grabenv.el: File removed.
[bpt/emacs.git] / lisp / term / ns-win.el
CommitLineData
c0642f6d
GM
1;;; ns-win.el --- lisp side of interface with NeXT/Open/GNUstep/MacOS X window system
2
3;; Copyright (C) 1993, 1994, 2005, 2006, 2008 Free Software Foundation, Inc.
4
5;; Author: Carl Edman, Christian Limpach, Scott Bender, Christophe de Dinechin, Adrian Robert
6;; Keywords: terminals
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
edfda783
AR
22
23;;; Commentary:
24
25;; ns-win.el: this file is loaded from ../lisp/startup.el when it recognizes
26;; that NS windows are to be used. Command line switches are parsed and those
27;; pertaining to NS are processed and removed from the command line. The
28;; NS display is opened and hooks are set for popping up the initial window.
29
30;; startup.el will then examine startup files, and eventually call the hooks
31;; which create the first window (s).
32
33;; A number of other NS convenience functions are defined in this file,
34;; which works in close coordination with src/nsfns.m.
35
36;;; Code:
37
38
39(if (not (featurep 'ns-windowing))
40 (error "%s: Loading ns-win.el but not compiled for *Step/OS X"
41 (invocation-name)))
42
ebe68042
SM
43(eval-when-compile (require 'cl))
44
edfda783
AR
45;; Documentation-purposes only: actually loaded in loadup.el
46(require 'frame)
47(require 'mouse)
48(require 'faces)
49(require 'easymenu)
50(require 'menu-bar)
51(require 'fontset)
52
ebe68042
SM
53;; Not needed?
54;;(require 'ispell)
edfda783 55
c0642f6d
GM
56;; nsterm.m
57(defvar ns-version-string)
58(defvar ns-expand-space)
59(defvar ns-cursor-blink-rate)
60(defvar ns-alternate-modifier)
61
62(declare-function ns-server-vendor "nsfns.m" (&optional display))
63(declare-function ns-server-version "nsfns.m" (&optional display))
64
edfda783 65(defun ns-submit-bug-report ()
ebe68042
SM
66 "Submit via mail a bug report on Emacs 23.0.0 for GNUstep / OS X."
67 (interactive)
68 (let ((frame-parameters (frame-parameters))
69 (server-vendor (ns-server-vendor))
70 (server-version (ns-server-version)))
71 (reporter-submit-bug-report
72 "Adrian Robert <Adrian.B.Robert@gmail.com>"
73 ;;"Christophe de Dinechin <descubes@earthlink.net>"
74 ;;"Scott Bender <emacs@harmony-ds.com>"
75 ;;"Christian Limpach <chris@nice.ch>"
76 ;;"Carl Edman <cedman@princeton.edu>"
77 (concat "Emacs for GNUstep / OS X " ns-version-string)
78 '(ns-expand-space ns-cursor-blink-rate ns-alternate-modifier
79 data-directory frame-parameters window-system window-system-version
80 server-vendor server-version system-configuration-options))))
edfda783
AR
81
82
83;;;; Command line argument handling.
84
85(defvar ns-invocation-args nil)
86(defvar ns-command-line-resources nil)
87
88;; Handler for switches of the form "-switch value" or "-switch".
d377ef4a 89(defun ns-handle-switch (switch &optional numeric)
edfda783
AR
90 (let ((aelt (assoc switch command-line-ns-option-alist)))
91 (if aelt
d377ef4a
GM
92 (setq default-frame-alist
93 (cons (cons (nth 3 aelt)
94 (if numeric
95 (string-to-number (pop ns-invocation-args))
96 (or (nth 4 aelt) (pop ns-invocation-args))))
97 default-frame-alist)))))
edfda783
AR
98
99;; Handler for switches of the form "-switch n"
100(defun ns-handle-numeric-switch (switch)
d377ef4a 101 (ns-handle-switch switch t))
edfda783
AR
102
103;; Make -iconic apply only to the initial frame!
104(defun ns-handle-iconic (switch)
105 (setq initial-frame-alist
106 (cons '(visibility . icon) initial-frame-alist)))
107
108;; Handle the -name option, set the name of
109;; the initial frame.
110(defun ns-handle-name-switch (switch)
111 (or (consp ns-invocation-args)
112 (error "%s: missing argument to `%s' option" (invocation-name) switch))
d377ef4a
GM
113 (setq initial-frame-alist (cons (cons 'name (pop ns-invocation-args))
114 initial-frame-alist)))
115
116;; Set (but not used?) in frame.el.
117(defvar ns-display-name nil
118 "The name of the NS display on which Emacs was started.")
edfda783 119
c0642f6d
GM
120;; nsterm.m.
121(defvar ns-input-file)
122
edfda783
AR
123(defun ns-handle-nxopen (switch)
124 (setq unread-command-events (append unread-command-events '(ns-open-file))
d377ef4a 125 ns-input-file (append ns-input-file (list (pop ns-invocation-args)))))
edfda783
AR
126
127(defun ns-handle-nxopentemp (switch)
d377ef4a
GM
128 (setq unread-command-events (append unread-command-events
129 '(ns-open-temp-file))
130 ns-input-file (append ns-input-file (list (pop ns-invocation-args)))))
edfda783
AR
131
132(defun ns-ignore-0-arg (switch)
133 )
134(defun ns-ignore-1-arg (switch)
135 (setq ns-invocation-args (cdr ns-invocation-args)))
136(defun ns-ignore-2-arg (switch)
137 (setq ns-invocation-args (cddr ns-invocation-args)))
138
139(defun ns-handle-args (args)
140 "Here the NS-related command line options in ARGS are processed,
141before the user's startup file is loaded. They are copied to
142`ns-invocation-args', from which the NS related things are extracted, first
143the switch (e.g., \"-fg\") in the following code, and possible values
144\(e.g., \"black\") in the option handler code (e.g., ns-handle-switch).
145This function returns ARGS minus the arguments that have been processed."
146 ;; We use ARGS to accumulate the args that we don't handle here, to return.
147 (setq ns-invocation-args args
148 args nil)
149 (while ns-invocation-args
d377ef4a 150 (let* ((this-switch (pop ns-invocation-args))
edfda783
AR
151 (orig-this-switch this-switch)
152 completion argval aelt handler)
edfda783
AR
153 ;; Check for long options with attached arguments
154 ;; and separate out the attached option argument into argval.
155 (if (string-match "^--[^=]*=" this-switch)
156 (setq argval (substring this-switch (match-end 0))
157 this-switch (substring this-switch 0 (1- (match-end 0)))))
158 ;; Complete names of long options.
159 (if (string-match "^--" this-switch)
160 (progn
161 (setq completion (try-completion this-switch
162 command-line-ns-option-alist))
163 (if (eq completion t)
164 ;; Exact match for long option.
165 nil
166 (if (stringp completion)
167 (let ((elt (assoc completion command-line-ns-option-alist)))
168 ;; Check for abbreviated long option.
169 (or elt
170 (error "Option `%s' is ambiguous" this-switch))
171 (setq this-switch completion))))))
172 (setq aelt (assoc this-switch command-line-ns-option-alist))
173 (if aelt (setq handler (nth 2 aelt)))
174 (if handler
175 (if argval
176 (let ((ns-invocation-args
177 (cons argval ns-invocation-args)))
178 (funcall handler this-switch))
179 (funcall handler this-switch))
180 (setq args (cons orig-this-switch args)))))
181 (nreverse args))
182
183(defun x-parse-geometry (geom)
184 "Parse an NS-style geometry string STRING.
185Returns an alist of the form ((top . TOP), (left . LEFT) ... ).
186The properties returned may include `top', `left', `height', and `width'."
187 (if (string-match "\\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\) ?\\)?\\)?\\)?"
188 geom)
189 (apply 'append
ebe68042
SM
190 (list
191 (list (cons 'top (string-to-number (match-string 1 geom))))
192 (if (match-string 3 geom)
193 (list (cons 'left (string-to-number (match-string 3 geom)))))
194 (if (match-string 5 geom)
195 (list (cons 'height (string-to-number (match-string 5 geom)))))
196 (if (match-string 7 geom)
197 (list (cons 'width (string-to-number (match-string 7 geom)))))))
edfda783
AR
198 '()))
199
200
201
202;;;; Keyboard mapping.
203
204;; These tell read-char how to convert
205;; these special chars to ASCII.
206(put 'backspace 'ascii-character 127)
207(put 'delete 'ascii-character 127)
208(put 'tab 'ascii-character ?\t)
209(put 'S-tab 'ascii-character (logior 16 ?\t))
210(put 'linefeed 'ascii-character ?\n)
211(put 'clear 'ascii-character 12)
212(put 'return 'ascii-character 13)
213(put 'escape 'ascii-character ?\e)
214
215;; Map certain keypad keys into ASCII characters
216;; that people usually expect.
217(define-key function-key-map [backspace] [127])
218(define-key function-key-map [delete] [127])
219(define-key function-key-map [tab] [?\t])
220(define-key function-key-map [S-tab] [25])
221(define-key function-key-map [linefeed] [?\n])
222(define-key function-key-map [clear] [11])
223(define-key function-key-map [return] [13])
224(define-key function-key-map [escape] [?\e])
225(define-key function-key-map [M-backspace] [?\M-\d])
226(define-key function-key-map [M-delete] [?\M-\d])
227(define-key function-key-map [M-tab] [?\M-\t])
228(define-key function-key-map [M-linefeed] [?\M-\n])
229(define-key function-key-map [M-clear] [?\M-\013])
230(define-key function-key-map [M-return] [?\M-\015])
231(define-key function-key-map [M-escape] [?\M-\e])
232
233
234;; Here are some NeXTSTEP like bindings for command key sequences.
235(define-key global-map [?\s-,] 'ns-popup-prefs-panel)
236(define-key global-map [?\s-'] 'next-multiframe-window)
237(define-key global-map [?\s-`] 'other-frame)
238(define-key global-map [?\s--] 'center-line)
239(define-key global-map [?\s-:] 'ispell)
240(define-key global-map [?\s-\;] 'ispell-next)
241(define-key global-map [?\s-?] 'info)
242(define-key global-map [?\s-^] 'kill-some-buffers)
243(define-key global-map [?\s-&] 'kill-this-buffer)
244(define-key global-map [?\s-C] 'ns-popup-color-panel)
245(define-key global-map [?\s-D] 'dired)
246(define-key global-map [?\s-E] 'edit-abbrevs)
247(define-key global-map [?\s-L] 'shell-command)
248(define-key global-map [?\s-M] 'manual-entry)
249(define-key global-map [?\s-S] 'ns-write-file-using-panel)
250(define-key global-map [?\s-a] 'mark-whole-buffer)
251(define-key global-map [?\s-c] 'ns-copy-including-secondary)
252(define-key global-map [?\s-d] 'isearch-repeat-backward)
253(define-key global-map [?\s-e] 'isearch-yank-kill)
254(define-key global-map [?\s-f] 'isearch-forward)
255(define-key global-map [?\s-g] 'isearch-repeat-forward)
256(define-key global-map [?\s-h] 'ns-do-hide-emacs)
257(define-key global-map [?\s-H] 'ns-do-hide-others)
258(define-key global-map [?\s-j] 'exchange-point-and-mark)
259(define-key global-map [?\s-k] 'kill-this-buffer)
260(define-key global-map [?\s-l] 'goto-line)
261(define-key global-map [?\s-m] 'iconify-frame)
262(define-key global-map [?\s-n] 'make-frame)
263(define-key global-map [?\s-o] 'ns-open-file-using-panel)
264(define-key global-map [?\s-p] 'ns-print-buffer)
265(define-key global-map [?\s-q] 'save-buffers-kill-emacs)
266(define-key global-map [?\s-s] 'save-buffer)
267(define-key global-map [?\s-t] 'ns-popup-font-panel)
268(define-key global-map [?\s-u] 'revert-buffer)
269(define-key global-map [?\s-v] 'yank)
270(define-key global-map [?\s-w] 'delete-frame)
271(define-key global-map [?\s-x] 'kill-region)
272(define-key global-map [?\s-y] 'ns-paste-secondary)
273(define-key global-map [?\s-z] 'undo)
274(define-key global-map [?\s-|] 'shell-command-on-region)
275(define-key global-map [s-kp-bar] 'shell-command-on-region)
ebe68042 276;; (as in Terminal.app)
edfda783
AR
277(define-key global-map [s-right] 'ns-next-frame)
278(define-key global-map [s-left] 'ns-prev-frame)
279
280(define-key global-map [home] 'beginning-of-buffer)
281(define-key global-map [end] 'end-of-buffer)
282(define-key global-map [kp-home] 'beginning-of-buffer)
283(define-key global-map [kp-end] 'end-of-buffer)
284(define-key global-map [kp-prior] 'scroll-down)
285(define-key global-map [kp-next] 'scroll-up)
286
287
288;; Special NeXTSTEP generated events are converted to function keys. Here
289;; are the bindings for them.
290(define-key global-map [ns-power-off]
ebe68042 291 (lambda () (interactive) (save-buffers-kill-emacs t)))
edfda783
AR
292(define-key global-map [ns-open-file] 'ns-find-file)
293(define-key global-map [ns-open-temp-file] [ns-open-file])
294(define-key global-map [ns-drag-file] 'ns-insert-file)
295(define-key global-map [ns-drag-color] 'ns-set-foreground-at-mouse)
296(define-key global-map [S-ns-drag-color] 'ns-set-background-at-mouse)
297(define-key global-map [ns-drag-text] 'ns-insert-text)
298(define-key global-map [ns-change-font] 'ns-respond-to-change-font)
299(define-key global-map [ns-open-file-line] 'ns-open-file-select-line)
300(define-key global-map [ns-insert-working-text] 'ns-insert-working-text)
301(define-key global-map [ns-delete-working-text] 'ns-delete-working-text)
302(define-key global-map [ns-spi-service-call] 'ns-spi-service-call)
303
304
305
306;;;; Lisp niceties, most used only under ns-extended-platform-support-mode,
307;;;; defined below
308
309(autoload 'ns-grabenv "ns-grabenv" "Get environment from your shell." t nil)
2f93961f
CY
310
311;; Set up a number of aliases and other layers to pretend we're using
312;; the Choi/Mitsuharu Carbon port.
313
314(defvaralias 'mac-allow-anti-aliasing 'ns-antialias-text)
315(defvaralias 'mac-command-modifier 'ns-command-modifier)
316(defvaralias 'mac-control-modifier 'ns-control-modifier)
317(defvaralias 'mac-option-modifier 'ns-option-modifier)
318(defvaralias 'mac-function-modifier 'ns-function-modifier)
edfda783
AR
319
320;; alt-up/down scrolling a la Stuart.app
321;; only activated if ns-extended-platform-support is on
322(defun up-one () (interactive) (scroll-up 1))
323(defun down-one () (interactive) (scroll-down 1))
324(defun left-one () (interactive) (scroll-left 1))
325(defun right-one () (interactive) (scroll-right 1))
326
c0642f6d
GM
327(defvar menu-bar-ns-file-menu) ; below
328
edfda783
AR
329;; Toggle some additional NS-like features that may interfere with users'
330;; expectations coming from emacs on other platforms.
331(define-minor-mode ns-extended-platform-support-mode
332 "Toggle NS extended platform support features.
333 When this mode is active (no modeline indicator):
38f4308d 334 - File menu is altered slightly in keeping with conventions.
edfda783 335 - Meta-up, meta-down are bound to scroll window up and down one line.
38f4308d
AR
336 - Screen position is preserved in scrolling.
337 - Transient mark mode is activated"
edfda783
AR
338 :init-value nil
339 :global t
340 :group 'ns
341 (if ns-extended-platform-support-mode
342 (progn
ebe68042
SM
343 (global-set-key [M-up] 'down-one)
344 (global-set-key [M-down] 'up-one)
345 ;; These conflict w/word-left, word-right.
346 ;;(global-set-key [M-left] 'left-one)
347 ;;(global-set-key [M-right] 'right-one)
348
349 (setq scroll-preserve-screen-position t)
350 (transient-mark-mode 1)
351
352 ;; Change file menu to simplify and add a couple of NS-specific items
353 (easy-menu-remove-item global-map '("menu-bar") 'file)
354 (easy-menu-add-item global-map '(menu-bar)
355 (cons "File" menu-bar-ns-file-menu) 'edit))
edfda783 356 (progn
ebe68042
SM
357 ;; Undo everything above.
358 (global-unset-key [M-up])
359 (global-unset-key [M-down])
360 (setq scroll-preserve-screen-position nil)
361 (transient-mark-mode 0)
362 (easy-menu-remove-item global-map '("menu-bar") 'file)
363 (easy-menu-add-item global-map '(menu-bar)
364 (cons "File" menu-bar-file-menu) 'edit))))
edfda783
AR
365
366
367(defun x-setup-function-keys (frame)
368 "Set up function Keys for NS for given FRAME."
369 (unless (terminal-parameter frame 'x-setup-function-keys)
370 (with-selected-frame frame
371 (setq interprogram-cut-function 'ns-select-text
372 interprogram-paste-function 'ns-pasteboard-value)
ebe68042
SM
373 ;; (let ((map (copy-keymap x-alternatives-map)))
374 ;; (set-keymap-parent map (keymap-parent local-function-key-map))
375 ;; (set-keymap-parent local-function-key-map map))
376 (setq system-key-alist
377 (list
378 (cons (logior (lsh 0 16) 1) 'ns-power-off)
379 (cons (logior (lsh 0 16) 2) 'ns-open-file)
380 (cons (logior (lsh 0 16) 3) 'ns-open-temp-file)
381 (cons (logior (lsh 0 16) 4) 'ns-drag-file)
382 (cons (logior (lsh 0 16) 5) 'ns-drag-color)
383 (cons (logior (lsh 0 16) 6) 'ns-drag-text)
384 (cons (logior (lsh 0 16) 7) 'ns-change-font)
385 (cons (logior (lsh 0 16) 8) 'ns-open-file-line)
386 (cons (logior (lsh 0 16) 9) 'ns-insert-working-text)
387 (cons (logior (lsh 0 16) 10) 'ns-delete-working-text)
388 (cons (logior (lsh 0 16) 11) 'ns-spi-service-call)
389 (cons (logior (lsh 1 16) 32) 'f1)
390 (cons (logior (lsh 1 16) 33) 'f2)
391 (cons (logior (lsh 1 16) 34) 'f3)
392 (cons (logior (lsh 1 16) 35) 'f4)
393 (cons (logior (lsh 1 16) 36) 'f5)
394 (cons (logior (lsh 1 16) 37) 'f6)
395 (cons (logior (lsh 1 16) 38) 'f7)
396 (cons (logior (lsh 1 16) 39) 'f8)
397 (cons (logior (lsh 1 16) 40) 'f9)
398 (cons (logior (lsh 1 16) 41) 'f10)
399 (cons (logior (lsh 1 16) 42) 'f11)
400 (cons (logior (lsh 1 16) 43) 'f12)
401 (cons (logior (lsh 1 16) 44) 'kp-insert)
402 (cons (logior (lsh 1 16) 45) 'kp-delete)
403 (cons (logior (lsh 1 16) 46) 'kp-home)
404 (cons (logior (lsh 1 16) 47) 'kp-end)
405 (cons (logior (lsh 1 16) 48) 'kp-prior)
406 (cons (logior (lsh 1 16) 49) 'kp-next)
407 (cons (logior (lsh 1 16) 50) 'print-screen)
408 (cons (logior (lsh 1 16) 51) 'scroll-lock)
409 (cons (logior (lsh 1 16) 52) 'pause)
410 (cons (logior (lsh 1 16) 53) 'system)
411 (cons (logior (lsh 1 16) 54) 'break)
412 (cons (logior (lsh 1 16) 56) 'please-tell-carl-what-this-key-is-called-56)
413 (cons (logior (lsh 1 16) 61) 'please-tell-carl-what-this-key-is-called-61)
414 (cons (logior (lsh 1 16) 62) 'please-tell-carl-what-this-key-is-called-62)
415 (cons (logior (lsh 1 16) 63) 'please-tell-carl-what-this-key-is-called-63)
416 (cons (logior (lsh 1 16) 64) 'please-tell-carl-what-this-key-is-called-64)
417 (cons (logior (lsh 1 16) 69) 'please-tell-carl-what-this-key-is-called-69)
418 (cons (logior (lsh 1 16) 70) 'please-tell-carl-what-this-key-is-called-70)
419 (cons (logior (lsh 1 16) 71) 'please-tell-carl-what-this-key-is-called-71)
420 (cons (logior (lsh 1 16) 72) 'please-tell-carl-what-this-key-is-called-72)
421 (cons (logior (lsh 1 16) 73) 'please-tell-carl-what-this-key-is-called-73)
422 (cons (logior (lsh 2 16) 3) 'kp-enter)
423 (cons (logior (lsh 2 16) 9) 'kp-tab)
424 (cons (logior (lsh 2 16) 28) 'kp-quit)
425 (cons (logior (lsh 2 16) 35) 'kp-hash)
426 (cons (logior (lsh 2 16) 42) 'kp-multiply)
427 (cons (logior (lsh 2 16) 43) 'kp-add)
428 (cons (logior (lsh 2 16) 44) 'kp-separator)
429 (cons (logior (lsh 2 16) 45) 'kp-subtract)
430 (cons (logior (lsh 2 16) 46) 'kp-decimal)
431 (cons (logior (lsh 2 16) 47) 'kp-divide)
432 (cons (logior (lsh 2 16) 48) 'kp-0)
433 (cons (logior (lsh 2 16) 49) 'kp-1)
434 (cons (logior (lsh 2 16) 50) 'kp-2)
435 (cons (logior (lsh 2 16) 51) 'kp-3)
436 (cons (logior (lsh 2 16) 52) 'kp-4)
437 (cons (logior (lsh 2 16) 53) 'kp-5)
438 (cons (logior (lsh 2 16) 54) 'kp-6)
439 (cons (logior (lsh 2 16) 55) 'kp-7)
440 (cons (logior (lsh 2 16) 56) 'kp-8)
441 (cons (logior (lsh 2 16) 57) 'kp-9)
442 (cons (logior (lsh 2 16) 60) 'kp-less)
443 (cons (logior (lsh 2 16) 61) 'kp-equal)
444 (cons (logior (lsh 2 16) 62) 'kp-more)
445 (cons (logior (lsh 2 16) 64) 'kp-at)
446 (cons (logior (lsh 2 16) 92) 'kp-backslash)
447 (cons (logior (lsh 2 16) 96) 'kp-backtick)
448 (cons (logior (lsh 2 16) 124) 'kp-bar)
449 (cons (logior (lsh 2 16) 126) 'kp-tilde)
450 (cons (logior (lsh 2 16) 157) 'kp-mu)
451 (cons (logior (lsh 2 16) 165) 'kp-yen)
452 (cons (logior (lsh 2 16) 167) 'kp-paragraph)
453 (cons (logior (lsh 2 16) 172) 'left)
454 (cons (logior (lsh 2 16) 173) 'up)
455 (cons (logior (lsh 2 16) 174) 'right)
456 (cons (logior (lsh 2 16) 175) 'down)
457 (cons (logior (lsh 2 16) 176) 'kp-ring)
458 (cons (logior (lsh 2 16) 201) 'kp-square)
459 (cons (logior (lsh 2 16) 204) 'kp-cube)
460 (cons (logior (lsh 3 16) 8) 'backspace)
461 (cons (logior (lsh 3 16) 9) 'tab)
462 (cons (logior (lsh 3 16) 10) 'linefeed)
463 (cons (logior (lsh 3 16) 11) 'clear)
464 (cons (logior (lsh 3 16) 13) 'return)
465 (cons (logior (lsh 3 16) 18) 'pause)
466 (cons (logior (lsh 3 16) 25) 'S-tab)
467 (cons (logior (lsh 3 16) 27) 'escape)
468 (cons (logior (lsh 3 16) 127) 'delete)
469 ))
470 (set-terminal-parameter frame 'x-setup-function-keys t))))
edfda783
AR
471
472
473
474;;;; Miscellaneous mouse bindings.
475
476;;; Allow shift-clicks to work just like under NS
477(defun mouse-extend-region (event)
478 "Move point or mark so as to extend region.
479This should be bound to a mouse click event type."
480 (interactive "e")
481 (mouse-minibuffer-check event)
482 (let ((posn (event-end event)))
483 (if (not (windowp (posn-window posn)))
484 (error "Cursor not in text area of window"))
485 (select-window (posn-window posn))
486 (cond
487 ((not (numberp (posn-point posn))))
488 ((or (not mark-active) (> (abs (- (posn-point posn) (point)))
489 (abs (- (posn-point posn) (mark)))))
490 (let ((point-save (point)))
491 (unwind-protect
492 (progn
493 (goto-char (posn-point posn))
494 (push-mark nil t t)
495 (or transient-mark-mode
496 (sit-for 1)))
497 (goto-char point-save))))
498 (t
499 (goto-char (posn-point posn))))))
500
501(define-key global-map [S-mouse-1] 'mouse-extend-region)
502(global-unset-key [S-down-mouse-1])
503
504
505
ebe68042 506;; Must come after keybindings.
edfda783
AR
507
508(fmakunbound 'clipboard-yank)
509(fmakunbound 'clipboard-kill-ring-save)
510(fmakunbound 'clipboard-kill-region)
511(fmakunbound 'menu-bar-enable-clipboard)
512
513;; Add a couple of menus and rearrange some others; easiest just to redo toplvl
514;; Note keymap defns must be given last-to-first
515(define-key global-map [menu-bar] (make-sparse-keymap "menu-bar"))
516
ebe68042
SM
517(setq menu-bar-final-items
518 (cond ((eq system-type 'darwin)
519 '(buffer windows services help-menu))
520 ;; Otherwise, GNUstep.
521 (t
522 '(buffer windows services hide-app quit))))
edfda783 523
ebe68042
SM
524;; Add standard top-level items to GNUstep menu.
525(unless (eq system-type 'darwin)
526 (define-key global-map [menu-bar quit] '("Quit" . save-buffers-kill-emacs))
527 (define-key global-map [menu-bar hide-app] '("Hide" . ns-do-hide-emacs)))
edfda783
AR
528
529(define-key global-map [menu-bar services]
530 (cons "Services" (make-sparse-keymap "Services")))
531(define-key global-map [menu-bar windows] (make-sparse-keymap "Windows"))
532(define-key global-map [menu-bar buffer]
533 (cons "Buffers" global-buffers-menu-map))
534;; (cons "Buffers" (make-sparse-keymap "Buffers")))
535(define-key global-map [menu-bar tools] (cons "Tools" menu-bar-tools-menu))
536(define-key global-map [menu-bar options] (cons "Options" menu-bar-options-menu))
537(define-key global-map [menu-bar edit] (cons "Edit" menu-bar-edit-menu))
538(define-key global-map [menu-bar file] (cons "File" menu-bar-file-menu))
539
540;; If running under GNUstep, rename "Help" to "Info"
541(cond ((eq system-type 'darwin)
542 (define-key global-map [menu-bar help-menu]
543 (cons "Help" menu-bar-help-menu)))
544 (t
545 (let ((contents (reverse (cdr menu-bar-help-menu))))
546 (setq menu-bar-help-menu
547 (append (list 'keymap) (cdr contents) (list "Info"))))
548 (define-key global-map [menu-bar help-menu]
549 (cons "Info" menu-bar-help-menu))))
550
551
552;;;; Add to help / info menu
553(defun info-ns-emacs ()
554 "Jump to ns-emacs info item."
555 (interactive)
556 (info "ns-emacs"))
557
558(define-key menu-bar-help-menu [ns-bug-report]
559 '("Report Emacs.app bug..." . ns-submit-bug-report))
560(define-key menu-bar-help-menu [info-ns]
561 '("Emacs.app Manual" . info-ns-emacs))
562(if (not (eq system-type 'darwin))
563 ;; in OS X it's in the app menu already
564 (define-key menu-bar-help-menu [info-panel]
565 '("About Emacs..." . ns-do-emacs-info-panel)))
566
567
568;;;; File menu, replaces standard under ns-extended-platform-support
569(defvar menu-bar-ns-file-menu (make-sparse-keymap "File"))
570(define-key menu-bar-ns-file-menu [one-window]
571 '("Remove Splits" . delete-other-windows))
572(define-key menu-bar-ns-file-menu [split-window]
573 '("Split Window" . split-window-vertically))
574
575(define-key menu-bar-ns-file-menu [separator-print] '("--"))
576
577(defvar ns-ps-print-menu-map (make-sparse-keymap "Postscript Print"))
578(define-key ns-ps-print-menu-map [ps-print-region]
579 '("Region (B+W)" . ps-print-region))
580(define-key ns-ps-print-menu-map [ps-print-buffer]
581 '("Buffer (B+W)" . ps-print-buffer))
582(define-key ns-ps-print-menu-map [ps-print-region-faces]
583 '("Region" . ps-print-region-with-faces))
584(define-key ns-ps-print-menu-map [ps-print-buffer-faces]
585 '("Buffer" . ns-ps-print-buffer-with-faces))
586(define-key menu-bar-ns-file-menu [postscript-print]
587 (cons "Postscript Print" ns-ps-print-menu-map))
588
589(define-key menu-bar-ns-file-menu [print-region]
590 '("Print Region" . print-region))
591(define-key menu-bar-ns-file-menu [print-buffer]
592 '("Print Buffer" . ns-print-buffer))
593
594(define-key menu-bar-ns-file-menu [separator-save] '("--"))
595
596(define-key menu-bar-ns-file-menu [recover-session]
597 '("Recover Crashed Session" . recover-session))
598(define-key menu-bar-ns-file-menu [revert-buffer]
599 '("Revert Buffer" . revert-buffer))
600(define-key menu-bar-ns-file-menu [write-file]
601 '("Save Buffer As..." . ns-write-file-using-panel))
602(define-key menu-bar-ns-file-menu [save-buffer] '("Save Buffer" . save-buffer))
603
604(define-key menu-bar-ns-file-menu [kill-buffer]
605 '("Kill Current Buffer" . kill-this-buffer))
606(define-key menu-bar-ns-file-menu [delete-this-frame]
607 '("Close Frame" . delete-frame))
608
609(define-key menu-bar-ns-file-menu [separator-open] '("--"))
610
611(define-key menu-bar-ns-file-menu [insert-file]
612 '("Insert File..." . insert-file))
613(define-key menu-bar-ns-file-menu [dired]
614 '("Open Directory..." . ns-open-file-using-panel))
615(define-key menu-bar-ns-file-menu [open-file]
616 '("Open File..." . ns-open-file-using-panel))
617(define-key menu-bar-ns-file-menu [make-frame]
618 '("New Frame" . make-frame))
619
620
621;;;; Edit menu: Modify slightly
622
ebe68042 623;; Substitute a Copy function that works better under X (for GNUstep).
edfda783
AR
624(easy-menu-remove-item global-map '("menu-bar" "edit") 'copy)
625(define-key-after menu-bar-edit-menu [copy]
626 '(menu-item "Copy" ns-copy-including-secondary
ebe68042
SM
627 :enable mark-active
628 :help "Copy text in region between mark and current position")
edfda783
AR
629 'cut)
630
ebe68042
SM
631;; Change to same precondition as select-and-paste, as we don't have
632;; `x-selection-exists-p'.
edfda783
AR
633(easy-menu-remove-item global-map '("menu-bar" "edit") 'paste)
634(define-key-after menu-bar-edit-menu [paste]
635 '(menu-item "Paste" yank
ebe68042
SM
636 :enable (and (cdr yank-menu) (not buffer-read-only))
637 :help "Paste (yank) text most recently cut/copied")
edfda783
AR
638 'copy)
639
ebe68042 640;; Change text to be more consistent with surrounding menu items `paste', etc.
edfda783
AR
641(easy-menu-remove-item global-map '("menu-bar" "edit") 'paste-from-menu)
642(define-key-after menu-bar-edit-menu [select-paste]
643 '(menu-item "Select and Paste" yank-menu
ebe68042
SM
644 :enable (and (cdr yank-menu) (not buffer-read-only))
645 :help "Choose a string from the kill ring and paste it")
edfda783
AR
646 'paste)
647
ebe68042 648;; Separate undo from cut/paste section, add spell for platform consistency.
edfda783
AR
649(define-key-after menu-bar-edit-menu [separator-undo] '("--") 'undo)
650(define-key-after menu-bar-edit-menu [spell] '("Spell" . ispell-menu-map) 'fill)
651
652
653;;;; Windows menu
d377ef4a 654(defun menu-bar-select-frame (&optional frame)
edfda783
AR
655 (interactive)
656 (make-frame-visible last-command-event)
657 (raise-frame last-command-event)
658 (select-frame last-command-event))
659
660(defun menu-bar-update-frames ()
661 ;; If user discards the Windows item, play along.
ebe68042
SM
662 (when (lookup-key (current-global-map) [menu-bar windows])
663 (let ((frames (frame-list))
664 (frames-menu (make-sparse-keymap "Select Frame")))
665 (setcdr frames-menu
666 (nconc
667 (mapcar (lambda (frame)
668 (list* frame
669 (cdr (assq 'name (frame-parameters frame)))
670 'menu-bar-select-frame))
671 frames)
672 (cdr frames-menu)))
673 (define-key frames-menu [separator-frames] '("--"))
674 (define-key frames-menu [popup-color-panel]
675 '("Colors..." . ns-popup-color-panel))
676 (define-key frames-menu [popup-font-panel]
677 '("Font Panel..." . ns-popup-font-panel))
678 (define-key frames-menu [separator-arrange] '("--"))
679 (define-key frames-menu [arrange-all-frames]
680 '("Arrange All Frames" . ns-arrange-all-frames))
681 (define-key frames-menu [arrange-visible-frames]
682 '("Arrange Visible Frames" . ns-arrange-visible-frames))
683 ;; Don't use delete-frame as event name
684 ;; because that is a special event.
685 (define-key (current-global-map) [menu-bar windows]
686 (cons "Windows" frames-menu)))))
edfda783
AR
687
688(defun force-menu-bar-update-buffers ()
689 ;; This is a hack to get around fact that we already checked
690 ;; frame-or-buffer-changed-p and reset it, so menu-bar-update-buffers
691 ;; does not pick up any change.
692 (menu-bar-update-buffers t))
693
694(add-hook 'menu-bar-update-fab-hook 'menu-bar-update-frames)
695(add-hook 'menu-bar-update-fab-hook 'force-menu-bar-update-buffers)
696
697(defun menu-bar-update-frames-and-buffers ()
698 (if (frame-or-buffer-changed-p)
699 (run-hooks 'menu-bar-update-fab-hook)))
700
701(setq menu-bar-update-hook
702 (delq 'menu-bar-update-buffers menu-bar-update-hook))
703(add-hook 'menu-bar-update-hook 'menu-bar-update-frames-and-buffers)
704
705(menu-bar-update-frames-and-buffers)
706
707
708;; ns-arrange functions contributed
709;; by Eberhard Mandler <mandler@dbag.ulm.DaimlerBenz.COM>
710(defun ns-arrange-all-frames ()
711 "Arranges all frames according to topline"
712 (interactive)
713 (ns-arrange-frames t))
714
715(defun ns-arrange-visible-frames ()
716 "Arranges all visible frames according to topline"
717 (interactive)
718 (ns-arrange-frames nil))
719
720(defun ns-arrange-frames ( vis)
721 (let ((frame (next-frame))
722 (end-frame (selected-frame))
723 (inc-x 20) ;relative position of frames
724 (inc-y 22)
725 (x-pos 100) ;start position
726 (y-pos 40)
727 (done nil))
728 (while (not done) ;cycle through all frames
729 (if (not (or vis (eq (frame-visible-p frame) t)))
ebe68042 730 (setq x-pos x-pos); do nothing; true case
edfda783
AR
731 (set-frame-position frame x-pos y-pos)
732 (setq x-pos (+ x-pos inc-x))
733 (setq y-pos (+ y-pos inc-y))
734 (raise-frame frame))
735 (select-frame frame)
736 (setq frame (next-frame))
737 (setq done (equal frame end-frame)))
738 (set-frame-position end-frame x-pos y-pos)
739 (raise-frame frame)
740 (select-frame frame)))
741
742
743;;;; Services
d377ef4a
GM
744(declare-function ns-perform-service "nsfns.m" (service send))
745
edfda783
AR
746(defun ns-define-service (path)
747 (let ((mapping [menu-bar services])
748 (service (mapconcat 'identity path "/"))
749 (name (intern
ebe68042
SM
750 (subst-char-in-string
751 ?\s ?-
752 (mapconcat 'identity (cons "ns-service" path) "-")))))
753 ;; This defines the function.
754 (defalias name
755 (lexical-let ((service service))
756 (lambda (arg)
757 (interactive "p")
758 (let* ((in-string
759 (cond ((stringp arg) arg)
760 (mark-active
761 (buffer-substring (region-beginning) (region-end)))))
762 (out-string (ns-perform-service service in-string)))
763 (cond
764 ((stringp arg) out-string)
765 ((and out-string (or (not in-string)
766 (not (string= in-string out-string))))
767 (if mark-active (delete-region (region-beginning) (region-end)))
768 (insert out-string)
769 (setq deactivate-mark nil)))))))
edfda783
AR
770 (cond
771 ((lookup-key global-map mapping)
772 (while (cdr path)
773 (setq mapping (vconcat mapping (list (intern (car path)))))
774 (if (not (keymapp (lookup-key global-map mapping)))
775 (define-key global-map mapping
776 (cons (car path) (make-sparse-keymap (car path)))))
777 (setq path (cdr path)))
778 (setq mapping (vconcat mapping (list (intern (car path)))))
779 (define-key global-map mapping (cons (car path) name))))
780 name))
781
782(precompute-menubar-bindings)
783
c0642f6d
GM
784;; nsterm.m
785(defvar ns-input-spi-name)
786(defvar ns-input-spi-arg)
787
edfda783
AR
788(defun ns-spi-service-call ()
789 "Respond to a service request to Emacs.app."
790 (interactive)
791 (cond ((string-equal ns-input-spi-name "open-selection")
792 (switch-to-buffer (generate-new-buffer "*untitled*"))
793 (insert ns-input-spi-arg))
794 ((string-equal ns-input-spi-name "open-file")
795 (dnd-open-file ns-input-spi-arg nil))
796 ((string-equal ns-input-spi-name "mail-selection")
797 (compose-mail)
798 (rfc822-goto-eoh)
799 (forward-line 1)
800 (insert ns-input-spi-arg))
801 ((string-equal ns-input-spi-name "mail-to")
802 (compose-mail ns-input-spi-arg))
803 (t (error (concat "Service " ns-input-spi-name " not recognized")))))
804
805
806;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
807
808
809
810;;;; Composed key sequence handling for NS system input methods.
811;;;; (On NS systems, input methods are provided for CJK characters,
812;;;; etc. which require multiple keystrokes, and during entry a
813;;;; partial ("working") result is typically shown in the editing window.)
814
815(defface ns-working-text-face
816 '((t :underline t))
817 "Face used to highlight working text during compose sequence insert."
818 :group 'ns)
819
820(defvar ns-working-overlay nil
821 "Overlay used to highlight working text during compose sequence insert.")
822(make-variable-buffer-local 'ns-working-overlay)
823(defvar ns-working-overlay-len 0
824 "Length of working text during compose sequence insert.")
825(make-variable-buffer-local 'ns-working-overlay-len)
826
ebe68042
SM
827;; Based on mac-win.el 2007/08/26 unicode-2. This will fail if called
828;; from an "interactive" function.
edfda783
AR
829(defun ns-in-echo-area ()
830 "Whether, for purposes of inserting working composition text, the minibuffer
831is currently being used."
832 (or isearch-mode
833 (and cursor-in-echo-area (current-message))
834 ;; Overlay strings are not shown in some cases.
835 (get-char-property (point) 'invisible)
836 (and (not (bobp))
837 (or (and (get-char-property (point) 'display)
838 (eq (get-char-property (1- (point)) 'display)
839 (get-char-property (point) 'display)))
840 (and (get-char-property (point) 'composition)
841 (eq (get-char-property (1- (point)) 'composition)
842 (get-char-property (point) 'composition)))))))
843
ebe68042
SM
844;; Currently not used, doesn't work because the 'interactive' here stays
845;; for subinvocations.
edfda783
AR
846(defun ns-insert-working-text ()
847 (interactive)
848 (if (ns-in-echo-area) (ns-echo-working-text) (ns-put-working-text)))
849
c0642f6d
GM
850(defvar ns-working-text) ; nsterm.m
851
edfda783
AR
852(defun ns-put-working-text ()
853 "Insert contents of ns-working-text as UTF8 string and mark with
854ns-working-overlay. Any previously existing working text is cleared first.
855The overlay is assigned the face ns-working-text-face."
856 (interactive)
857 (if ns-working-overlay (ns-delete-working-text))
858 (let ((start (point)))
859 (insert ns-working-text)
860 (overlay-put (setq ns-working-overlay (make-overlay start (point)
861 (current-buffer) nil t))
862 'face 'ns-working-text-face)
863 (setq ns-working-overlay-len (+ ns-working-overlay-len (- (point) start)))))
864
865(defun ns-echo-working-text ()
866 "Echo contents of ns-working-text in message display area.
867See ns-insert-working-text."
868 (if ns-working-overlay (ns-unecho-working-text))
869 (let* ((msg (current-message))
870 (msglen (length msg))
871 message-log-max)
872 (setq ns-working-overlay-len (length ns-working-text))
873 (setq msg (concat msg ns-working-text))
874 (put-text-property msglen (+ msglen ns-working-overlay-len) 'face 'ns-working-text-face msg)
875 (message "%s" msg)
876 (setq ns-working-overlay t)))
877
878(defun ns-delete-working-text()
879 "Delete working text and clear ns-working-overlay."
880 (interactive)
881 (delete-backward-char ns-working-overlay-len)
882 (setq ns-working-overlay-len 0)
883 (delete-overlay ns-working-overlay))
884
885(defun ns-unecho-working-text()
886 "Delete working text from echo area and clear ns-working-overlay."
887 (let ((msg (current-message))
888 message-log-max)
889 (setq msg (substring msg 0 (- (length msg) ns-working-overlay-len)))
890 (setq ns-working-overlay-len 0)
891 (setq ns-working-overlay nil)))
892
893
c0642f6d
GM
894(declare-function ns-convert-utf8-nfd-to-nfc "nsfns.m" (str))
895
edfda783
AR
896;;;; OS X file system Unicode UTF-8 NFD (decomposed form) support
897;; Lisp code based on utf-8m.el, by Seiji Zenitani, Eiji Honjoh, and
898;; Carsten Bormann.
899(if (eq system-type 'darwin)
900 (progn
901
902 (defun ns-utf8-nfd-post-read-conversion (length)
903 "Calls ns-convert-utf8-nfd-to-nfc to compose char sequences."
904 (save-excursion
905 (save-restriction
906 (narrow-to-region (point) (+ (point) length))
907 (let ((str (buffer-string)))
908 (delete-region (point-min) (point-max))
909 (insert (ns-convert-utf8-nfd-to-nfc str))
910 (- (point-max) (point-min))
911 ))))
912
913 (define-coding-system 'utf-8-nfd
914 "UTF-8 NFD (decomposed) encoding."
915 :coding-type 'utf-8
916 :mnemonic ?U
917 :charset-list '(unicode)
918 :post-read-conversion 'ns-utf8-nfd-post-read-conversion)
919 (set-file-name-coding-system 'utf-8-nfd)))
920
921;; PENDING: disable composition-based display for Indic scripts as it
d377ef4a 922;; is not working well under NS for some reason
edfda783 923(set-char-table-range composition-function-table
ebe68042 924 '(#x0900 . #x0DFF) nil)
edfda783
AR
925
926
927;;;; Inter-app communications support.
928
c0642f6d
GM
929(defvar ns-input-text) ; nsterm.m
930
edfda783
AR
931(defun ns-insert-text ()
932 "Insert contents of ns-input-text at point."
933 (interactive)
934 (insert ns-input-text)
935 (setq ns-input-text nil))
c0642f6d 936
edfda783
AR
937(defun ns-insert-file ()
938 "Insert contents of file ns-input-file like insert-file but with less
939prompting. If file is a directory perform a find-file on it."
940 (interactive)
941 (let ((f))
942 (setq f (car ns-input-file))
943 (setq ns-input-file (cdr ns-input-file))
944 (if (file-directory-p f)
945 (find-file f)
946 (push-mark (+ (point) (car (cdr (insert-file-contents f))))))))
947
948(defvar ns-select-overlay nil
949 "Overlay used to highlight areas in files requested by NS apps.")
950(make-variable-buffer-local 'ns-select-overlay)
951
c0642f6d
GM
952(defvar ns-input-line) ; nsterm.m
953
edfda783
AR
954(defun ns-open-file-select-line ()
955 "Brings up a buffer containing file ns-input-file,\n\
956and highlights lines indicated by ns-input-line."
957 (interactive)
958 (ns-find-file)
959 (cond
960 ((and ns-input-line (buffer-modified-p))
961 (if ns-select-overlay
962 (setq ns-select-overlay (delete-overlay ns-select-overlay)))
963 (deactivate-mark)
964 (goto-line (if (consp ns-input-line)
965 (min (car ns-input-line) (cdr ns-input-line))
966 ns-input-line)))
967 (ns-input-line
968 (if (not ns-select-overlay)
969 (overlay-put (setq ns-select-overlay (make-overlay (point-min) (point-min)))
970 'face 'highlight))
971 (let ((beg (save-excursion
972 (goto-line (if (consp ns-input-line)
973 (min (car ns-input-line) (cdr ns-input-line))
974 ns-input-line))
975 (point)))
976 (end (save-excursion
977 (goto-line (+ 1 (if (consp ns-input-line)
978 (max (car ns-input-line) (cdr ns-input-line))
979 ns-input-line)))
980 (point))))
981 (move-overlay ns-select-overlay beg end)
982 (deactivate-mark)
983 (goto-char beg)))
984 (t
985 (if ns-select-overlay
986 (setq ns-select-overlay (delete-overlay ns-select-overlay))))))
987
988(defun ns-unselect-line ()
989 "Removes any NS highlight a buffer may contain."
990 (if ns-select-overlay
991 (setq ns-select-overlay (delete-overlay ns-select-overlay))))
992
993(add-hook 'first-change-hook 'ns-unselect-line)
994
995
996
997;;;; Preferences handling.
c0642f6d 998(declare-function ns-get-resource "nsfns.m" (owner name))
edfda783
AR
999
1000(defun get-lisp-resource (arg1 arg2)
1001 (let ((res (ns-get-resource arg1 arg2)))
1002 (cond
1003 ((not res) 'unbound)
1004 ((string-equal (upcase res) "YES") t)
1005 ((string-equal (upcase res) "NO") nil)
1006 (t (read res)))))
1007
c0642f6d
GM
1008;; nsterm.m
1009(defvar ns-command-modifier)
1010(defvar ns-control-modifier)
1011(defvar ns-function-modifier)
1012(defvar ns-antialias-text)
1013(defvar ns-use-qd-smoothing)
1014(defvar ns-use-system-highlight-color)
1015
1016(declare-function ns-set-resource "nsfns.m" (owner name value))
1017(declare-function ns-font-name "nsfns.m" (name))
1018(declare-function ns-read-file-name "nsfns.m"
1019 (prompt &optional dir isLoad init))
1020
edfda783
AR
1021(defun ns-save-preferences ()
1022 "Set all the defaults."
1023 (interactive)
1024 ;; Global preferences
1025 (ns-set-resource nil "AlternateModifier" (symbol-name ns-alternate-modifier))
1026 (ns-set-resource nil "CommandModifier" (symbol-name ns-command-modifier))
1027 (ns-set-resource nil "ControlModifier" (symbol-name ns-control-modifier))
1028 (ns-set-resource nil "FunctionModifier" (symbol-name ns-function-modifier))
1029 (ns-set-resource nil "CursorBlinkRate"
ebe68042
SM
1030 (if ns-cursor-blink-rate
1031 (number-to-string ns-cursor-blink-rate)
1032 "NO"))
edfda783 1033 (ns-set-resource nil "ExpandSpace"
ebe68042
SM
1034 (if ns-expand-space
1035 (number-to-string ns-expand-space)
1036 "NO"))
edfda783
AR
1037 (ns-set-resource nil "GSFontAntiAlias" (if ns-antialias-text "YES" "NO"))
1038 (ns-set-resource nil "UseQuickdrawSmoothing"
1039 (if ns-use-qd-smoothing "YES" "NO"))
1040 (ns-set-resource nil "UseSystemHighlightColor"
1041 (if ns-use-system-highlight-color "YES" "NO"))
1042 ;; Default frame parameters
d377ef4a
GM
1043 (let ((p (frame-parameters))
1044 v)
1045 (if (setq v (assq 'font p))
1046 (ns-set-resource nil "Font" (ns-font-name (cdr v))))
1047 (if (setq v (assq 'fontsize p))
1048 (ns-set-resource nil "FontSize" (number-to-string (cdr v))))
1049 (if (setq v (assq 'foreground-color p))
1050 (ns-set-resource nil "Foreground" (cdr v)))
1051 (if (setq v (assq 'background-color p))
1052 (ns-set-resource nil "Background" (cdr v)))
1053 (if (setq v (assq 'cursor-color p))
1054 (ns-set-resource nil "CursorColor" (cdr v)))
1055 (if (setq v (assq 'cursor-type p))
1056 (ns-set-resource nil "CursorType" (if (symbolp (cdr v))
1057 (symbol-name (cdr v))
1058 (cdr v))))
1059 (if (setq v (assq 'underline p))
1060 (ns-set-resource nil "Underline"
1061 (case (cdr v)
1062 ((t) "YES")
1063 ((nil) "NO")
1064 (t (cdr v)))))
1065 (if (setq v (assq 'internal-border-width p))
1066 (ns-set-resource nil "InternalBorderWidth"
1067 (number-to-string v)))
1068 (if (setq v (assq 'vertical-scroll-bars p))
1069 (ns-set-resource nil "VerticalScrollBars"
1070 (case (cdr v)
1071 ((t) "YES")
1072 ((nil) "NO")
1073 ((left) "left")
1074 ((right) "right")
1075 (t nil))))
1076 (if (setq v (assq 'height p))
1077 (ns-set-resource nil "Height" (number-to-string (cdr v))))
1078 (if (setq v (assq 'width p))
1079 (ns-set-resource nil "Width" (number-to-string (cdr v))))
1080 (if (setq v (assq 'top p))
1081 (ns-set-resource nil "Top" (number-to-string (cdr v))))
1082 (if (setq v (assq 'left p))
1083 (ns-set-resource nil "Left" (number-to-string (cdr v))))
edfda783 1084 ;; These not fully supported
d377ef4a
GM
1085 (if (setq v (assq 'auto-raise p))
1086 (ns-set-resource nil "AutoRaise" (if (cdr v) "YES" "NO")))
1087 (if (setq v (assq 'auto-lower p))
1088 (ns-set-resource nil "AutoLower" (if (cdr v) "YES" "NO")))
1089 (if (setq v (assq 'menu-bar-lines p))
1090 (ns-set-resource nil "Menus" (if (cdr v) "YES" "NO")))
edfda783
AR
1091 )
1092 (let ((fl (face-list)))
1093 (while (consp fl)
1094 (or (eq 'default (car fl))
1095 ;; dont save Default* since it causes all created faces to
1096 ;; inherit its values. The properties of the default face
1097 ;; have already been saved from the frame-parameters anyway.
1098 (let* ((name (symbol-name (car fl)))
1099 (font (face-font (car fl)))
ebe68042 1100 ;; (fontsize (face-fontsize (car fl)))
edfda783
AR
1101 (foreground (face-foreground (car fl)))
1102 (background (face-background (car fl)))
1103 (underline (face-underline-p (car fl)))
1104 (italic (face-italic-p (car fl)))
1105 (bold (face-bold-p (car fl)))
1106 (stipple (face-stipple (car fl))))
ebe68042
SM
1107 ;; (ns-set-resource nil (concat name ".attributeFont")
1108 ;; (if font font nil))
1109 ;; (ns-set-resource nil (concat name ".attributeFontSize")
1110 ;; (if fontsize (number-to-string fontsize) nil))
edfda783 1111 (ns-set-resource nil (concat name ".attributeForeground")
ebe68042 1112 (if foreground foreground nil))
edfda783 1113 (ns-set-resource nil (concat name ".attributeBackground")
ebe68042 1114 (if background background nil))
edfda783 1115 (ns-set-resource nil (concat name ".attributeUnderline")
ebe68042 1116 (if underline "YES" nil))
edfda783 1117 (ns-set-resource nil (concat name ".attributeItalic")
ebe68042 1118 (if italic "YES" nil))
edfda783 1119 (ns-set-resource nil (concat name ".attributeBold")
ebe68042 1120 (if bold "YES" nil))
edfda783
AR
1121 (and stipple
1122 (or (stringp stipple)
1123 (setq stipple (prin1-to-string stipple))))
1124 (ns-set-resource nil (concat name ".attributeStipple")
ebe68042 1125 (if stipple stipple nil))))
edfda783
AR
1126 (setq fl (cdr fl)))))
1127
c0642f6d
GM
1128(declare-function menu-bar-options-save-orig "ns-win" () t)
1129
edfda783
AR
1130;; call ns-save-preferences when menu-bar-options-save is called
1131(fset 'menu-bar-options-save-orig (symbol-function 'menu-bar-options-save))
1132(defun ns-save-options ()
1133 (interactive)
1134 (menu-bar-options-save-orig)
1135 (ns-save-preferences))
1136(fset 'menu-bar-options-save (symbol-function 'ns-save-options))
1137
1138
1139;;;; File handling.
1140
1141(defun ns-open-file-using-panel ()
1142 "Pop up open-file panel, and load the result in a buffer."
1143 (interactive)
ebe68042 1144 ;; Prompt dir defaultName isLoad initial.
edfda783
AR
1145 (setq ns-input-file (ns-read-file-name "Select File to Load" nil t nil))
1146 (if ns-input-file
1147 (and (setq ns-input-file (list ns-input-file)) (ns-find-file))))
1148
1149(defun ns-write-file-using-panel ()
1150 "Pop up save-file panel, and save buffer in resulting name."
1151 (interactive)
1152 (let (ns-output-file)
ebe68042 1153 ;; Prompt dir defaultName isLoad initial.
edfda783
AR
1154 (setq ns-output-file (ns-read-file-name "Save As" nil nil nil))
1155 (message ns-output-file)
1156 (if ns-output-file (write-file ns-output-file))))
1157
c0642f6d
GM
1158(defvar ns-pop-up-frames 'fresh
1159 "*Non-nil means open files upon request from the Workspace in a new frame.
1160If t, always do so. Any other non-nil value means open a new frame
1161unless the current buffer is a scratch buffer.")
1162
1163(declare-function ns-hide-emacs "nsfns.m" (on))
1164
edfda783
AR
1165(defun ns-find-file ()
1166 "Do a find-file with the ns-input-file as argument."
1167 (interactive)
1168 (let ((f) (file) (bufwin1) (bufwin2))
1169 (setq f (file-truename (car ns-input-file)))
1170 (setq ns-input-file (cdr ns-input-file))
1171 (setq file (find-file-noselect f))
1172 (setq bufwin1 (get-buffer-window file 'visible))
1173 (setq bufwin2 (get-buffer-window "*scratch*" 'visibile))
1174 (cond
1175 (bufwin1
1176 (select-frame (window-frame bufwin1))
1177 (raise-frame (window-frame bufwin1))
1178 (select-window bufwin1))
1179 ((and (eq ns-pop-up-frames 'fresh) bufwin2)
1180 (ns-hide-emacs 'activate)
1181 (select-frame (window-frame bufwin2))
1182 (raise-frame (window-frame bufwin2))
1183 (select-window bufwin2)
1184 (find-file f))
1185 (ns-pop-up-frames
1186 (ns-hide-emacs 'activate)
1187 (let ((pop-up-frames t)) (pop-to-buffer file nil)))
1188 (t
1189 (ns-hide-emacs 'activate)
1190 (find-file f)))))
1191
1192
1193
1194;;;; Frame-related functions.
1195
1196;; Don't show the frame name; that's redundant with NS.
1197(setq-default mode-line-frame-identification '(" "))
1198
edfda783
AR
1199;; You say tomAYto, I say tomAHto..
1200(defvaralias 'ns-option-modifier 'ns-alternate-modifier)
1201
1202(defun ns-do-hide-emacs ()
1203 (interactive)
1204 (ns-hide-emacs t))
1205
c0642f6d
GM
1206(declare-function ns-hide-others "nsfns.m" ())
1207
edfda783
AR
1208(defun ns-do-hide-others ()
1209 (interactive)
1210 (ns-hide-others))
1211
c0642f6d
GM
1212(declare-function ns-emacs-info-panel "nsfns.m" ())
1213
edfda783
AR
1214(defun ns-do-emacs-info-panel ()
1215 (interactive)
1216 (ns-emacs-info-panel))
1217
1218(defun ns-next-frame ()
1219 "Switch to next visible frame."
1220 (interactive)
1221 (other-frame 1))
1222(defun ns-prev-frame ()
1223 "Switch to previous visible frame."
1224 (interactive)
1225 (other-frame -1))
1226
ebe68042 1227;; If no position specified, make new frame offset by 25 from current.
e5744c66
GM
1228(defvar parameters) ; dynamically bound in make-frame
1229
edfda783 1230(add-hook 'before-make-frame-hook
ebe68042
SM
1231 (lambda ()
1232 (let ((left (cdr (assq 'left (frame-parameters))))
1233 (top (cdr (assq 'top (frame-parameters)))))
1234 (if (consp left) (setq left (cadr left)))
1235 (if (consp top) (setq top (cadr top)))
1236 (cond
1237 ((or (assq 'top parameters) (assq 'left parameters)))
1238 ((or (not left) (not top)))
1239 (t
1240 (setq parameters (cons (cons 'left (+ left 25))
1241 (cons (cons 'top (+ top 25))
1242 parameters))))))))
1243
1244;; frame will be focused anyway, so select it
edfda783
AR
1245(add-hook 'after-make-frame-functions 'select-frame)
1246
ebe68042
SM
1247;; (defun ns-win-suspend-error ()
1248;; (error "Suspending an emacs running under *Step/OS X makes no sense"))
1249;; (add-hook 'suspend-hook 'ns-win-suspend-error)
1250;; (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
1251;; global-map)
edfda783
AR
1252
1253;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
1254;; see http://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html .
1255(defun ns-toggle-toolbar (&optional frame)
1256 "Switches the tool bar on and off in frame FRAME.
1257 If FRAME is nil, the change applies to the selected frame."
1258 (interactive)
ebe68042
SM
1259 (modify-frame-parameters
1260 frame (list (cons 'tool-bar-lines
edfda783
AR
1261 (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
1262 0 1)) ))
1263 (if (not tool-bar-mode) (tool-bar-mode t)))
1264
c0642f6d
GM
1265(defvar ns-cursor-blink-mode) ; nsterm.m
1266
ebe68042 1267;; Redefine from frame.el.
edfda783
AR
1268(define-minor-mode blink-cursor-mode
1269 "Toggle blinking cursor mode.
1270With a numeric argument, turn blinking cursor mode on if ARG is positive,
1271otherwise turn it off. When blinking cursor mode is enabled, the
1272cursor of the selected window blinks.
1273
1274Note that this command is effective only when Emacs
1275displays through a window system, because then Emacs does its own
1276cursor display. On a text-only terminal, this is not implemented."
1277 :init-value (not (or noninteractive
1278 no-blinking-cursor
1279 (eq ns-cursor-blink-rate nil)))
1280 :initialize 'custom-initialize-safe-default
1281 :group 'cursor
1282 :global t
1283 (if blink-cursor-mode
1284 (setq ns-cursor-blink-mode t)
1285 (setq ns-cursor-blink-mode nil)))
1286
1287
1288
1289;;;; Dialog-related functions.
1290
1291;; Ask user for confirm before printing. Due to Kevin Rodgers.
1292(defun ns-print-buffer ()
1293 "Interactive front-end to `print-buffer': asks for user confirmation first."
1294 (interactive)
1295 (if (and (interactive-p)
ebe68042
SM
1296 (or (listp last-nonmenu-event)
1297 (and (char-or-string-p (event-basic-type last-command-event))
1298 (memq 'super (event-modifiers last-command-event)))))
1299 (let ((last-nonmenu-event (if (listp last-nonmenu-event)
1300 last-nonmenu-event
1301 ;; Fake it:
1302 `(mouse-1 POSITION 1))))
1303 (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
1304 (print-buffer)
edfda783
AR
1305 (error "Cancelled")))
1306 (print-buffer)))
1307
1308(defun ns-yes-or-no-p (prompt)
1309 "As yes-or-no-p except that NS panel always used for querying."
1310 (interactive)
ebe68042
SM
1311 (setq last-nonmenu-event nil)
1312 (yes-or-no-p prompt))
edfda783
AR
1313
1314
1315;;;; Font support.
1316
1317(defalias 'x-list-fonts 'ns-list-fonts)
1318;; Needed for font listing functions under both backend and normal
1319(setq scalable-fonts-allowed t)
1320
1321;; Set to use font panel instead
1322(defalias 'generate-fontset-menu 'ns-popup-font-panel)
1323(defalias 'mouse-set-font 'ns-popup-font-panel)
1324
c0642f6d
GM
1325;; nsterm.m
1326(defvar ns-input-font)
1327(defvar ns-input-fontsize)
1328
edfda783
AR
1329(defun ns-respond-to-change-font ()
1330 "Respond to changeFont: event, expecting ns-input-font and\n\
1331ns-input-fontsize of new font."
1332 (interactive)
1333 (modify-frame-parameters (selected-frame)
1334 (list (cons 'font ns-input-font)
1335 (cons 'fontsize ns-input-fontsize)))
1336 (set-frame-font ns-input-font))
1337
1338
1339;; Default fontset for Mac OS X. This is mainly here to show how a fontset
1340;; can be set up manually. Ordinarily, fontsets are auto-created whenever
1341;; a font is chosen by
1342(defvar ns-standard-fontset-spec
ebe68042
SM
1343 ;; Only some code supports this so far, so use uglier XLFD version
1344 ;; "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
1345 (mapconcat 'identity
1346 '("-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard"
1347 "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1"
1348 "han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1"
1349 "cyrillic:-*-Trebuchet$MS-*-*-*-*-10-*-*-*-*-*-iso10646-1")
1350 ",")
1351 "String of fontset spec of the standard fontset.
edfda783
AR
1352This defines a fontset consisting of the Courier and other fonts that
1353come with OS X\".
1354See the documentation of `create-fontset-from-fontset-spec for the format.")
1355
ebe68042 1356;; Conditional on new-fontset so bootstrapping works on non-GUI compiles.
edfda783
AR
1357(if (fboundp 'new-fontset)
1358 (progn
1359 ;; Setup the default fontset.
1360 (setup-default-fontset)
1361 ;; Create the standard fontset.
ebe68042 1362 (create-fontset-from-fontset-spec ns-standard-fontset-spec t)))
edfda783 1363
ebe68042
SM
1364;;(push (cons 'font "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard")
1365;; default-frame-alist)
edfda783 1366
ebe68042 1367;; Add some additional scripts to var we use for fontset generation.
edfda783
AR
1368(setq script-representative-chars
1369 (cons '(kana #xff8a)
1370 (cons '(symbol #x2295 #x2287 #x25a1)
ebe68042 1371 script-representative-chars)))
edfda783
AR
1372
1373
1374;;;; Pasteboard support.
1375
c0642f6d
GM
1376(declare-function ns-get-cut-buffer-internal "nsselect.m" (buffer))
1377
edfda783
AR
1378(defun ns-get-pasteboard ()
1379 "Returns the value of the pasteboard."
1380 (ns-get-cut-buffer-internal 'PRIMARY))
1381
c0642f6d
GM
1382(declare-function ns-store-cut-buffer-internal "nsselect.m" (buffer string))
1383
edfda783
AR
1384(defun ns-set-pasteboard (string)
1385 "Store STRING into the NS server's pasteboard."
1386 ;; Check the data type of STRING.
1387 (if (not (stringp string)) (error "Nonstring given to pasteboard"))
1388 (ns-store-cut-buffer-internal 'PRIMARY string))
1389
ebe68042
SM
1390;; We keep track of the last text selected here, so we can check the
1391;; current selection against it, and avoid passing back our own text
1392;; from ns-pasteboard-value.
edfda783
AR
1393(defvar ns-last-selected-text nil)
1394
edfda783 1395(defun ns-select-text (text &optional push)
ebe68042 1396 "Put TEXT, a string, on the pasteboard."
edfda783
AR
1397 ;; Don't send the pasteboard too much text.
1398 ;; It becomes slow, and if really big it causes errors.
1399 (ns-set-pasteboard text)
1400 (setq ns-last-selected-text text))
1401
ebe68042
SM
1402;; Return the value of the current NS selection. For compatibility
1403;; with older NS applications, this checks cut buffer 0 before
1404;; retrieving the value of the primary selection.
edfda783
AR
1405(defun ns-pasteboard-value ()
1406 (let (text)
d377ef4a 1407
edfda783
AR
1408 ;; Consult the selection, then the cut buffer. Treat empty strings
1409 ;; as if they were unset.
1410 (or text (setq text (ns-get-pasteboard)))
1411 (if (string= text "") (setq text nil))
d377ef4a 1412
edfda783
AR
1413 (cond
1414 ((not text) nil)
1415 ((eq text ns-last-selected-text) nil)
1416 ((string= text ns-last-selected-text)
1417 ;; Record the newer string, so subsequent calls can use the `eq' test.
1418 (setq ns-last-selected-text text)
1419 nil)
1420 (t
1421 (setq ns-last-selected-text text)))))
1422
1423(defun ns-copy-including-secondary ()
1424 (interactive)
1425 (call-interactively 'kill-ring-save)
1426 (ns-store-cut-buffer-internal 'SECONDARY
1427 (buffer-substring (point) (mark t))))
1428(defun ns-paste-secondary ()
1429 (interactive)
1430 (insert (ns-get-cut-buffer-internal 'SECONDARY)))
1431
1432;; PENDING: not sure what to do here.. for now interprog- are set in
ebe68042 1433;; init-fn-keys, and unsure whether these x- settings have an effect.
edfda783
AR
1434;;(setq interprogram-cut-function 'ns-select-text
1435;; interprogram-paste-function 'ns-pasteboard-value)
ebe68042 1436;; These only needed if above not working.
edfda783
AR
1437(defalias 'x-select-text 'ns-select-text)
1438(defalias 'x-cut-buffer-or-selection-value 'ns-pasteboard-value)
1439(defalias 'x-disown-selection-internal 'ns-disown-selection-internal)
1440(defalias 'x-get-selection-internal 'ns-get-selection-internal)
1441(defalias 'x-own-selection-internal 'ns-own-selection-internal)
1442
1443(set-face-background 'region "ns_selection_color")
1444
1445
1446
1447;;;; Scrollbar handling.
1448
1449(global-set-key [vertical-scroll-bar down-mouse-1] 'ns-handle-scroll-bar-event)
1450(global-unset-key [vertical-scroll-bar mouse-1])
1451(global-unset-key [vertical-scroll-bar drag-mouse-1])
1452
1453(defun ns-scroll-bar-move (event)
1454 "Scroll the frame according to an NS scroller event."
1455 (interactive "e")
1456 (let* ((pos (event-end event))
1457 (window (nth 0 pos))
1458 (scale (nth 2 pos)))
1459 (save-excursion
1460 (set-buffer (window-buffer window))
1461 (cond
1462 ((eq (car scale) (cdr scale))
1463 (goto-char (point-max)))
1464 ((= (car scale) 0)
1465 (goto-char (point-min)))
1466 (t
1467 (goto-char (+ (point-min) 1
1468 (scroll-bar-scale scale (- (point-max) (point-min)))))))
1469 (beginning-of-line)
1470 (set-window-start window (point))
1471 (vertical-motion (/ (window-height window) 2) window))))
1472
1473(defun ns-handle-scroll-bar-event (event)
1474 "Handle scroll bar EVENT to emulate Mac Toolbox style scrolling."
1475 (interactive "e")
1476 (let* ((position (event-start event))
1477 (bar-part (nth 4 position))
1478 (window (nth 0 position))
1479 (old-window (selected-window)))
1480 (cond
1481 ((eq bar-part 'ratio)
1482 (ns-scroll-bar-move event))
1483 ((eq bar-part 'handle)
1484 (if (eq window (selected-window))
1485 (track-mouse (ns-scroll-bar-move event))
ebe68042 1486 ;; track-mouse faster for selected window, slower for unselected.
edfda783
AR
1487 (ns-scroll-bar-move event)))
1488 (t
1489 (select-window window)
1490 (cond
1491 ((eq bar-part 'up)
1492 (goto-char (window-start window))
1493 (scroll-down 1))
1494 ((eq bar-part 'above-handle)
1495 (scroll-down))
1496 ((eq bar-part 'below-handle)
1497 (scroll-up))
1498 ((eq bar-part 'down)
1499 (goto-char (window-start window))
1500 (scroll-up 1)))
1501 (select-window old-window)))))
1502
1503
1504;;;; Color support.
1505
c0642f6d
GM
1506(declare-function ns-list-colors "nsfns.m" (&optional frame))
1507
edfda783
AR
1508(defvar x-colors (ns-list-colors)
1509 "The list of colors defined in non-PANTONE color files.")
1510(defvar colors x-colors
1511 "The list of colors defined in non-PANTONE color files.")
1512
1513(defun ns-defined-colors (&optional frame)
1514 "Return a list of colors supported for a particular frame.
1515The argument FRAME specifies which frame to try.
1516The value may be different for frames on different NS displays."
1517 (or frame (setq frame (selected-frame)))
1518 (let ((all-colors x-colors)
1519 (this-color nil)
1520 (defined-colors nil))
1521 (while all-colors
1522 (setq this-color (car all-colors)
1523 all-colors (cdr all-colors))
ebe68042
SM
1524 ;; (and (face-color-supported-p frame this-color t)
1525 (setq defined-colors (cons this-color defined-colors))) ;;)
edfda783
AR
1526 defined-colors))
1527(defalias 'x-defined-colors 'ns-defined-colors)
1528(defalias 'xw-defined-colors 'ns-defined-colors)
1529
c0642f6d
GM
1530(declare-function ns-set-alpha "nsfns.m" (color alpha))
1531
edfda783
AR
1532;; Convenience and work-around for fact that set color fns now require named.
1533(defun ns-set-background-alpha (alpha)
1534 "Sets alpha (opacity) of background.
1535Set from 0.0 (fully transparent) to 1.0 (fully opaque; default).
1536Note, tranparency works better on Tiger (10.4) and higher."
1537 (interactive "nSet background alpha to: ")
1538 (let ((bgcolor (cdr (assq 'background-color (frame-parameters)))))
1539 (set-frame-parameter (selected-frame)
1540 'background-color (ns-set-alpha bgcolor alpha))))
1541
1542;; Functions for color panel + drag
1543(defun ns-face-at-pos (pos)
1544 (let* ((frame (car pos))
1545 (frame-pos (cons (cadr pos) (cddr pos)))
1546 (window (window-at (car frame-pos) (cdr frame-pos) frame))
1547 (window-pos (coordinates-in-window-p frame-pos window))
1548 (buffer (window-buffer window))
1549 (edges (window-edges window)))
1550 (cond
1551 ((not window-pos)
1552 nil)
1553 ((eq window-pos 'mode-line)
1554 'modeline)
1555 ((eq window-pos 'vertical-line)
1556 'default)
1557 ((consp window-pos)
1558 (save-excursion
1559 (set-buffer buffer)
1560 (let ((p (car (compute-motion (window-start window)
1561 (cons (nth 0 edges) (nth 1 edges))
1562 (window-end window)
1563 frame-pos
1564 (- (window-width window) 1)
1565 nil
1566 window))))
1567 (cond
1568 ((eq p (window-point window))
1569 'cursor)
1570 ((and mark-active (< (region-beginning) p) (< p (region-end)))
1571 'region)
1572 (t
1573 (let ((faces (get-char-property p 'face window)))
1574 (if (consp faces) (car faces) faces)))))))
1575 (t
1576 nil))))
1577
c0642f6d
GM
1578(defvar ns-input-color) ; nsterm.m
1579
edfda783
AR
1580(defun ns-set-foreground-at-mouse ()
1581 "Set the foreground color at the mouse location to ns-input-color."
1582 (interactive)
1583 (let* ((pos (mouse-position))
1584 (frame (car pos))
1585 (face (ns-face-at-pos pos)))
1586 (cond
1587 ((eq face 'cursor)
c0642f6d 1588 (modify-frame-parameters frame (list (cons 'cursor-color
edfda783
AR
1589 ns-input-color))))
1590 ((not face)
1591 (modify-frame-parameters frame (list (cons 'foreground-color
1592 ns-input-color))))
1593 (t
1594 (set-face-foreground face ns-input-color frame)))))
1595
1596(defun ns-set-background-at-mouse ()
1597 "Set the background color at the mouse location to ns-input-color."
1598 (interactive)
1599 (let* ((pos (mouse-position))
1600 (frame (car pos))
1601 (face (ns-face-at-pos pos)))
1602 (cond
1603 ((eq face 'cursor)
1604 (modify-frame-parameters frame (list (cons 'cursor-color
1605 ns-input-color))))
1606 ((not face)
1607 (modify-frame-parameters frame (list (cons 'background-color
1608 ns-input-color))))
1609 (t
1610 (set-face-background face ns-input-color frame)))))
1611
1612
1613
ebe68042 1614;; Misc aliases.
edfda783
AR
1615(defalias 'x-display-mm-width 'ns-display-mm-width)
1616(defalias 'x-display-mm-height 'ns-display-mm-height)
1617(defalias 'x-display-backing-store 'ns-display-backing-store)
1618(defalias 'x-display-save-under 'ns-display-save-under)
1619(defalias 'x-display-visual-class 'ns-display-visual-class)
1620(defalias 'x-display-screens 'ns-display-screens)
1621(defalias 'x-focus-frame 'ns-focus-frame)
1622
1623;; Set some options to be as NS-like as possible.
1624(setq frame-title-format t
1625 icon-title-format t)
1626
ebe68042 1627;; Set up browser connectivity.
c0642f6d
GM
1628(defvar browse-url-generic-program)
1629
edfda783 1630(setq browse-url-browser-function 'browse-url-generic)
ebe68042
SM
1631(setq browse-url-generic-program
1632 (cond ((eq system-type 'darwin) "open")
1633 ;; Otherwise, GNUstep.
1634 (t "gopen")))
edfda783
AR
1635
1636
1637(defvar ns-initialized nil
1638 "Non-nil if NS windowing has been initialized.")
1639
c0642f6d
GM
1640(declare-function ns-open-connection "nsfns.m"
1641 (display &optional resource_string must_succeed))
1642
1643(declare-function ns-list-services "nsfns.m" ())
1644
ebe68042
SM
1645;; Do the actual NS Windows setup here; the above code just defines
1646;; functions and variables that we use now.
edfda783
AR
1647(defun ns-initialize-window-system ()
1648 "Initialize Emacs for NS (Cocoa / GNUstep) windowing."
1649
ebe68042 1650 ;; PENDING: not needed?
edfda783
AR
1651 (setq command-line-args (ns-handle-args command-line-args))
1652
1653 (ns-open-connection (system-name) nil t)
1654
ebe68042
SM
1655 (dolist (service (ns-list-services))
1656 (if (eq (car service) 'undefined)
1657 (ns-define-service (cdr service))
1658 (define-key global-map (vector (car service))
1659 (ns-define-service (cdr service)))))
edfda783
AR
1660
1661 (if (and (eq (get-lisp-resource nil "NXAutoLaunch") t)
1662 (eq (get-lisp-resource nil "HideOnAutoLaunch") t))
1663 (add-hook 'after-init-hook 'ns-do-hide-emacs))
1664
ebe68042 1665 ;; FIXME: This will surely lead to "MODIFIED OUTSIDE CUSTOM" warnings.
edfda783
AR
1666 (menu-bar-mode (if (get-lisp-resource nil "Menus") 1 -1))
1667 (mouse-wheel-mode 1)
1668
1669 (setq ns-initialized t))
1670
1671(add-to-list 'handle-args-function-alist '(ns . ns-handle-args))
1672(add-to-list 'frame-creation-function-alist '(ns . x-create-frame-with-faces))
1673(add-to-list 'window-system-initialization-alist '(ns . ns-initialize-window-system))
1674
1675
1676(provide 'ns-win)
1677
0ae1e5e5 1678;; arch-tag: eb138a45-4e2e-4d68-b1c9-a39665731644
edfda783 1679;;; ns-win.el ends here