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