Mercurial > emacs
diff lisp/term/ns-win.el @ 96675:d45acf0c8d23
merging Emacs.app (NeXTstep port)
author | Adrian Robert <Adrian.B.Robert@gmail.com> |
---|---|
date | Tue, 15 Jul 2008 18:15:18 +0000 |
parents | |
children | 9a85c163883d |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/term/ns-win.el Tue Jul 15 18:15:18 2008 +0000 @@ -0,0 +1,1608 @@ +;;; ns-win.el --- lisp side of interface with +;;; NeXT/Open/GNUstep/MacOS X window system +;;; Copyright (C) 1993, 1994, 2005, 2006, 2008 Free Software Foundation, Inc. + +;;; Author: Carl Edman, Christian Limpach, Scott Bender, Christophe de Dinechin, +;;; Adrian Robert +;;; Keywords: terminals + +;;; This file is part of GNU Emacs. +;;; +;;; GNU Emacs is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3, or (at your option) +;;; any later version. +;;; +;;; GNU Emacs is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Emacs; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; ns-win.el: this file is loaded from ../lisp/startup.el when it recognizes +;; that NS windows are to be used. Command line switches are parsed and those +;; pertaining to NS are processed and removed from the command line. The +;; NS display is opened and hooks are set for popping up the initial window. + +;; startup.el will then examine startup files, and eventually call the hooks +;; which create the first window (s). + +;; A number of other NS convenience functions are defined in this file, +;; which works in close coordination with src/nsfns.m. + +;;; Code: + + +(if (not (featurep 'ns-windowing)) + (error "%s: Loading ns-win.el but not compiled for *Step/OS X" + (invocation-name))) + +;; Documentation-purposes only: actually loaded in loadup.el +(require 'frame) +(require 'mouse) +(require 'faces) +(require 'easymenu) +(require 'menu-bar) +(require 'fontset) + +; Not needed? +;(require 'ispell) + +(defun ns-submit-bug-report () + "Submit via mail a bug report on Emacs 23.0.0 for GNUstep / OS X." + (interactive) + (let ((frame-parameters (frame-parameters)) + (server-vendor (ns-server-vendor)) + (server-version (ns-server-version))) + (reporter-submit-bug-report + "Adrian Robert <Adrian.B.Robert@gmail.com>" + ;;"Christophe de Dinechin <descubes@earthlink.net>" + ;;"Scott Bender <emacs@harmony-ds.com>" + ;;"Christian Limpach <chris@nice.ch>" + ;;"Carl Edman <cedman@princeton.edu>" + (concat "Emacs for GNUstep / OS X " ns-version-string) + '(ns-expand-space ns-cursor-blink-rate ns-alternate-modifier + data-directory frame-parameters window-system window-system-version + server-vendor server-version system-configuration-options)))) + + +;;;; Command line argument handling. + +(defvar ns-invocation-args nil) +(defvar ns-command-line-resources nil) + +;; Handler for switches of the form "-switch value" or "-switch". +(defun ns-handle-switch (switch) + (let ((aelt (assoc switch command-line-ns-option-alist))) + (if aelt + (let ((param (nth 3 aelt)) + (value (nth 4 aelt))) + (if value + (setq default-frame-alist + (cons (cons param value) + default-frame-alist)) + (setq default-frame-alist + (cons (cons param + (car ns-invocation-args)) + default-frame-alist) + ns-invocation-args (cdr ns-invocation-args))))))) + +;; Handler for switches of the form "-switch n" +(defun ns-handle-numeric-switch (switch) + (let ((aelt (assoc switch command-line-ns-option-alist))) + (if aelt + (let ((param (nth 3 aelt))) + (setq default-frame-alist + (cons (cons param + (string-to-number (car ns-invocation-args))) + default-frame-alist) + ns-invocation-args + (cdr ns-invocation-args)))))) + +;; Make -iconic apply only to the initial frame! +(defun ns-handle-iconic (switch) + (setq initial-frame-alist + (cons '(visibility . icon) initial-frame-alist))) + +;; Handle the -name option, set the name of +;; the initial frame. +(defun ns-handle-name-switch (switch) + (or (consp ns-invocation-args) + (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (setq initial-frame-alist (cons (cons 'name (car ns-invocation-args)) + initial-frame-alist) + ns-invocation-args (cdr ns-invocation-args))) + +(defun ns-handle-nxopen (switch) + (setq unread-command-events (append unread-command-events '(ns-open-file)) + ns-input-file (append ns-input-file (list (car ns-invocation-args))) + ns-invocation-args (cdr ns-invocation-args))) + +(defun ns-handle-nxopentemp (switch) + (setq unread-command-events (append unread-command-events '(ns-open-temp-file)) + ns-input-file (append ns-input-file (list (car ns-invocation-args))) + ns-invocation-args (cdr ns-invocation-args))) + +(defun ns-ignore-0-arg (switch) + ) +(defun ns-ignore-1-arg (switch) + (setq ns-invocation-args (cdr ns-invocation-args))) +(defun ns-ignore-2-arg (switch) + (setq ns-invocation-args (cddr ns-invocation-args))) + +(defun ns-handle-args (args) + "Here the NS-related command line options in ARGS are processed, +before the user's startup file is loaded. They are copied to +`ns-invocation-args', from which the NS related things are extracted, first +the switch (e.g., \"-fg\") in the following code, and possible values +\(e.g., \"black\") in the option handler code (e.g., ns-handle-switch). +This function returns ARGS minus the arguments that have been processed." + ;; We use ARGS to accumulate the args that we don't handle here, to return. + (setq ns-invocation-args args + args nil) + (while ns-invocation-args + (let* ((this-switch (car ns-invocation-args)) + (orig-this-switch this-switch) + completion argval aelt handler) + (setq ns-invocation-args (cdr ns-invocation-args)) + ;; Check for long options with attached arguments + ;; and separate out the attached option argument into argval. + (if (string-match "^--[^=]*=" this-switch) + (setq argval (substring this-switch (match-end 0)) + this-switch (substring this-switch 0 (1- (match-end 0))))) + ;; Complete names of long options. + (if (string-match "^--" this-switch) + (progn + (setq completion (try-completion this-switch + command-line-ns-option-alist)) + (if (eq completion t) + ;; Exact match for long option. + nil + (if (stringp completion) + (let ((elt (assoc completion command-line-ns-option-alist))) + ;; Check for abbreviated long option. + (or elt + (error "Option `%s' is ambiguous" this-switch)) + (setq this-switch completion)))))) + (setq aelt (assoc this-switch command-line-ns-option-alist)) + (if aelt (setq handler (nth 2 aelt))) + (if handler + (if argval + (let ((ns-invocation-args + (cons argval ns-invocation-args))) + (funcall handler this-switch)) + (funcall handler this-switch)) + (setq args (cons orig-this-switch args))))) + (nreverse args)) + +(defun x-parse-geometry (geom) + "Parse an NS-style geometry string STRING. +Returns an alist of the form ((top . TOP), (left . LEFT) ... ). +The properties returned may include `top', `left', `height', and `width'." + (if (string-match "\\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\) ?\\)?\\)?\\)?" + geom) + (apply 'append + (list + (list (cons 'top (string-to-number (match-string 1 geom)))) + (if (match-string 3 geom) + (list (cons 'left (string-to-number (match-string 3 geom))))) + (if (match-string 5 geom) + (list (cons 'height (string-to-number (match-string 5 geom))))) + (if (match-string 7 geom) + (list (cons 'width (string-to-number (match-string 7 geom))))))) + '())) + + + +;;;; Keyboard mapping. + +;; These tell read-char how to convert +;; these special chars to ASCII. +(put 'backspace 'ascii-character 127) +(put 'delete 'ascii-character 127) +(put 'tab 'ascii-character ?\t) +(put 'S-tab 'ascii-character (logior 16 ?\t)) +(put 'linefeed 'ascii-character ?\n) +(put 'clear 'ascii-character 12) +(put 'return 'ascii-character 13) +(put 'escape 'ascii-character ?\e) + +;; Map certain keypad keys into ASCII characters +;; that people usually expect. +(define-key function-key-map [backspace] [127]) +(define-key function-key-map [delete] [127]) +(define-key function-key-map [tab] [?\t]) +(define-key function-key-map [S-tab] [25]) +(define-key function-key-map [linefeed] [?\n]) +(define-key function-key-map [clear] [11]) +(define-key function-key-map [return] [13]) +(define-key function-key-map [escape] [?\e]) +(define-key function-key-map [M-backspace] [?\M-\d]) +(define-key function-key-map [M-delete] [?\M-\d]) +(define-key function-key-map [M-tab] [?\M-\t]) +(define-key function-key-map [M-linefeed] [?\M-\n]) +(define-key function-key-map [M-clear] [?\M-\013]) +(define-key function-key-map [M-return] [?\M-\015]) +(define-key function-key-map [M-escape] [?\M-\e]) + + +;; Here are some NeXTSTEP like bindings for command key sequences. +(define-key global-map [?\s-,] 'ns-popup-prefs-panel) +(define-key global-map [?\s-'] 'next-multiframe-window) +(define-key global-map [?\s-`] 'other-frame) +(define-key global-map [?\s--] 'center-line) +(define-key global-map [?\s-:] 'ispell) +(define-key global-map [?\s-\;] 'ispell-next) +(define-key global-map [?\s-?] 'info) +(define-key global-map [?\s-^] 'kill-some-buffers) +(define-key global-map [?\s-&] 'kill-this-buffer) +(define-key global-map [?\s-C] 'ns-popup-color-panel) +(define-key global-map [?\s-D] 'dired) +(define-key global-map [?\s-E] 'edit-abbrevs) +(define-key global-map [?\s-L] 'shell-command) +(define-key global-map [?\s-M] 'manual-entry) +(define-key global-map [?\s-S] 'ns-write-file-using-panel) +(define-key global-map [?\s-a] 'mark-whole-buffer) +(define-key global-map [?\s-c] 'ns-copy-including-secondary) +(define-key global-map [?\s-d] 'isearch-repeat-backward) +(define-key global-map [?\s-e] 'isearch-yank-kill) +(define-key global-map [?\s-f] 'isearch-forward) +(define-key global-map [?\s-g] 'isearch-repeat-forward) +(define-key global-map [?\s-h] 'ns-do-hide-emacs) +(define-key global-map [?\s-H] 'ns-do-hide-others) +(define-key global-map [?\s-j] 'exchange-point-and-mark) +(define-key global-map [?\s-k] 'kill-this-buffer) +(define-key global-map [?\s-l] 'goto-line) +(define-key global-map [?\s-m] 'iconify-frame) +(define-key global-map [?\s-n] 'make-frame) +(define-key global-map [?\s-o] 'ns-open-file-using-panel) +(define-key global-map [?\s-p] 'ns-print-buffer) +(define-key global-map [?\s-q] 'save-buffers-kill-emacs) +(define-key global-map [?\s-s] 'save-buffer) +(define-key global-map [?\s-t] 'ns-popup-font-panel) +(define-key global-map [?\s-u] 'revert-buffer) +(define-key global-map [?\s-v] 'yank) +(define-key global-map [?\s-w] 'delete-frame) +(define-key global-map [?\s-x] 'kill-region) +(define-key global-map [?\s-y] 'ns-paste-secondary) +(define-key global-map [?\s-z] 'undo) +(define-key global-map [?\s-|] 'shell-command-on-region) +(define-key global-map [s-kp-bar] 'shell-command-on-region) +; (as in Terminal.app) +(define-key global-map [s-right] 'ns-next-frame) +(define-key global-map [s-left] 'ns-prev-frame) + +(define-key global-map [home] 'beginning-of-buffer) +(define-key global-map [end] 'end-of-buffer) +(define-key global-map [kp-home] 'beginning-of-buffer) +(define-key global-map [kp-end] 'end-of-buffer) +(define-key global-map [kp-prior] 'scroll-down) +(define-key global-map [kp-next] 'scroll-up) + + +;; Special NeXTSTEP generated events are converted to function keys. Here +;; are the bindings for them. +(define-key global-map [ns-power-off] + '(lambda () (interactive) (save-buffers-kill-emacs t))) +(define-key global-map [ns-open-file] 'ns-find-file) +(define-key global-map [ns-open-temp-file] [ns-open-file]) +(define-key global-map [ns-drag-file] 'ns-insert-file) +(define-key global-map [ns-drag-color] 'ns-set-foreground-at-mouse) +(define-key global-map [S-ns-drag-color] 'ns-set-background-at-mouse) +(define-key global-map [ns-drag-text] 'ns-insert-text) +(define-key global-map [ns-change-font] 'ns-respond-to-change-font) +(define-key global-map [ns-open-file-line] 'ns-open-file-select-line) +(define-key global-map [ns-insert-working-text] 'ns-insert-working-text) +(define-key global-map [ns-delete-working-text] 'ns-delete-working-text) +(define-key global-map [ns-spi-service-call] 'ns-spi-service-call) + + + +;;;; Lisp niceties, most used only under ns-extended-platform-support-mode, +;;;; defined below + +(autoload 'ns-grabenv "ns-grabenv" "Get environment from your shell." t nil) +(load "ns-carbon-compat") + +;; alt-up/down scrolling a la Stuart.app +;; only activated if ns-extended-platform-support is on +(defun up-one () (interactive) (scroll-up 1)) +(defun down-one () (interactive) (scroll-down 1)) +(defun left-one () (interactive) (scroll-left 1)) +(defun right-one () (interactive) (scroll-right 1)) + +;; Toggle some additional NS-like features that may interfere with users' +;; expectations coming from emacs on other platforms. +(define-minor-mode ns-extended-platform-support-mode + "Toggle NS extended platform support features. + When this mode is active (no modeline indicator): + - File menus is altered slightly in keeping with conventions. + - Meta-up, meta-down are bound to scroll window up and down one line. + - Meta-p, Meta-n navigate forwards and backwards in the mark ring." + :init-value nil + :global t + :group 'ns + (if ns-extended-platform-support-mode + (progn + (global-set-key [M-up] 'down-one) + (global-set-key [M-down] 'up-one) + ; These conflict w/word-left, word-right + ;;(global-set-key [M-left] 'left-one) + ;;(global-set-key [M-right] 'right-one) + + (setq scroll-preserve-screen-position t) + (transient-mark-mode 1) + + ;; Change file menu to simplify and add a couple of NS-specific items + (easy-menu-remove-item global-map '("menu-bar") 'file) + (easy-menu-add-item global-map '(menu-bar) + (cons "File" menu-bar-ns-file-menu) 'edit)) + (progn + ; undo everything above + (global-unset-key [M-up]) + (global-unset-key [M-down]) + (setq scroll-preserve-screen-position nil) + (transient-mark-mode 0) + (easy-menu-remove-item global-map '("menu-bar") 'file) + (easy-menu-add-item global-map '(menu-bar) + (cons "File" menu-bar-file-menu) 'edit)))) + + +(defun x-setup-function-keys (frame) + "Set up function Keys for NS for given FRAME." + (unless (terminal-parameter frame 'x-setup-function-keys) + (with-selected-frame frame + (setq interprogram-cut-function 'ns-select-text + interprogram-paste-function 'ns-pasteboard-value) +;;; (let ((map (copy-keymap x-alternatives-map))) +;;; (set-keymap-parent map (keymap-parent local-function-key-map)) +;;; (set-keymap-parent local-function-key-map map)) + (setq system-key-alist + (list + (cons (logior (lsh 0 16) 1) 'ns-power-off) + (cons (logior (lsh 0 16) 2) 'ns-open-file) + (cons (logior (lsh 0 16) 3) 'ns-open-temp-file) + (cons (logior (lsh 0 16) 4) 'ns-drag-file) + (cons (logior (lsh 0 16) 5) 'ns-drag-color) + (cons (logior (lsh 0 16) 6) 'ns-drag-text) + (cons (logior (lsh 0 16) 7) 'ns-change-font) + (cons (logior (lsh 0 16) 8) 'ns-open-file-line) + (cons (logior (lsh 0 16) 9) 'ns-insert-working-text) + (cons (logior (lsh 0 16) 10) 'ns-delete-working-text) + (cons (logior (lsh 0 16) 11) 'ns-spi-service-call) + (cons (logior (lsh 1 16) 32) 'f1) + (cons (logior (lsh 1 16) 33) 'f2) + (cons (logior (lsh 1 16) 34) 'f3) + (cons (logior (lsh 1 16) 35) 'f4) + (cons (logior (lsh 1 16) 36) 'f5) + (cons (logior (lsh 1 16) 37) 'f6) + (cons (logior (lsh 1 16) 38) 'f7) + (cons (logior (lsh 1 16) 39) 'f8) + (cons (logior (lsh 1 16) 40) 'f9) + (cons (logior (lsh 1 16) 41) 'f10) + (cons (logior (lsh 1 16) 42) 'f11) + (cons (logior (lsh 1 16) 43) 'f12) + (cons (logior (lsh 1 16) 44) 'kp-insert) + (cons (logior (lsh 1 16) 45) 'kp-delete) + (cons (logior (lsh 1 16) 46) 'kp-home) + (cons (logior (lsh 1 16) 47) 'kp-end) + (cons (logior (lsh 1 16) 48) 'kp-prior) + (cons (logior (lsh 1 16) 49) 'kp-next) + (cons (logior (lsh 1 16) 50) 'print-screen) + (cons (logior (lsh 1 16) 51) 'scroll-lock) + (cons (logior (lsh 1 16) 52) 'pause) + (cons (logior (lsh 1 16) 53) 'system) + (cons (logior (lsh 1 16) 54) 'break) + (cons (logior (lsh 1 16) 56) 'please-tell-carl-what-this-key-is-called-56) + (cons (logior (lsh 1 16) 61) 'please-tell-carl-what-this-key-is-called-61) + (cons (logior (lsh 1 16) 62) 'please-tell-carl-what-this-key-is-called-62) + (cons (logior (lsh 1 16) 63) 'please-tell-carl-what-this-key-is-called-63) + (cons (logior (lsh 1 16) 64) 'please-tell-carl-what-this-key-is-called-64) + (cons (logior (lsh 1 16) 69) 'please-tell-carl-what-this-key-is-called-69) + (cons (logior (lsh 1 16) 70) 'please-tell-carl-what-this-key-is-called-70) + (cons (logior (lsh 1 16) 71) 'please-tell-carl-what-this-key-is-called-71) + (cons (logior (lsh 1 16) 72) 'please-tell-carl-what-this-key-is-called-72) + (cons (logior (lsh 1 16) 73) 'please-tell-carl-what-this-key-is-called-73) + (cons (logior (lsh 2 16) 3) 'kp-enter) + (cons (logior (lsh 2 16) 9) 'kp-tab) + (cons (logior (lsh 2 16) 28) 'kp-quit) + (cons (logior (lsh 2 16) 35) 'kp-hash) + (cons (logior (lsh 2 16) 42) 'kp-multiply) + (cons (logior (lsh 2 16) 43) 'kp-add) + (cons (logior (lsh 2 16) 44) 'kp-separator) + (cons (logior (lsh 2 16) 45) 'kp-subtract) + (cons (logior (lsh 2 16) 46) 'kp-decimal) + (cons (logior (lsh 2 16) 47) 'kp-divide) + (cons (logior (lsh 2 16) 48) 'kp-0) + (cons (logior (lsh 2 16) 49) 'kp-1) + (cons (logior (lsh 2 16) 50) 'kp-2) + (cons (logior (lsh 2 16) 51) 'kp-3) + (cons (logior (lsh 2 16) 52) 'kp-4) + (cons (logior (lsh 2 16) 53) 'kp-5) + (cons (logior (lsh 2 16) 54) 'kp-6) + (cons (logior (lsh 2 16) 55) 'kp-7) + (cons (logior (lsh 2 16) 56) 'kp-8) + (cons (logior (lsh 2 16) 57) 'kp-9) + (cons (logior (lsh 2 16) 60) 'kp-less) + (cons (logior (lsh 2 16) 61) 'kp-equal) + (cons (logior (lsh 2 16) 62) 'kp-more) + (cons (logior (lsh 2 16) 64) 'kp-at) + (cons (logior (lsh 2 16) 92) 'kp-backslash) + (cons (logior (lsh 2 16) 96) 'kp-backtick) + (cons (logior (lsh 2 16) 124) 'kp-bar) + (cons (logior (lsh 2 16) 126) 'kp-tilde) + (cons (logior (lsh 2 16) 157) 'kp-mu) + (cons (logior (lsh 2 16) 165) 'kp-yen) + (cons (logior (lsh 2 16) 167) 'kp-paragraph) + (cons (logior (lsh 2 16) 172) 'left) + (cons (logior (lsh 2 16) 173) 'up) + (cons (logior (lsh 2 16) 174) 'right) + (cons (logior (lsh 2 16) 175) 'down) + (cons (logior (lsh 2 16) 176) 'kp-ring) + (cons (logior (lsh 2 16) 201) 'kp-square) + (cons (logior (lsh 2 16) 204) 'kp-cube) + (cons (logior (lsh 3 16) 8) 'backspace) + (cons (logior (lsh 3 16) 9) 'tab) + (cons (logior (lsh 3 16) 10) 'linefeed) + (cons (logior (lsh 3 16) 11) 'clear) + (cons (logior (lsh 3 16) 13) 'return) + (cons (logior (lsh 3 16) 18) 'pause) + (cons (logior (lsh 3 16) 25) 'S-tab) + (cons (logior (lsh 3 16) 27) 'escape) + (cons (logior (lsh 3 16) 127) 'delete) + )) + (set-terminal-parameter frame 'x-setup-function-keys t)))) + + + +;;;; Miscellaneous mouse bindings. + +;;; Allow shift-clicks to work just like under NS +(defun mouse-extend-region (event) + "Move point or mark so as to extend region. +This should be bound to a mouse click event type." + (interactive "e") + (mouse-minibuffer-check event) + (let ((posn (event-end event))) + (if (not (windowp (posn-window posn))) + (error "Cursor not in text area of window")) + (select-window (posn-window posn)) + (cond + ((not (numberp (posn-point posn)))) + ((or (not mark-active) (> (abs (- (posn-point posn) (point))) + (abs (- (posn-point posn) (mark))))) + (let ((point-save (point))) + (unwind-protect + (progn + (goto-char (posn-point posn)) + (push-mark nil t t) + (or transient-mark-mode + (sit-for 1))) + (goto-char point-save)))) + (t + (goto-char (posn-point posn)))))) + +(define-key global-map [S-mouse-1] 'mouse-extend-region) +(global-unset-key [S-down-mouse-1]) + + + +; must come after keybindings + +(fmakunbound 'clipboard-yank) +(fmakunbound 'clipboard-kill-ring-save) +(fmakunbound 'clipboard-kill-region) +(fmakunbound 'menu-bar-enable-clipboard) + +;; Add a couple of menus and rearrange some others; easiest just to redo toplvl +;; Note keymap defns must be given last-to-first +(define-key global-map [menu-bar] (make-sparse-keymap "menu-bar")) + +(cond ((eq system-type 'darwin) + (setq menu-bar-final-items '(buffer windows services help-menu))) + ;; otherwise, gnustep + (t + (setq menu-bar-final-items '(buffer windows services hide-app quit)) ) +) + +;; add standard top-level items to GNUstep menu +(cond ((not (eq system-type 'darwin)) + (define-key global-map [menu-bar quit] '("Quit" . save-buffers-kill-emacs)) + (define-key global-map [menu-bar hide-app] '("Hide" . ns-do-hide-emacs)) +)) + +(define-key global-map [menu-bar services] + (cons "Services" (make-sparse-keymap "Services"))) +(define-key global-map [menu-bar windows] (make-sparse-keymap "Windows")) +(define-key global-map [menu-bar buffer] + (cons "Buffers" global-buffers-menu-map)) +;; (cons "Buffers" (make-sparse-keymap "Buffers"))) +(define-key global-map [menu-bar tools] (cons "Tools" menu-bar-tools-menu)) +(define-key global-map [menu-bar options] (cons "Options" menu-bar-options-menu)) +(define-key global-map [menu-bar edit] (cons "Edit" menu-bar-edit-menu)) +(define-key global-map [menu-bar file] (cons "File" menu-bar-file-menu)) + +;; If running under GNUstep, rename "Help" to "Info" +(cond ((eq system-type 'darwin) + (define-key global-map [menu-bar help-menu] + (cons "Help" menu-bar-help-menu))) + (t + (let ((contents (reverse (cdr menu-bar-help-menu)))) + (setq menu-bar-help-menu + (append (list 'keymap) (cdr contents) (list "Info")))) + (define-key global-map [menu-bar help-menu] + (cons "Info" menu-bar-help-menu)))) + + +;;;; Add to help / info menu +(defun info-ns-emacs () + "Jump to ns-emacs info item." + (interactive) + (info "ns-emacs")) + +(define-key menu-bar-help-menu [ns-bug-report] + '("Report Emacs.app bug..." . ns-submit-bug-report)) +(define-key menu-bar-help-menu [info-ns] + '("Emacs.app Manual" . info-ns-emacs)) +(if (not (eq system-type 'darwin)) + ;; in OS X it's in the app menu already + (define-key menu-bar-help-menu [info-panel] + '("About Emacs..." . ns-do-emacs-info-panel))) + + +;;;; File menu, replaces standard under ns-extended-platform-support +(defvar menu-bar-ns-file-menu (make-sparse-keymap "File")) +(define-key menu-bar-ns-file-menu [one-window] + '("Remove Splits" . delete-other-windows)) +(define-key menu-bar-ns-file-menu [split-window] + '("Split Window" . split-window-vertically)) + +(define-key menu-bar-ns-file-menu [separator-print] '("--")) + +(defvar ns-ps-print-menu-map (make-sparse-keymap "Postscript Print")) +(define-key ns-ps-print-menu-map [ps-print-region] + '("Region (B+W)" . ps-print-region)) +(define-key ns-ps-print-menu-map [ps-print-buffer] + '("Buffer (B+W)" . ps-print-buffer)) +(define-key ns-ps-print-menu-map [ps-print-region-faces] + '("Region" . ps-print-region-with-faces)) +(define-key ns-ps-print-menu-map [ps-print-buffer-faces] + '("Buffer" . ns-ps-print-buffer-with-faces)) +(define-key menu-bar-ns-file-menu [postscript-print] + (cons "Postscript Print" ns-ps-print-menu-map)) + +(define-key menu-bar-ns-file-menu [print-region] + '("Print Region" . print-region)) +(define-key menu-bar-ns-file-menu [print-buffer] + '("Print Buffer" . ns-print-buffer)) + +(define-key menu-bar-ns-file-menu [separator-save] '("--")) + +(define-key menu-bar-ns-file-menu [recover-session] + '("Recover Crashed Session" . recover-session)) +(define-key menu-bar-ns-file-menu [revert-buffer] + '("Revert Buffer" . revert-buffer)) +(define-key menu-bar-ns-file-menu [write-file] + '("Save Buffer As..." . ns-write-file-using-panel)) +(define-key menu-bar-ns-file-menu [save-buffer] '("Save Buffer" . save-buffer)) + +(define-key menu-bar-ns-file-menu [kill-buffer] + '("Kill Current Buffer" . kill-this-buffer)) +(define-key menu-bar-ns-file-menu [delete-this-frame] + '("Close Frame" . delete-frame)) + +(define-key menu-bar-ns-file-menu [separator-open] '("--")) + +(define-key menu-bar-ns-file-menu [insert-file] + '("Insert File..." . insert-file)) +(define-key menu-bar-ns-file-menu [dired] + '("Open Directory..." . ns-open-file-using-panel)) +(define-key menu-bar-ns-file-menu [open-file] + '("Open File..." . ns-open-file-using-panel)) +(define-key menu-bar-ns-file-menu [make-frame] + '("New Frame" . make-frame)) + + +;;;; Edit menu: Modify slightly + +; Substitute a Copy function that works better under X (for GNUstep) +(easy-menu-remove-item global-map '("menu-bar" "edit") 'copy) +(define-key-after menu-bar-edit-menu [copy] + '(menu-item "Copy" ns-copy-including-secondary + :enable mark-active + :help "Copy text in region between mark and current position") + 'cut) + +; Change to same precondition as select-and-paste, as we don't have +; 'x-selection-exists-p +(easy-menu-remove-item global-map '("menu-bar" "edit") 'paste) +(define-key-after menu-bar-edit-menu [paste] + '(menu-item "Paste" yank + :enable (and (cdr yank-menu) (not buffer-read-only)) + :help "Paste (yank) text most recently cut/copied") + 'copy) + +; Change text to be more consistent with surrounding menu items 'paste', etc. +(easy-menu-remove-item global-map '("menu-bar" "edit") 'paste-from-menu) +(define-key-after menu-bar-edit-menu [select-paste] + '(menu-item "Select and Paste" yank-menu + :enable (and (cdr yank-menu) (not buffer-read-only)) + :help "Choose a string from the kill ring and paste it") + 'paste) + +; Separate undo item from cut/paste section, add spell for platform consistency +(define-key-after menu-bar-edit-menu [separator-undo] '("--") 'undo) +(define-key-after menu-bar-edit-menu [spell] '("Spell" . ispell-menu-map) 'fill) + + +;;;; Windows menu +(defun menu-bar-select-frame () + (interactive) + (make-frame-visible last-command-event) + (raise-frame last-command-event) + (select-frame last-command-event)) + +(defun menu-bar-update-frames () + ;; If user discards the Windows item, play along. + (and (lookup-key (current-global-map) [menu-bar windows]) + (let ((frames (frame-list)) + (frames-menu (make-sparse-keymap "Select Frame"))) + (setcdr frames-menu + (nconc + (mapcar '(lambda (frame) + (nconc (list frame + (cdr (assq 'name (frame-parameters frame))) + (cons nil nil)) + 'menu-bar-select-frame)) + frames) + (cdr frames-menu))) + (define-key frames-menu [separator-frames] '("--")) + (define-key frames-menu [popup-color-panel] + '("Colors..." . ns-popup-color-panel)) + (define-key frames-menu [popup-font-panel] + '("Font Panel..." . ns-popup-font-panel)) + (define-key frames-menu [separator-arrange] '("--")) + (define-key frames-menu [arrange-all-frames] + '("Arrange All Frames" . ns-arrange-all-frames)) + (define-key frames-menu [arrange-visible-frames] + '("Arrange Visible Frames" . ns-arrange-visible-frames)) + ;; Don't use delete-frame as event name + ;; because that is a special event. + (define-key (current-global-map) [menu-bar windows] + (cons "Windows" frames-menu))))) + +(defun force-menu-bar-update-buffers () + ;; This is a hack to get around fact that we already checked + ;; frame-or-buffer-changed-p and reset it, so menu-bar-update-buffers + ;; does not pick up any change. + (menu-bar-update-buffers t)) + +(add-hook 'menu-bar-update-fab-hook 'menu-bar-update-frames) +(add-hook 'menu-bar-update-fab-hook 'force-menu-bar-update-buffers) + +(defun menu-bar-update-frames-and-buffers () + (if (frame-or-buffer-changed-p) + (run-hooks 'menu-bar-update-fab-hook))) + +(setq menu-bar-update-hook + (delq 'menu-bar-update-buffers menu-bar-update-hook)) +(add-hook 'menu-bar-update-hook 'menu-bar-update-frames-and-buffers) + +(menu-bar-update-frames-and-buffers) + + +;; ns-arrange functions contributed +;; by Eberhard Mandler <mandler@dbag.ulm.DaimlerBenz.COM> +(defun ns-arrange-all-frames () + "Arranges all frames according to topline" + (interactive) + (ns-arrange-frames t)) + +(defun ns-arrange-visible-frames () + "Arranges all visible frames according to topline" + (interactive) + (ns-arrange-frames nil)) + +(defun ns-arrange-frames ( vis) + (let ((frame (next-frame)) + (end-frame (selected-frame)) + (inc-x 20) ;relative position of frames + (inc-y 22) + (x-pos 100) ;start position + (y-pos 40) + (done nil)) + (while (not done) ;cycle through all frames + (if (not (or vis (eq (frame-visible-p frame) t))) + (setq x-pos x-pos); do nothing; true case + (set-frame-position frame x-pos y-pos) + (setq x-pos (+ x-pos inc-x)) + (setq y-pos (+ y-pos inc-y)) + (raise-frame frame)) + (select-frame frame) + (setq frame (next-frame)) + (setq done (equal frame end-frame))) + (set-frame-position end-frame x-pos y-pos) + (raise-frame frame) + (select-frame frame))) + + +;;;; Services +(defun ns-define-service (path) + (let ((mapping [menu-bar services]) + (service (mapconcat 'identity path "/")) + (name (intern + (mapconcat '(lambda (s) (if (= s 32) "-" (char-to-string s))) + (mapconcat 'identity (cons "ns-service" path) "-") + "")))) + ;; This defines the function + (eval (append (list 'defun name) + `((arg) + (interactive "p") + (let* ((in-string (if (stringp arg) arg (if mark-active + (buffer-substring (region-beginning) (region-end))))) + (out-string (ns-perform-service (,@service) in-string))) + (cond + ((stringp arg) out-string) + ((and out-string (or (not in-string) + (not (string= in-string out-string)))) + (if mark-active (delete-region (region-beginning) (region-end))) + (insert out-string) + (setq deactivate-mark nil))))))) + (cond + ((lookup-key global-map mapping) + (while (cdr path) + (setq mapping (vconcat mapping (list (intern (car path))))) + (if (not (keymapp (lookup-key global-map mapping))) + (define-key global-map mapping + (cons (car path) (make-sparse-keymap (car path))))) + (setq path (cdr path))) + (setq mapping (vconcat mapping (list (intern (car path))))) + (define-key global-map mapping (cons (car path) name)))) + name)) + +(precompute-menubar-bindings) + +(defun ns-spi-service-call () + "Respond to a service request to Emacs.app." + (interactive) + (cond ((string-equal ns-input-spi-name "open-selection") + (switch-to-buffer (generate-new-buffer "*untitled*")) + (insert ns-input-spi-arg)) + ((string-equal ns-input-spi-name "open-file") + (dnd-open-file ns-input-spi-arg nil)) + ((string-equal ns-input-spi-name "mail-selection") + (compose-mail) + (rfc822-goto-eoh) + (forward-line 1) + (insert ns-input-spi-arg)) + ((string-equal ns-input-spi-name "mail-to") + (compose-mail ns-input-spi-arg)) + (t (error (concat "Service " ns-input-spi-name " not recognized"))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +;;;; Composed key sequence handling for NS system input methods. +;;;; (On NS systems, input methods are provided for CJK characters, +;;;; etc. which require multiple keystrokes, and during entry a +;;;; partial ("working") result is typically shown in the editing window.) + +(defface ns-working-text-face + '((t :underline t)) + "Face used to highlight working text during compose sequence insert." + :group 'ns) + +(defvar ns-working-overlay nil + "Overlay used to highlight working text during compose sequence insert.") +(make-variable-buffer-local 'ns-working-overlay) +(defvar ns-working-overlay-len 0 + "Length of working text during compose sequence insert.") +(make-variable-buffer-local 'ns-working-overlay-len) + +; Based on mac-win.el 2007/08/26 unicode-2. This will fail if called +; from an "interactive" function. +(defun ns-in-echo-area () + "Whether, for purposes of inserting working composition text, the minibuffer +is currently being used." + (or isearch-mode + (and cursor-in-echo-area (current-message)) + ;; Overlay strings are not shown in some cases. + (get-char-property (point) 'invisible) + (and (not (bobp)) + (or (and (get-char-property (point) 'display) + (eq (get-char-property (1- (point)) 'display) + (get-char-property (point) 'display))) + (and (get-char-property (point) 'composition) + (eq (get-char-property (1- (point)) 'composition) + (get-char-property (point) 'composition))))))) + +; currently not used, doesn't work because the 'interactive' here stays +; for subinvocations +(defun ns-insert-working-text () + (interactive) + (if (ns-in-echo-area) (ns-echo-working-text) (ns-put-working-text))) + +(defun ns-put-working-text () + "Insert contents of ns-working-text as UTF8 string and mark with +ns-working-overlay. Any previously existing working text is cleared first. +The overlay is assigned the face ns-working-text-face." + (interactive) + (if ns-working-overlay (ns-delete-working-text)) + (let ((start (point))) + (insert ns-working-text) + (overlay-put (setq ns-working-overlay (make-overlay start (point) + (current-buffer) nil t)) + 'face 'ns-working-text-face) + (setq ns-working-overlay-len (+ ns-working-overlay-len (- (point) start))))) + +(defun ns-echo-working-text () + "Echo contents of ns-working-text in message display area. +See ns-insert-working-text." + (if ns-working-overlay (ns-unecho-working-text)) + (let* ((msg (current-message)) + (msglen (length msg)) + message-log-max) + (setq ns-working-overlay-len (length ns-working-text)) + (setq msg (concat msg ns-working-text)) + (put-text-property msglen (+ msglen ns-working-overlay-len) 'face 'ns-working-text-face msg) + (message "%s" msg) + (setq ns-working-overlay t))) + +(defun ns-delete-working-text() + "Delete working text and clear ns-working-overlay." + (interactive) + (delete-backward-char ns-working-overlay-len) + (setq ns-working-overlay-len 0) + (delete-overlay ns-working-overlay)) + +(defun ns-unecho-working-text() + "Delete working text from echo area and clear ns-working-overlay." + (let ((msg (current-message)) + message-log-max) + (setq msg (substring msg 0 (- (length msg) ns-working-overlay-len))) + (setq ns-working-overlay-len 0) + (setq ns-working-overlay nil))) + + +;;;; OS X file system Unicode UTF-8 NFD (decomposed form) support +;; Lisp code based on utf-8m.el, by Seiji Zenitani, Eiji Honjoh, and +;; Carsten Bormann. +(if (eq system-type 'darwin) + (progn + + (defun ns-utf8-nfd-post-read-conversion (length) + "Calls ns-convert-utf8-nfd-to-nfc to compose char sequences." + (save-excursion + (save-restriction + (narrow-to-region (point) (+ (point) length)) + (let ((str (buffer-string))) + (delete-region (point-min) (point-max)) + (insert (ns-convert-utf8-nfd-to-nfc str)) + (- (point-max) (point-min)) + )))) + + (define-coding-system 'utf-8-nfd + "UTF-8 NFD (decomposed) encoding." + :coding-type 'utf-8 + :mnemonic ?U + :charset-list '(unicode) + :post-read-conversion 'ns-utf8-nfd-post-read-conversion) + (set-file-name-coding-system 'utf-8-nfd))) + +;; PENDING: disable composition-based display for Indic scripts as it +;; is not working well under NS for some reason +(set-char-table-range composition-function-table + '(#x0900 . #x0DFF) nil) + + +;;;; Inter-app communications support. + +(defun ns-insert-text () + "Insert contents of ns-input-text at point." + (interactive) + (insert ns-input-text) + (setq ns-input-text nil)) + +(defun ns-insert-file () + "Insert contents of file ns-input-file like insert-file but with less +prompting. If file is a directory perform a find-file on it." + (interactive) + (let ((f)) + (setq f (car ns-input-file)) + (setq ns-input-file (cdr ns-input-file)) + (if (file-directory-p f) + (find-file f) + (push-mark (+ (point) (car (cdr (insert-file-contents f)))))))) + +(defvar ns-select-overlay nil + "Overlay used to highlight areas in files requested by NS apps.") +(make-variable-buffer-local 'ns-select-overlay) + +(defun ns-open-file-select-line () + "Brings up a buffer containing file ns-input-file,\n\ +and highlights lines indicated by ns-input-line." + (interactive) + (ns-find-file) + (cond + ((and ns-input-line (buffer-modified-p)) + (if ns-select-overlay + (setq ns-select-overlay (delete-overlay ns-select-overlay))) + (deactivate-mark) + (goto-line (if (consp ns-input-line) + (min (car ns-input-line) (cdr ns-input-line)) + ns-input-line))) + (ns-input-line + (if (not ns-select-overlay) + (overlay-put (setq ns-select-overlay (make-overlay (point-min) (point-min))) + 'face 'highlight)) + (let ((beg (save-excursion + (goto-line (if (consp ns-input-line) + (min (car ns-input-line) (cdr ns-input-line)) + ns-input-line)) + (point))) + (end (save-excursion + (goto-line (+ 1 (if (consp ns-input-line) + (max (car ns-input-line) (cdr ns-input-line)) + ns-input-line))) + (point)))) + (move-overlay ns-select-overlay beg end) + (deactivate-mark) + (goto-char beg))) + (t + (if ns-select-overlay + (setq ns-select-overlay (delete-overlay ns-select-overlay)))))) + +(defun ns-unselect-line () + "Removes any NS highlight a buffer may contain." + (if ns-select-overlay + (setq ns-select-overlay (delete-overlay ns-select-overlay)))) + +(add-hook 'first-change-hook 'ns-unselect-line) + + + +;;;; Preferences handling. + +(defun get-lisp-resource (arg1 arg2) + (let ((res (ns-get-resource arg1 arg2))) + (cond + ((not res) 'unbound) + ((string-equal (upcase res) "YES") t) + ((string-equal (upcase res) "NO") nil) + (t (read res))))) + +(defun ns-save-preferences () + "Set all the defaults." + (interactive) + ;; Global preferences + (ns-set-resource nil "AlternateModifier" (symbol-name ns-alternate-modifier)) + (ns-set-resource nil "CommandModifier" (symbol-name ns-command-modifier)) + (ns-set-resource nil "ControlModifier" (symbol-name ns-control-modifier)) + (ns-set-resource nil "FunctionModifier" (symbol-name ns-function-modifier)) + (ns-set-resource nil "CursorBlinkRate" + (if ns-cursor-blink-rate + (number-to-string ns-cursor-blink-rate) + "NO")) + (ns-set-resource nil "ExpandSpace" + (if ns-expand-space + (number-to-string ns-expand-space) + "NO")) + (ns-set-resource nil "GSFontAntiAlias" (if ns-antialias-text "YES" "NO")) + (ns-set-resource nil "UseQuickdrawSmoothing" + (if ns-use-qd-smoothing "YES" "NO")) + (ns-set-resource nil "UseSystemHighlightColor" + (if ns-use-system-highlight-color "YES" "NO")) + ;; Default frame parameters + (let ((p (frame-parameters))) + (let ((f (assq 'font p))) + (if f (ns-set-resource nil "Font" (ns-font-name (cdr f))))) + (let ((fs (assq 'fontsize p))) + (if fs (ns-set-resource nil "FontSize" (number-to-string (cdr fs))))) + (let ((fgc (assq 'foreground-color p))) + (if fgc (ns-set-resource nil "Foreground" (cdr fgc)))) + (let ((bgc (assq 'background-color p))) + (if bgc (ns-set-resource nil "Background" (cdr bgc)))) + (let ((cc (assq 'cursor-color p))) + (if cc (ns-set-resource nil "CursorColor" (cdr cc)))) + (let ((ct (assq 'cursor-type p))) + (if ct (ns-set-resource nil "CursorType" + (if (symbolp (cdr ct)) (symbol-name (cdr ct)) (cdr ct))))) + (let ((under (assq 'underline p))) + (if under (ns-set-resource nil "Underline" + (cond ((eq (cdr under) t) "YES") + ((eq (cdr under) nil) "NO") + (t (cdr under)))))) + (let ((ibw (assq 'internal-border-width p))) + (if ibw (ns-set-resource nil "InternalBorderWidth" + (number-to-string (cdr ibw))))) + (let ((vsb (assq 'vertical-scroll-bars p))) + (if vsb (ns-set-resource nil "VerticalScrollBars" (cond + ((eq t (cdr vsb)) "YES") + ((eq nil (cdr vsb)) "NO") + ((eq 'left (cdr vsb)) "left") + ((eq 'right (cdr vsb)) "right") + (t nil))))) + (let ((height (assq 'height p))) + (if height (ns-set-resource nil "Height" + (number-to-string (cdr height))))) + (let ((width (assq 'width p))) + (if width (ns-set-resource nil "Width" + (number-to-string (cdr width))))) + (let ((top (assq 'top p))) + (if top (ns-set-resource nil "Top" + (number-to-string (cdr top))))) + (let ((left (assq 'left p))) + (if left (ns-set-resource nil "Left" + (number-to-string (cdr left))))) + ;; These not fully supported + (let ((ar (assq 'auto-raise p))) + (if ar (ns-set-resource nil "AutoRaise" + (if (cdr ar) "YES" "NO")))) + (let ((al (assq 'auto-lower p))) + (if al (ns-set-resource nil "AutoLower" + (if (cdr al) "YES" "NO")))) + (let ((mbl (assq 'menu-bar-lines p))) + (if mbl (ns-set-resource nil "Menus" + (if (cdr mbl) "YES" "NO")))) + ) + (let ((fl (face-list))) + (while (consp fl) + (or (eq 'default (car fl)) + ;; dont save Default* since it causes all created faces to + ;; inherit its values. The properties of the default face + ;; have already been saved from the frame-parameters anyway. + (let* ((name (symbol-name (car fl))) + (font (face-font (car fl))) +; (fontsize (face-fontsize (car fl))) + (foreground (face-foreground (car fl))) + (background (face-background (car fl))) + (underline (face-underline-p (car fl))) + (italic (face-italic-p (car fl))) + (bold (face-bold-p (car fl))) + (stipple (face-stipple (car fl)))) +; (ns-set-resource nil (concat name ".attributeFont") +; (if font font nil)) +; (ns-set-resource nil (concat name ".attributeFontSize") +; (if fontsize (number-to-string fontsize) nil)) + (ns-set-resource nil (concat name ".attributeForeground") + (if foreground foreground nil)) + (ns-set-resource nil (concat name ".attributeBackground") + (if background background nil)) + (ns-set-resource nil (concat name ".attributeUnderline") + (if underline "YES" nil)) + (ns-set-resource nil (concat name ".attributeItalic") + (if italic "YES" nil)) + (ns-set-resource nil (concat name ".attributeBold") + (if bold "YES" nil)) + (and stipple + (or (stringp stipple) + (setq stipple (prin1-to-string stipple)))) + (ns-set-resource nil (concat name ".attributeStipple") + (if stipple stipple nil)))) + (setq fl (cdr fl))))) + +;; call ns-save-preferences when menu-bar-options-save is called +(fset 'menu-bar-options-save-orig (symbol-function 'menu-bar-options-save)) +(defun ns-save-options () + (interactive) + (menu-bar-options-save-orig) + (ns-save-preferences)) +(fset 'menu-bar-options-save (symbol-function 'ns-save-options)) + + +;;;; File handling. + +(defun ns-open-file-using-panel () + "Pop up open-file panel, and load the result in a buffer." + (interactive) + ; prompt dir defaultName isLoad initial + (setq ns-input-file (ns-read-file-name "Select File to Load" nil t nil)) + (if ns-input-file + (and (setq ns-input-file (list ns-input-file)) (ns-find-file)))) + +(defun ns-write-file-using-panel () + "Pop up save-file panel, and save buffer in resulting name." + (interactive) + (let (ns-output-file) + ; prompt dir defaultName isLoad initial + (setq ns-output-file (ns-read-file-name "Save As" nil nil nil)) + (message ns-output-file) + (if ns-output-file (write-file ns-output-file)))) + +(defun ns-find-file () + "Do a find-file with the ns-input-file as argument." + (interactive) + (let ((f) (file) (bufwin1) (bufwin2)) + (setq f (file-truename (car ns-input-file))) + (setq ns-input-file (cdr ns-input-file)) + (setq file (find-file-noselect f)) + (setq bufwin1 (get-buffer-window file 'visible)) + (setq bufwin2 (get-buffer-window "*scratch*" 'visibile)) + (cond + (bufwin1 + (select-frame (window-frame bufwin1)) + (raise-frame (window-frame bufwin1)) + (select-window bufwin1)) + ((and (eq ns-pop-up-frames 'fresh) bufwin2) + (ns-hide-emacs 'activate) + (select-frame (window-frame bufwin2)) + (raise-frame (window-frame bufwin2)) + (select-window bufwin2) + (find-file f)) + (ns-pop-up-frames + (ns-hide-emacs 'activate) + (let ((pop-up-frames t)) (pop-to-buffer file nil))) + (t + (ns-hide-emacs 'activate) + (find-file f))))) + + + +;;;; Frame-related functions. + +;; Don't show the frame name; that's redundant with NS. +(setq-default mode-line-frame-identification '(" ")) + +(defvar ns-pop-up-frames 'fresh + "* Should file opened upon request from the Workspace be opened in a new frame ? +If t, always. If nil, never. Otherwise a new frame is opened +unless the current buffer is a scratch buffer.") + +;; You say tomAYto, I say tomAHto.. +(defvaralias 'ns-option-modifier 'ns-alternate-modifier) + +(defun ns-do-hide-emacs () + (interactive) + (ns-hide-emacs t)) + +(defun ns-do-hide-others () + (interactive) + (ns-hide-others)) + +(defun ns-do-emacs-info-panel () + (interactive) + (ns-emacs-info-panel)) + +(defun ns-next-frame () + "Switch to next visible frame." + (interactive) + (other-frame 1)) +(defun ns-prev-frame () + "Switch to previous visible frame." + (interactive) + (other-frame -1)) + +; If no position specified, make new frame offset by 25 from current. +(add-hook 'before-make-frame-hook + '(lambda () + (let ((left (cdr (assq 'left (frame-parameters)))) + (top (cdr (assq 'top (frame-parameters))))) + (if (consp left) (setq left (cadr left))) + (if (consp top) (setq top (cadr top))) + (cond + ((or (assq 'top parameters) (assq 'left parameters))) + ((or (not left) (not top))) + (t + (setq parameters (cons (cons 'left (+ left 25)) + (cons (cons 'top (+ top 25)) + parameters)))))))) + +; frame will be focused anyway, so select it +(add-hook 'after-make-frame-functions 'select-frame) + +;;; (defun ns-win-suspend-error () +;;; (error "Suspending an emacs running under *Step/OS X makes no sense")) +;;; (add-hook 'suspend-hook 'ns-win-suspend-error) +;;; (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame +;;; global-map) + +;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ; +;; see http://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html . +(defun ns-toggle-toolbar (&optional frame) + "Switches the tool bar on and off in frame FRAME. + If FRAME is nil, the change applies to the selected frame." + (interactive) + (modify-frame-parameters frame + (list (cons 'tool-bar-lines + (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0) + 0 1)) )) + (if (not tool-bar-mode) (tool-bar-mode t))) + +; Redefine from frame.el +(define-minor-mode blink-cursor-mode + "Toggle blinking cursor mode. +With a numeric argument, turn blinking cursor mode on if ARG is positive, +otherwise turn it off. When blinking cursor mode is enabled, the +cursor of the selected window blinks. + +Note that this command is effective only when Emacs +displays through a window system, because then Emacs does its own +cursor display. On a text-only terminal, this is not implemented." + :init-value (not (or noninteractive + no-blinking-cursor + (eq ns-cursor-blink-rate nil))) + :initialize 'custom-initialize-safe-default + :group 'cursor + :global t + (if blink-cursor-mode + (setq ns-cursor-blink-mode t) + (setq ns-cursor-blink-mode nil))) + + + +;;;; Dialog-related functions. + +;; Ask user for confirm before printing. Due to Kevin Rodgers. +(defun ns-print-buffer () + "Interactive front-end to `print-buffer': asks for user confirmation first." + (interactive) + (if (and (interactive-p) + (or (listp last-nonmenu-event) + (and (char-or-string-p (event-basic-type last-command-event)) + (memq 'super (event-modifiers last-command-event))))) + (let ((last-nonmenu-event (if (listp last-nonmenu-event) + last-nonmenu-event + ;; fake it: + `(mouse-1 POSITION 1)))) + (if (y-or-n-p (format "Print buffer %s? " (buffer-name))) + (print-buffer) + (error "Cancelled"))) + (print-buffer))) + +(defun ns-yes-or-no-p (prompt) + "As yes-or-no-p except that NS panel always used for querying." + (interactive) + (setq last-nonmenu-event nil) + (yes-or-no-p prompt)) + + +;;;; Font support. + +(defalias 'x-list-fonts 'ns-list-fonts) +;; Needed for font listing functions under both backend and normal +(setq scalable-fonts-allowed t) + +;; Set to use font panel instead +(defalias 'generate-fontset-menu 'ns-popup-font-panel) +(defalias 'mouse-set-font 'ns-popup-font-panel) + +(defun ns-respond-to-change-font () + "Respond to changeFont: event, expecting ns-input-font and\n\ +ns-input-fontsize of new font." + (interactive) + (modify-frame-parameters (selected-frame) + (list (cons 'font ns-input-font) + (cons 'fontsize ns-input-fontsize))) + (set-frame-font ns-input-font)) + + +;; Default fontset for Mac OS X. This is mainly here to show how a fontset +;; can be set up manually. Ordinarily, fontsets are auto-created whenever +;; a font is chosen by +(defvar ns-standard-fontset-spec +; Only some code supports this so far, so use uglier XLFD version +; "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai" +"-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1,han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1,cyrillic:-*-Trebuchet$MS-*-*-*-*-10-*-*-*-*-*-iso10646-1" + "String of fontset spec of the standard fontset. +This defines a fontset consisting of the Courier and other fonts that +come with OS X\". +See the documentation of `create-fontset-from-fontset-spec for the format.") + +;; Conditional on new-fontset so bootstrapping works on non-GUI compiles +(if (fboundp 'new-fontset) + (progn + ;; Setup the default fontset. + (setup-default-fontset) + ;; Create the standard fontset. + (create-fontset-from-fontset-spec ns-standard-fontset-spec t) +)) + +;(setq default-frame-alist (cons (cons 'font "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard") default-frame-alist)) + +;; add some additional scripts to var we use for fontset generation +(setq script-representative-chars + (cons '(kana #xff8a) + (cons '(symbol #x2295 #x2287 #x25a1) + script-representative-chars))) + + +;;;; Pasteboard support. + +(defun ns-get-pasteboard () + "Returns the value of the pasteboard." + (ns-get-cut-buffer-internal 'PRIMARY)) + +(defun ns-set-pasteboard (string) + "Store STRING into the NS server's pasteboard." + ;; Check the data type of STRING. + (if (not (stringp string)) (error "Nonstring given to pasteboard")) + (ns-store-cut-buffer-internal 'PRIMARY string)) + +;;; We keep track of the last text selected here, so we can check the +;;; current selection against it, and avoid passing back our own text +;;; from ns-pasteboard-value. +(defvar ns-last-selected-text nil) + +;;; Put TEXT, a string, on the pasteboard. +(defun ns-select-text (text &optional push) + ;; Don't send the pasteboard too much text. + ;; It becomes slow, and if really big it causes errors. + (ns-set-pasteboard text) + (setq ns-last-selected-text text)) + +;;; Return the value of the current NS selection. For compatibility +;;; with older NS applications, this checks cut buffer 0 before +;;; retrieving the value of the primary selection. +(defun ns-pasteboard-value () + (let (text) + + ;; Consult the selection, then the cut buffer. Treat empty strings + ;; as if they were unset. + (or text (setq text (ns-get-pasteboard))) + (if (string= text "") (setq text nil)) + + (cond + ((not text) nil) + ((eq text ns-last-selected-text) nil) + ((string= text ns-last-selected-text) + ;; Record the newer string, so subsequent calls can use the `eq' test. + (setq ns-last-selected-text text) + nil) + (t + (setq ns-last-selected-text text))))) + +(defun ns-copy-including-secondary () + (interactive) + (call-interactively 'kill-ring-save) + (ns-store-cut-buffer-internal 'SECONDARY + (buffer-substring (point) (mark t)))) +(defun ns-paste-secondary () + (interactive) + (insert (ns-get-cut-buffer-internal 'SECONDARY))) + +;; PENDING: not sure what to do here.. for now interprog- are set in +;; init-fn-keys, and unsure whether these x- settings have an effect +;;(setq interprogram-cut-function 'ns-select-text +;; interprogram-paste-function 'ns-pasteboard-value) +; these only needed if above not working +(defalias 'x-select-text 'ns-select-text) +(defalias 'x-cut-buffer-or-selection-value 'ns-pasteboard-value) +(defalias 'x-disown-selection-internal 'ns-disown-selection-internal) +(defalias 'x-get-selection-internal 'ns-get-selection-internal) +(defalias 'x-own-selection-internal 'ns-own-selection-internal) + +(set-face-background 'region "ns_selection_color") + + + +;;;; Scrollbar handling. + +(global-set-key [vertical-scroll-bar down-mouse-1] 'ns-handle-scroll-bar-event) +(global-unset-key [vertical-scroll-bar mouse-1]) +(global-unset-key [vertical-scroll-bar drag-mouse-1]) + +(defun ns-scroll-bar-move (event) + "Scroll the frame according to an NS scroller event." + (interactive "e") + (let* ((pos (event-end event)) + (window (nth 0 pos)) + (scale (nth 2 pos))) + (save-excursion + (set-buffer (window-buffer window)) + (cond + ((eq (car scale) (cdr scale)) + (goto-char (point-max))) + ((= (car scale) 0) + (goto-char (point-min))) + (t + (goto-char (+ (point-min) 1 + (scroll-bar-scale scale (- (point-max) (point-min))))))) + (beginning-of-line) + (set-window-start window (point)) + (vertical-motion (/ (window-height window) 2) window)))) + +(defun ns-handle-scroll-bar-event (event) + "Handle scroll bar EVENT to emulate Mac Toolbox style scrolling." + (interactive "e") + (let* ((position (event-start event)) + (bar-part (nth 4 position)) + (window (nth 0 position)) + (old-window (selected-window))) + (cond + ((eq bar-part 'ratio) + (ns-scroll-bar-move event)) + ((eq bar-part 'handle) + (if (eq window (selected-window)) + (track-mouse (ns-scroll-bar-move event)) + ; track-mouse faster for selected window, slower for unselected + (ns-scroll-bar-move event))) + (t + (select-window window) + (cond + ((eq bar-part 'up) + (goto-char (window-start window)) + (scroll-down 1)) + ((eq bar-part 'above-handle) + (scroll-down)) + ((eq bar-part 'below-handle) + (scroll-up)) + ((eq bar-part 'down) + (goto-char (window-start window)) + (scroll-up 1))) + (select-window old-window))))) + + +;;;; Color support. + +(defvar x-colors (ns-list-colors) + "The list of colors defined in non-PANTONE color files.") +(defvar colors x-colors + "The list of colors defined in non-PANTONE color files.") + +(defun ns-defined-colors (&optional frame) + "Return a list of colors supported for a particular frame. +The argument FRAME specifies which frame to try. +The value may be different for frames on different NS displays." + (or frame (setq frame (selected-frame))) + (let ((all-colors x-colors) + (this-color nil) + (defined-colors nil)) + (while all-colors + (setq this-color (car all-colors) + all-colors (cdr all-colors)) +; (and (face-color-supported-p frame this-color t) + (setq defined-colors (cons this-color defined-colors))) +;) + defined-colors)) +(defalias 'x-defined-colors 'ns-defined-colors) +(defalias 'xw-defined-colors 'ns-defined-colors) + +;; Convenience and work-around for fact that set color fns now require named. +(defun ns-set-background-alpha (alpha) + "Sets alpha (opacity) of background. +Set from 0.0 (fully transparent) to 1.0 (fully opaque; default). +Note, tranparency works better on Tiger (10.4) and higher." + (interactive "nSet background alpha to: ") + (let ((bgcolor (cdr (assq 'background-color (frame-parameters))))) + (set-frame-parameter (selected-frame) + 'background-color (ns-set-alpha bgcolor alpha)))) + +;; Functions for color panel + drag +(defun ns-face-at-pos (pos) + (let* ((frame (car pos)) + (frame-pos (cons (cadr pos) (cddr pos))) + (window (window-at (car frame-pos) (cdr frame-pos) frame)) + (window-pos (coordinates-in-window-p frame-pos window)) + (buffer (window-buffer window)) + (edges (window-edges window))) + (cond + ((not window-pos) + nil) + ((eq window-pos 'mode-line) + 'modeline) + ((eq window-pos 'vertical-line) + 'default) + ((consp window-pos) + (save-excursion + (set-buffer buffer) + (let ((p (car (compute-motion (window-start window) + (cons (nth 0 edges) (nth 1 edges)) + (window-end window) + frame-pos + (- (window-width window) 1) + nil + window)))) + (cond + ((eq p (window-point window)) + 'cursor) + ((and mark-active (< (region-beginning) p) (< p (region-end))) + 'region) + (t + (let ((faces (get-char-property p 'face window))) + (if (consp faces) (car faces) faces))))))) + (t + nil)))) + +(defun ns-set-foreground-at-mouse () + "Set the foreground color at the mouse location to ns-input-color." + (interactive) + (let* ((pos (mouse-position)) + (frame (car pos)) + (face (ns-face-at-pos pos))) + (cond + ((eq face 'cursor) + (modify-frame-parameters frame (list (cons 'cursor-color + ns-input-color)))) + ((not face) + (modify-frame-parameters frame (list (cons 'foreground-color + ns-input-color)))) + (t + (set-face-foreground face ns-input-color frame))))) + +(defun ns-set-background-at-mouse () + "Set the background color at the mouse location to ns-input-color." + (interactive) + (let* ((pos (mouse-position)) + (frame (car pos)) + (face (ns-face-at-pos pos))) + (cond + ((eq face 'cursor) + (modify-frame-parameters frame (list (cons 'cursor-color + ns-input-color)))) + ((not face) + (modify-frame-parameters frame (list (cons 'background-color + ns-input-color)))) + (t + (set-face-background face ns-input-color frame))))) + + + +;; Misc aliases +(defalias 'x-display-mm-width 'ns-display-mm-width) +(defalias 'x-display-mm-height 'ns-display-mm-height) +(defalias 'x-display-backing-store 'ns-display-backing-store) +(defalias 'x-display-save-under 'ns-display-save-under) +(defalias 'x-display-visual-class 'ns-display-visual-class) +(defalias 'x-display-screens 'ns-display-screens) +(defalias 'x-focus-frame 'ns-focus-frame) + +;; Set some options to be as NS-like as possible. +(setq frame-title-format t + icon-title-format t) + +;; Set up browser connectivity +(setq browse-url-browser-function 'browse-url-generic) +(cond ((eq system-type 'darwin) + (setq browse-url-generic-program "open")) + ;; otherwise, gnustep + (t + (setq browse-url-generic-program "gopen")) ) + + +(defvar ns-initialized nil + "Non-nil if NS windowing has been initialized.") + +;;; Do the actual NS Windows setup here; the above code just defines +;;; functions and variables that we use now. +(defun ns-initialize-window-system () + "Initialize Emacs for NS (Cocoa / GNUstep) windowing." + + ; PENDING: not needed? + (setq command-line-args (ns-handle-args command-line-args)) + + (ns-open-connection (system-name) nil t) + + (let ((services (ns-list-services))) + (while services + (if (eq (caar services) 'undefined) + (ns-define-service (cdar services)) + (define-key global-map (vector (caar services)) + (ns-define-service (cdar services))) + ) + (setq services (cdr services)))) + + (if (and (eq (get-lisp-resource nil "NXAutoLaunch") t) + (eq (get-lisp-resource nil "HideOnAutoLaunch") t)) + (add-hook 'after-init-hook 'ns-do-hide-emacs)) + + (menu-bar-mode (if (get-lisp-resource nil "Menus") 1 -1)) + (mouse-wheel-mode 1) + + (setq ns-initialized t)) + +(add-to-list 'handle-args-function-alist '(ns . ns-handle-args)) +(add-to-list 'frame-creation-function-alist '(ns . x-create-frame-with-faces)) +(add-to-list 'window-system-initialization-alist '(ns . ns-initialize-window-system)) + + +(provide 'ns-win) + +;;; ns-win.el ends here