lisp/term/ns-win.el

   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
1608 ;; arch-tag: eb138a45-4e2e-4d68-b1c9-a39665731644
1609 ;;; ns-win.el ends here