Move ns-specific menu-bar code from term/ns-win.el to menu-bar.el.
[bpt/emacs.git] / lisp / term / ns-win.el
1 ;;; ns-win.el --- lisp side of interface with NeXT/Open/GNUstep/MacOS X window system
2
3 ;; Copyright (C) 1993, 1994, 2005, 2006, 2007, 2008, 2009, 2010
4 ;; Free Software Foundation, Inc.
5
6 ;; Authors: Carl Edman
7 ;; Christian Limpach
8 ;; Scott Bender
9 ;; Christophe de Dinechin
10 ;; Adrian Robert
11 ;; Keywords: terminals
12
13 ;; This file is part of GNU Emacs.
14
15 ;; GNU Emacs is free software: you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation, either version 3 of the License, or
18 ;; (at your option) any later version.
19
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 ;; GNU General Public License for more details.
24
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27
28 ;;; Commentary:
29
30 ;; ns-win.el: this file is loaded from ../lisp/startup.el when it
31 ;; recognizes that Nextstep windows are to be used. Command line
32 ;; switches are parsed and those pertaining to Nextstep are processed
33 ;; and removed from the command line. The Nextstep display is opened
34 ;; and hooks are set for popping up the initial window.
35
36 ;; startup.el will then examine startup files, and eventually call the hooks
37 ;; which create the first window (s).
38
39 ;; A number of other Nextstep convenience functions are defined in
40 ;; this file, which works in close coordination with src/nsfns.m.
41
42 ;;; Code:
43
44 (or (featurep 'ns)
45 (error "%s: Loading ns-win.el but not compiled for GNUstep/MacOS"
46 (invocation-name)))
47
48 (eval-when-compile (require 'cl)) ; lexical-let
49
50 ;; Documentation-purposes only: actually loaded in loadup.el.
51 (require 'frame)
52 (require 'mouse)
53 (require 'faces)
54 (require 'menu-bar)
55 (require 'fontset)
56
57 (defgroup ns nil
58 "GNUstep/Mac OS X specific features."
59 :group 'environment)
60
61 ;;;; Command line argument handling.
62
63 (defvar x-invocation-args)
64 (defvar ns-command-line-resources nil) ; FIXME unused?
65
66 ;; nsterm.m.
67 (defvar ns-input-file)
68
69 (defun ns-handle-nxopen (switch &optional temp)
70 (setq unread-command-events (append unread-command-events
71 (if temp '(ns-open-temp-file)
72 '(ns-open-file)))
73 ns-input-file (append ns-input-file (list (pop x-invocation-args)))))
74
75 (defun ns-handle-nxopentemp (switch)
76 (ns-handle-nxopen switch t))
77
78 (defun ns-ignore-1-arg (switch)
79 (setq x-invocation-args (cdr x-invocation-args)))
80
81 (defun ns-parse-geometry (geom)
82 "Parse a Nextstep-style geometry string GEOM.
83 Returns an alist of the form ((top . TOP), (left . LEFT) ... ).
84 The properties returned may include `top', `left', `height', and `width'."
85 (when (string-match "\\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\)\
86 \\( \\([0-9]+\\) ?\\)?\\)?\\)?"
87 geom)
88 (apply
89 'append
90 (list
91 (list (cons 'top (string-to-number (match-string 1 geom))))
92 (if (match-string 3 geom)
93 (list (cons 'left (string-to-number (match-string 3 geom)))))
94 (if (match-string 5 geom)
95 (list (cons 'height (string-to-number (match-string 5 geom)))))
96 (if (match-string 7 geom)
97 (list (cons 'width (string-to-number (match-string 7 geom)))))))))
98
99 ;;;; Keyboard mapping.
100
101 (define-obsolete-variable-alias 'ns-alternatives-map 'x-alternatives-map "24.1")
102
103 ;; Here are some Nextstep-like bindings for command key sequences.
104 (define-key global-map [?\s-,] 'customize)
105 (define-key global-map [?\s-'] 'next-multiframe-window)
106 (define-key global-map [?\s-`] 'other-frame)
107 (define-key global-map [?\s-~] 'ns-prev-frame)
108 (define-key global-map [?\s--] 'center-line)
109 (define-key global-map [?\s-:] 'ispell)
110 (define-key global-map [?\s-\;] 'ispell-next)
111 (define-key global-map [?\s-?] 'info)
112 (define-key global-map [?\s-^] 'kill-some-buffers)
113 (define-key global-map [?\s-&] 'kill-this-buffer)
114 (define-key global-map [?\s-C] 'ns-popup-color-panel)
115 (define-key global-map [?\s-D] 'dired)
116 (define-key global-map [?\s-E] 'edit-abbrevs)
117 (define-key global-map [?\s-L] 'shell-command)
118 (define-key global-map [?\s-M] 'manual-entry)
119 (define-key global-map [?\s-S] 'ns-write-file-using-panel)
120 (define-key global-map [?\s-a] 'mark-whole-buffer)
121 (define-key global-map [?\s-c] 'ns-copy-including-secondary)
122 (define-key global-map [?\s-d] 'isearch-repeat-backward)
123 (define-key global-map [?\s-e] 'isearch-yank-kill)
124 (define-key global-map [?\s-f] 'isearch-forward)
125 (define-key global-map [?\s-g] 'isearch-repeat-forward)
126 (define-key global-map [?\s-h] 'ns-do-hide-emacs)
127 (define-key global-map [?\s-H] 'ns-do-hide-others)
128 (define-key global-map [?\s-j] 'exchange-point-and-mark)
129 (define-key global-map [?\s-k] 'kill-this-buffer)
130 (define-key global-map [?\s-l] 'goto-line)
131 (define-key global-map [?\s-m] 'iconify-frame)
132 (define-key global-map [?\s-n] 'make-frame)
133 (define-key global-map [?\s-o] 'ns-open-file-using-panel)
134 (define-key global-map [?\s-p] 'ns-print-buffer)
135 (define-key global-map [?\s-q] 'save-buffers-kill-emacs)
136 (define-key global-map [?\s-s] 'save-buffer)
137 (define-key global-map [?\s-t] 'ns-popup-font-panel)
138 (define-key global-map [?\s-u] 'revert-buffer)
139 (define-key global-map [?\s-v] 'yank)
140 (define-key global-map [?\s-w] 'delete-frame)
141 (define-key global-map [?\s-x] 'kill-region)
142 (define-key global-map [?\s-y] 'ns-paste-secondary)
143 (define-key global-map [?\s-z] 'undo)
144 (define-key global-map [?\s-|] 'shell-command-on-region)
145 (define-key global-map [s-kp-bar] 'shell-command-on-region)
146 ;; (as in Terminal.app)
147 (define-key global-map [s-right] 'ns-next-frame)
148 (define-key global-map [s-left] 'ns-prev-frame)
149
150 (define-key global-map [home] 'beginning-of-buffer)
151 (define-key global-map [end] 'end-of-buffer)
152 (define-key global-map [kp-home] 'beginning-of-buffer)
153 (define-key global-map [kp-end] 'end-of-buffer)
154 (define-key global-map [kp-prior] 'scroll-down)
155 (define-key global-map [kp-next] 'scroll-up)
156
157 ;; Allow shift-clicks to work similarly to under Nextstep.
158 (define-key global-map [S-mouse-1] 'mouse-save-then-kill)
159 (global-unset-key [S-down-mouse-1])
160
161 ;; Special Nextstep-generated events are converted to function keys. Here
162 ;; are the bindings for them. Note, these keys are actually declared in
163 ;; x-setup-function-keys in common-win.
164 (define-key global-map [ns-power-off] 'save-buffers-kill-emacs)
165 (define-key global-map [ns-open-file] 'ns-find-file)
166 (define-key global-map [ns-open-temp-file] [ns-open-file])
167 (define-key global-map [ns-drag-file] 'ns-insert-file)
168 (define-key global-map [ns-drag-color] 'ns-set-foreground-at-mouse)
169 (define-key global-map [S-ns-drag-color] 'ns-set-background-at-mouse)
170 (define-key global-map [ns-drag-text] 'ns-insert-text)
171 (define-key global-map [ns-change-font] 'ns-respond-to-change-font)
172 (define-key global-map [ns-open-file-line] 'ns-open-file-select-line)
173 (define-key global-map [ns-spi-service-call] 'ns-spi-service-call)
174 (define-key global-map [ns-toggle-toolbar] 'ns-toggle-toolbar)
175
176
177 ;; Set up a number of aliases and other layers to pretend we're using
178 ;; the Choi/Mitsuharu Carbon port.
179
180 (defvaralias 'mac-allow-anti-aliasing 'ns-antialias-text)
181 (defvaralias 'mac-command-modifier 'ns-command-modifier)
182 (defvaralias 'mac-control-modifier 'ns-control-modifier)
183 (defvaralias 'mac-option-modifier 'ns-option-modifier)
184 (defvaralias 'mac-right-option-modifier 'ns-right-option-modifier)
185 (defvaralias 'mac-function-modifier 'ns-function-modifier)
186 (declare-function ns-do-applescript "nsfns.m" (script))
187 (defalias 'do-applescript 'ns-do-applescript)
188
189 ;;;; Services
190 (declare-function ns-perform-service "nsfns.m" (service send))
191
192 (defun ns-define-service (path)
193 (let ((mapping [menu-bar services])
194 (service (mapconcat 'identity path "/"))
195 (name (intern
196 (subst-char-in-string
197 ?\s ?-
198 (mapconcat 'identity (cons "ns-service" path) "-")))))
199 ;; This defines the function.
200 (defalias name
201 (lexical-let ((service service))
202 (lambda (arg)
203 (interactive "p")
204 (let* ((in-string
205 (cond ((stringp arg) arg)
206 (mark-active
207 (buffer-substring (region-beginning) (region-end)))))
208 (out-string (ns-perform-service service in-string)))
209 (cond
210 ((stringp arg) out-string)
211 ((and out-string (or (not in-string)
212 (not (string= in-string out-string))))
213 (if mark-active (delete-region (region-beginning) (region-end)))
214 (insert out-string)
215 (setq deactivate-mark nil)))))))
216 (cond
217 ((lookup-key global-map mapping)
218 (while (cdr path)
219 (setq mapping (vconcat mapping (list (intern (car path)))))
220 (if (not (keymapp (lookup-key global-map mapping)))
221 (define-key global-map mapping
222 (cons (car path) (make-sparse-keymap (car path)))))
223 (setq path (cdr path)))
224 (setq mapping (vconcat mapping (list (intern (car path)))))
225 (define-key global-map mapping (cons (car path) name))))
226 name))
227
228 ;; nsterm.m
229 (defvar ns-input-spi-name)
230 (defvar ns-input-spi-arg)
231
232 (declare-function dnd-open-file "dnd" (uri action))
233
234 (defun ns-spi-service-call ()
235 "Respond to a service request."
236 (interactive)
237 (cond ((string-equal ns-input-spi-name "open-selection")
238 (switch-to-buffer (generate-new-buffer "*untitled*"))
239 (insert ns-input-spi-arg))
240 ((string-equal ns-input-spi-name "open-file")
241 (dnd-open-file ns-input-spi-arg nil))
242 ((string-equal ns-input-spi-name "mail-selection")
243 (compose-mail)
244 (rfc822-goto-eoh)
245 (forward-line 1)
246 (insert ns-input-spi-arg))
247 ((string-equal ns-input-spi-name "mail-to")
248 (compose-mail ns-input-spi-arg))
249 (t (error (concat "Service " ns-input-spi-name " not recognized")))))
250
251
252 ;; Composed key sequence handling for Nextstep system input methods.
253 ;; (On Nextstep systems, input methods are provided for CJK
254 ;; characters, etc. which require multiple keystrokes, and during
255 ;; entry a partial ("working") result is typically shown in the
256 ;; editing window.)
257
258 (defface ns-working-text-face
259 '((t :underline t))
260 "Face used to highlight working text during compose sequence insert."
261 :group 'ns)
262
263 (defvar ns-working-overlay nil
264 "Overlay used to highlight working text during compose sequence insert.
265 When text is in th echo area, this just stores the length of the working text.")
266
267 (defvar ns-working-text) ; nsterm.m
268
269 ;; Test if in echo area, based on mac-win.el 2007/08/26 unicode-2.
270 ;; This will fail if called from a NONASCII_KEYSTROKE event on the global map.
271 (defun ns-in-echo-area ()
272 "Whether, for purposes of inserting working composition text, the minibuffer
273 is currently being used."
274 (or isearch-mode
275 (and cursor-in-echo-area (current-message))
276 ;; Overlay strings are not shown in some cases.
277 (get-char-property (point) 'invisible)
278 (and (not (bobp))
279 (or (and (get-char-property (point) 'display)
280 (eq (get-char-property (1- (point)) 'display)
281 (get-char-property (point) 'display)))
282 (and (get-char-property (point) 'composition)
283 (eq (get-char-property (1- (point)) 'composition)
284 (get-char-property (point) 'composition)))))))
285
286 ;; The 'interactive' here stays for subinvocations, so the ns-in-echo-area
287 ;; always returns nil for some reason. If this WASN'T the case, we could
288 ;; map this to [ns-insert-working-text] and eliminate Fevals in nsterm.m.
289 ;; These functions test whether in echo area and delegate accordingly.
290 (defun ns-put-working-text ()
291 (interactive)
292 (if (ns-in-echo-area) (ns-echo-working-text) (ns-insert-working-text)))
293 (defun ns-unput-working-text ()
294 (interactive)
295 (ns-delete-working-text))
296
297 (defun ns-insert-working-text ()
298 "Insert contents of `ns-working-text' as UTF-8 string and mark with
299 `ns-working-overlay'. Any previously existing working text is cleared first.
300 The overlay is assigned the face `ns-working-text-face'."
301 ;; FIXME: if buffer is read-only, don't try to insert anything
302 ;; and if text is bound to a command, execute that instead (Bug#1453)
303 (interactive)
304 (ns-delete-working-text)
305 (let ((start (point)))
306 (insert ns-working-text)
307 (overlay-put (setq ns-working-overlay (make-overlay start (point)
308 (current-buffer) nil t))
309 'face 'ns-working-text-face)))
310
311 (defun ns-echo-working-text ()
312 "Echo contents of `ns-working-text' in message display area.
313 See `ns-insert-working-text'."
314 (ns-delete-working-text)
315 (let* ((msg (current-message))
316 (msglen (length msg))
317 message-log-max)
318 (setq ns-working-overlay (length ns-working-text))
319 (setq msg (concat msg ns-working-text))
320 (put-text-property msglen (+ msglen ns-working-overlay)
321 'face 'ns-working-text-face msg)
322 (message "%s" msg)))
323
324 (defun ns-delete-working-text()
325 "Delete working text and clear `ns-working-overlay'."
326 (interactive)
327 (cond
328 ((and (overlayp ns-working-overlay)
329 ;; Still alive?
330 (overlay-buffer ns-working-overlay))
331 (with-current-buffer (overlay-buffer ns-working-overlay)
332 (delete-region (overlay-start ns-working-overlay)
333 (overlay-end ns-working-overlay))
334 (delete-overlay ns-working-overlay)))
335 ((integerp ns-working-overlay)
336 (let ((msg (current-message))
337 message-log-max)
338 (setq msg (substring msg 0 (- (length msg) ns-working-overlay)))
339 (message "%s" msg))))
340 (setq ns-working-overlay nil))
341
342
343 (declare-function ns-convert-utf8-nfd-to-nfc "nsfns.m" (str))
344
345 ;;;; OS X file system Unicode UTF-8 NFD (decomposed form) support
346 ;; Lisp code based on utf-8m.el, by Seiji Zenitani, Eiji Honjoh, and
347 ;; Carsten Bormann.
348 (when (eq system-type 'darwin)
349 (defun ns-utf8-nfd-post-read-conversion (length)
350 "Calls `ns-convert-utf8-nfd-to-nfc' to compose char sequences."
351 (save-excursion
352 (save-restriction
353 (narrow-to-region (point) (+ (point) length))
354 (let ((str (buffer-string)))
355 (delete-region (point-min) (point-max))
356 (insert (ns-convert-utf8-nfd-to-nfc str))
357 (- (point-max) (point-min))))))
358
359 (define-coding-system 'utf-8-nfd
360 "UTF-8 NFD (decomposed) encoding."
361 :coding-type 'utf-8
362 :mnemonic ?U
363 :charset-list '(unicode)
364 :post-read-conversion 'ns-utf8-nfd-post-read-conversion)
365 (set-file-name-coding-system 'utf-8-nfd))
366
367 ;;;; Inter-app communications support.
368
369 (defvar ns-input-text) ; nsterm.m
370
371 (defun ns-insert-text ()
372 "Insert contents of `ns-input-text' at point."
373 (interactive)
374 (insert ns-input-text)
375 (setq ns-input-text nil))
376
377 (defun ns-insert-file ()
378 "Insert contents of file `ns-input-file' like insert-file but with less
379 prompting. If file is a directory perform a `find-file' on it."
380 (interactive)
381 (let ((f (pop ns-input-file)))
382 (if (file-directory-p f)
383 (find-file f)
384 (push-mark (+ (point) (cadr (insert-file-contents f)))))))
385
386 (defvar ns-select-overlay nil
387 "Overlay used to highlight areas in files requested by Nextstep apps.")
388 (make-variable-buffer-local 'ns-select-overlay)
389
390 (defvar ns-input-line) ; nsterm.m
391
392 (defun ns-open-file-select-line ()
393 "Open a buffer containing the file `ns-input-file'.
394 Lines are highlighted according to `ns-input-line'."
395 (interactive)
396 (ns-find-file)
397 (cond
398 ((and ns-input-line (buffer-modified-p))
399 (if ns-select-overlay
400 (setq ns-select-overlay (delete-overlay ns-select-overlay)))
401 (deactivate-mark)
402 (goto-char (point-min))
403 (forward-line (1- (if (consp ns-input-line)
404 (min (car ns-input-line) (cdr ns-input-line))
405 ns-input-line))))
406 (ns-input-line
407 (if (not ns-select-overlay)
408 (overlay-put (setq ns-select-overlay (make-overlay (point-min)
409 (point-min)))
410 'face 'highlight))
411 (let ((beg (save-excursion
412 (goto-char (point-min))
413 (line-beginning-position
414 (if (consp ns-input-line)
415 (min (car ns-input-line) (cdr ns-input-line))
416 ns-input-line))))
417 (end (save-excursion
418 (goto-char (point-min))
419 (line-beginning-position
420 (1+ (if (consp ns-input-line)
421 (max (car ns-input-line) (cdr ns-input-line))
422 ns-input-line))))))
423 (move-overlay ns-select-overlay beg end)
424 (deactivate-mark)
425 (goto-char beg)))
426 (t
427 (if ns-select-overlay
428 (setq ns-select-overlay (delete-overlay ns-select-overlay))))))
429
430 (defun ns-unselect-line ()
431 "Removes any Nextstep highlight a buffer may contain."
432 (if ns-select-overlay
433 (setq ns-select-overlay (delete-overlay ns-select-overlay))))
434
435 (add-hook 'first-change-hook 'ns-unselect-line)
436
437 ;;;; Preferences handling.
438 (declare-function ns-get-resource "nsfns.m" (owner name))
439
440 (defun get-lisp-resource (arg1 arg2)
441 (let ((res (ns-get-resource arg1 arg2)))
442 (cond
443 ((not res) 'unbound)
444 ((string-equal (upcase res) "YES") t)
445 ((string-equal (upcase res) "NO") nil)
446 (t (read res)))))
447
448 ;; nsterm.m
449
450 (declare-function ns-read-file-name "nsfns.m"
451 (prompt &optional dir isLoad init))
452
453 ;;;; File handling.
454
455 (defun ns-open-file-using-panel ()
456 "Pop up open-file panel, and load the result in a buffer."
457 (interactive)
458 ;; Prompt dir defaultName isLoad initial.
459 (setq ns-input-file (ns-read-file-name "Select File to Load" nil t nil))
460 (if ns-input-file
461 (and (setq ns-input-file (list ns-input-file)) (ns-find-file))))
462
463 (defun ns-write-file-using-panel ()
464 "Pop up save-file panel, and save buffer in resulting name."
465 (interactive)
466 (let (ns-output-file)
467 ;; Prompt dir defaultName isLoad initial.
468 (setq ns-output-file (ns-read-file-name "Save As" nil nil nil))
469 (message ns-output-file)
470 (if ns-output-file (write-file ns-output-file))))
471
472 (defcustom ns-pop-up-frames 'fresh
473 "Non-nil means open files upon request from the Workspace in a new frame.
474 If t, always do so. Any other non-nil value means open a new frame
475 unless the current buffer is a scratch buffer."
476 :type '(choice (const :tag "Never" nil)
477 (const :tag "Always" t)
478 (other :tag "Except for scratch buffer" fresh))
479 :version "23.1"
480 :group 'ns)
481
482 (declare-function ns-hide-emacs "nsfns.m" (on))
483
484 (defun ns-find-file ()
485 "Do a `find-file' with the `ns-input-file' as argument."
486 (interactive)
487 (let* ((f (file-truename (pop ns-input-file)))
488 (file (find-file-noselect f))
489 (bufwin1 (get-buffer-window file 'visible))
490 (bufwin2 (get-buffer-window "*scratch*" 'visibile)))
491 (cond
492 (bufwin1
493 (select-frame (window-frame bufwin1))
494 (raise-frame (window-frame bufwin1))
495 (select-window bufwin1))
496 ((and (eq ns-pop-up-frames 'fresh) bufwin2)
497 (ns-hide-emacs 'activate)
498 (select-frame (window-frame bufwin2))
499 (raise-frame (window-frame bufwin2))
500 (select-window bufwin2)
501 (find-file f))
502 (ns-pop-up-frames
503 (ns-hide-emacs 'activate)
504 (let ((pop-up-frames t)) (pop-to-buffer file nil)))
505 (t
506 (ns-hide-emacs 'activate)
507 (find-file f)))))
508
509 ;;;; Frame-related functions.
510
511 ;; Don't show the frame name; that's redundant with Nextstep.
512 (setq-default mode-line-frame-identification '(" "))
513
514 ;; nsterm.m
515 (defvar ns-alternate-modifier)
516 (defvar ns-right-alternate-modifier)
517
518 ;; You say tomAYto, I say tomAHto..
519 (defvaralias 'ns-option-modifier 'ns-alternate-modifier)
520 (defvaralias 'ns-right-option-modifier 'ns-right-alternate-modifier)
521
522 (defun ns-do-hide-emacs ()
523 (interactive)
524 (ns-hide-emacs t))
525
526 (declare-function ns-hide-others "nsfns.m" ())
527
528 (defun ns-do-hide-others ()
529 (interactive)
530 (ns-hide-others))
531
532 (declare-function ns-emacs-info-panel "nsfns.m" ())
533
534 (defun ns-do-emacs-info-panel ()
535 (interactive)
536 (ns-emacs-info-panel))
537
538 (defun ns-next-frame ()
539 "Switch to next visible frame."
540 (interactive)
541 (other-frame 1))
542
543 (defun ns-prev-frame ()
544 "Switch to previous visible frame."
545 (interactive)
546 (other-frame -1))
547
548 ;; If no position specified, make new frame offset by 25 from current.
549 (defvar parameters) ; dynamically bound in make-frame
550 (add-hook 'before-make-frame-hook
551 (lambda ()
552 (let ((left (cdr (assq 'left (frame-parameters))))
553 (top (cdr (assq 'top (frame-parameters)))))
554 (if (consp left) (setq left (cadr left)))
555 (if (consp top) (setq top (cadr top)))
556 (cond
557 ((or (assq 'top parameters) (assq 'left parameters)))
558 ((or (not left) (not top)))
559 (t
560 (setq parameters (cons (cons 'left (+ left 25))
561 (cons (cons 'top (+ top 25))
562 parameters))))))))
563
564 ;; frame will be focused anyway, so select it
565 ;; (if this is not done, modeline is dimmed until first interaction)
566 (add-hook 'after-make-frame-functions 'select-frame)
567
568 (defvar tool-bar-mode)
569 (declare-function tool-bar-mode "tool-bar" (&optional arg))
570
571 ;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
572 ;; see http://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html .
573 (defun ns-toggle-toolbar (&optional frame)
574 "Switches the tool bar on and off in frame FRAME.
575 If FRAME is nil, the change applies to the selected frame."
576 (interactive)
577 (modify-frame-parameters
578 frame (list (cons 'tool-bar-lines
579 (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
580 0 1)) ))
581 (if (not tool-bar-mode) (tool-bar-mode t)))
582
583
584 ;;;; Dialog-related functions.
585
586 ;; Ask user for confirm before printing. Due to Kevin Rodgers.
587 (defun ns-print-buffer ()
588 "Interactive front-end to `print-buffer': asks for user confirmation first."
589 (interactive)
590 (if (and (called-interactively-p 'interactive)
591 (or (listp last-nonmenu-event)
592 (and (char-or-string-p (event-basic-type last-command-event))
593 (memq 'super (event-modifiers last-command-event)))))
594 (let ((last-nonmenu-event (if (listp last-nonmenu-event)
595 last-nonmenu-event
596 ;; Fake it:
597 `(mouse-1 POSITION 1))))
598 (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
599 (print-buffer)
600 (error "Cancelled")))
601 (print-buffer)))
602
603 ;;;; Font support.
604
605 ;; Needed for font listing functions under both backend and normal
606 (setq scalable-fonts-allowed t)
607
608 ;; Set to use font panel instead
609 (declare-function ns-popup-font-panel "nsfns.m" (&optional frame))
610 (defalias 'x-select-font 'ns-popup-font-panel "Pop up the font panel.
611 This function has been overloaded in Nextstep.")
612 (defalias 'mouse-set-font 'ns-popup-font-panel "Pop up the font panel.
613 This function has been overloaded in Nextstep.")
614
615 ;; nsterm.m
616 (defvar ns-input-font)
617 (defvar ns-input-fontsize)
618
619 (defun ns-respond-to-change-font ()
620 "Respond to changeFont: event, expecting `ns-input-font' and\n\
621 `ns-input-fontsize' of new font."
622 (interactive)
623 (modify-frame-parameters (selected-frame)
624 (list (cons 'font ns-input-font)
625 (cons 'fontsize ns-input-fontsize)))
626 (set-frame-font ns-input-font))
627
628
629 ;; Default fontset for Mac OS X. This is mainly here to show how a fontset
630 ;; can be set up manually. Ordinarily, fontsets are auto-created whenever
631 ;; a font is chosen by
632 (defvar ns-standard-fontset-spec
633 ;; Only some code supports this so far, so use uglier XLFD version
634 ;; "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
635 (mapconcat 'identity
636 '("-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard"
637 "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1"
638 "han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1"
639 "cyrillic:-*-Trebuchet$MS-*-*-*-*-10-*-*-*-*-*-iso10646-1")
640 ",")
641 "String of fontset spec of the standard fontset.
642 This defines a fontset consisting of the Courier and other fonts that
643 come with OS X.
644 See the documentation of `create-fontset-from-fontset-spec' for the format.")
645
646 ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles.
647 (when (fboundp 'new-fontset)
648 ;; Setup the default fontset.
649 (create-default-fontset)
650 ;; Create the standard fontset.
651 (condition-case err
652 (create-fontset-from-fontset-spec ns-standard-fontset-spec t)
653 (error (display-warning
654 'initialization
655 (format "Creation of the standard fontset failed: %s" err)
656 :error))))
657
658 (defvar ns-reg-to-script) ; nsfont.m
659
660 ;; This maps font registries (not exposed by NS APIs for font selection) to
661 ;; unicode scripts (which can be mapped to unicode character ranges which are).
662 ;; See ../international/fontset.el
663 (setq ns-reg-to-script
664 '(("iso8859-1" . latin)
665 ("iso8859-2" . latin)
666 ("iso8859-3" . latin)
667 ("iso8859-4" . latin)
668 ("iso8859-5" . cyrillic)
669 ("microsoft-cp1251" . cyrillic)
670 ("koi8-r" . cyrillic)
671 ("iso8859-6" . arabic)
672 ("iso8859-7" . greek)
673 ("iso8859-8" . hebrew)
674 ("iso8859-9" . latin)
675 ("iso8859-10" . latin)
676 ("iso8859-11" . thai)
677 ("tis620" . thai)
678 ("iso8859-13" . latin)
679 ("iso8859-14" . latin)
680 ("iso8859-15" . latin)
681 ("iso8859-16" . latin)
682 ("viscii1.1-1" . latin)
683 ("jisx0201" . kana)
684 ("jisx0208" . han)
685 ("jisx0212" . han)
686 ("jisx0213" . han)
687 ("gb2312.1980" . han)
688 ("gb18030" . han)
689 ("gbk-0" . han)
690 ("big5" . han)
691 ("cns11643" . han)
692 ("sisheng_cwnn" . bopomofo)
693 ("ksc5601.1987" . hangul)
694 ("ethiopic-unicode" . ethiopic)
695 ("is13194-devanagari" . indian-is13194)
696 ("iso10646.indian-1" . devanagari)))
697
698
699 ;;;; Pasteboard support.
700
701 (declare-function ns-get-cut-buffer-internal "nsselect.m" (buffer))
702
703 (defun ns-get-pasteboard ()
704 "Returns the value of the pasteboard."
705 (ns-get-cut-buffer-internal 'CLIPBOARD))
706
707 (declare-function ns-store-cut-buffer-internal "nsselect.m" (buffer string))
708
709 (defun ns-set-pasteboard (string)
710 "Store STRING into the pasteboard of the Nextstep display server."
711 ;; Check the data type of STRING.
712 (if (not (stringp string)) (error "Nonstring given to pasteboard"))
713 (ns-store-cut-buffer-internal 'CLIPBOARD string))
714
715 ;; We keep track of the last text selected here, so we can check the
716 ;; current selection against it, and avoid passing back our own text
717 ;; from x-selection-value.
718 (defvar ns-last-selected-text nil)
719
720 ;; Return the value of the current Nextstep selection. For
721 ;; compatibility with older Nextstep applications, this checks cut
722 ;; buffer 0 before retrieving the value of the primary selection.
723 (defun x-selection-value ()
724 (let (text)
725 ;; Consult the selection. Treat empty strings as if they were unset.
726 (or text (setq text (ns-get-pasteboard)))
727 (if (string= text "") (setq text nil))
728 (cond
729 ((not text) nil)
730 ((eq text ns-last-selected-text) nil)
731 ((string= text ns-last-selected-text)
732 ;; Record the newer string, so subsequent calls can use the `eq' test.
733 (setq ns-last-selected-text text)
734 nil)
735 (t
736 (setq ns-last-selected-text text)))))
737
738 (defun ns-copy-including-secondary ()
739 (interactive)
740 (call-interactively 'kill-ring-save)
741 (ns-store-cut-buffer-internal 'SECONDARY
742 (buffer-substring (point) (mark t))))
743 (defun ns-paste-secondary ()
744 (interactive)
745 (insert (ns-get-cut-buffer-internal 'SECONDARY)))
746
747
748 ;;;; Scrollbar handling.
749
750 (global-set-key [vertical-scroll-bar down-mouse-1] 'ns-handle-scroll-bar-event)
751 (global-unset-key [vertical-scroll-bar mouse-1])
752 (global-unset-key [vertical-scroll-bar drag-mouse-1])
753
754 (declare-function scroll-bar-scale "scroll-bar" (num-denom whole))
755
756 (defun ns-scroll-bar-move (event)
757 "Scroll the frame according to a Nextstep scroller event."
758 (interactive "e")
759 (let* ((pos (event-end event))
760 (window (nth 0 pos))
761 (scale (nth 2 pos)))
762 (with-current-buffer (window-buffer window)
763 (cond
764 ((eq (car scale) (cdr scale))
765 (goto-char (point-max)))
766 ((= (car scale) 0)
767 (goto-char (point-min)))
768 (t
769 (goto-char (+ (point-min) 1
770 (scroll-bar-scale scale (- (point-max) (point-min)))))))
771 (beginning-of-line)
772 (set-window-start window (point))
773 (vertical-motion (/ (window-height window) 2) window))))
774
775 (defun ns-handle-scroll-bar-event (event)
776 "Handle scroll bar EVENT to emulate Nextstep style scrolling."
777 (interactive "e")
778 (let* ((position (event-start event))
779 (bar-part (nth 4 position))
780 (window (nth 0 position))
781 (old-window (selected-window)))
782 (cond
783 ((eq bar-part 'ratio)
784 (ns-scroll-bar-move event))
785 ((eq bar-part 'handle)
786 (if (eq window (selected-window))
787 (track-mouse (ns-scroll-bar-move event))
788 ;; track-mouse faster for selected window, slower for unselected.
789 (ns-scroll-bar-move event)))
790 (t
791 (select-window window)
792 (cond
793 ((eq bar-part 'up)
794 (goto-char (window-start window))
795 (scroll-down 1))
796 ((eq bar-part 'above-handle)
797 (scroll-down))
798 ((eq bar-part 'below-handle)
799 (scroll-up))
800 ((eq bar-part 'down)
801 (goto-char (window-start window))
802 (scroll-up 1)))
803 (select-window old-window)))))
804
805
806 ;;;; Color support.
807
808 ;; Functions for color panel + drag
809 (defun ns-face-at-pos (pos)
810 (let* ((frame (car pos))
811 (frame-pos (cons (cadr pos) (cddr pos)))
812 (window (window-at (car frame-pos) (cdr frame-pos) frame))
813 (window-pos (coordinates-in-window-p frame-pos window))
814 (buffer (window-buffer window))
815 (edges (window-edges window)))
816 (cond
817 ((not window-pos)
818 nil)
819 ((eq window-pos 'mode-line)
820 'modeline)
821 ((eq window-pos 'vertical-line)
822 'default)
823 ((consp window-pos)
824 (with-current-buffer buffer
825 (let ((p (car (compute-motion (window-start window)
826 (cons (nth 0 edges) (nth 1 edges))
827 (window-end window)
828 frame-pos
829 (- (window-width window) 1)
830 nil
831 window))))
832 (cond
833 ((eq p (window-point window))
834 'cursor)
835 ((and mark-active (< (region-beginning) p) (< p (region-end)))
836 'region)
837 (t
838 (let ((faces (get-char-property p 'face window)))
839 (if (consp faces) (car faces) faces)))))))
840 (t
841 nil))))
842
843 (defvar ns-input-color) ; nsterm.m
844
845 (defun ns-set-foreground-at-mouse ()
846 "Set the foreground color at the mouse location to `ns-input-color'."
847 (interactive)
848 (let* ((pos (mouse-position))
849 (frame (car pos))
850 (face (ns-face-at-pos pos)))
851 (cond
852 ((eq face 'cursor)
853 (modify-frame-parameters frame (list (cons 'cursor-color
854 ns-input-color))))
855 ((not face)
856 (modify-frame-parameters frame (list (cons 'foreground-color
857 ns-input-color))))
858 (t
859 (set-face-foreground face ns-input-color frame)))))
860
861 (defun ns-set-background-at-mouse ()
862 "Set the background color at the mouse location to `ns-input-color'."
863 (interactive)
864 (let* ((pos (mouse-position))
865 (frame (car pos))
866 (face (ns-face-at-pos pos)))
867 (cond
868 ((eq face 'cursor)
869 (modify-frame-parameters frame (list (cons 'cursor-color
870 ns-input-color))))
871 ((not face)
872 (modify-frame-parameters frame (list (cons 'background-color
873 ns-input-color))))
874 (t
875 (set-face-background face ns-input-color frame)))))
876
877 ;; Set some options to be as Nextstep-like as possible.
878 (setq frame-title-format t
879 icon-title-format t)
880
881
882 (defvar ns-initialized nil
883 "Non-nil if Nextstep windowing has been initialized.")
884
885 (declare-function ns-list-services "nsfns.m" ())
886 (declare-function x-open-connection "nsfns.m"
887 (display &optional xrm-string must-succeed))
888
889 ;; Do the actual Nextstep Windows setup here; the above code just
890 ;; defines functions and variables that we use now.
891 (defun ns-initialize-window-system ()
892 "Initialize Emacs for Nextstep (Cocoa / GNUstep) windowing."
893
894 ;; PENDING: not needed?
895 (setq command-line-args (x-handle-args command-line-args))
896
897 (x-open-connection (system-name) nil t)
898
899 (dolist (service (ns-list-services))
900 (if (eq (car service) 'undefined)
901 (ns-define-service (cdr service))
902 (define-key global-map (vector (car service))
903 (ns-define-service (cdr service)))))
904
905 (if (and (eq (get-lisp-resource nil "NXAutoLaunch") t)
906 (eq (get-lisp-resource nil "HideOnAutoLaunch") t))
907 (add-hook 'after-init-hook 'ns-do-hide-emacs))
908
909 ;; FIXME: This will surely lead to "MODIFIED OUTSIDE CUSTOM" warnings.
910 (menu-bar-mode (if (get-lisp-resource nil "Menus") 1 -1))
911
912 (setq ns-initialized t))
913
914 (add-to-list 'handle-args-function-alist '(ns . x-handle-args))
915 (add-to-list 'frame-creation-function-alist '(ns . x-create-frame-with-faces))
916 (add-to-list 'window-system-initialization-alist '(ns . ns-initialize-window-system))
917
918
919 (provide 'ns-win)
920
921 ;;; ns-win.el ends here