lisp/term/mac-win.el

   1 ;;; mac-win.el --- parse switches controlling interface with Mac window system -*-coding: utf-8-*-
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008  Free Software Foundation, Inc.
   5
   6 ;; Author: Andrew Choi <akochoi@mac.com>
   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 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Mac-win.el:  this file is loaded from ../lisp/startup.el when it recognizes
  27 ;; that Mac windows are to be used.  Command line switches are parsed and those
  28 ;; pertaining to Mac are processed and removed from the command line.  The
  29 ;; Mac display is opened and hooks are set for popping up the initial window.
  30
  31 ;; startup.el will then examine startup files, and eventually call the hooks
  32 ;; which create the first window(s).
  33
  34 ;;; Code:
  35 \f
  36 ;; These are the standard X switches from the Xt Initialize.c file of
  37 ;; Release 4.
  38
  39 ;; Command line         Resource Manager string
  40
  41 ;; +rv                  *reverseVideo
  42 ;; +synchronous         *synchronous
  43 ;; -background          *background
  44 ;; -bd                  *borderColor
  45 ;; -bg                  *background
  46 ;; -bordercolor         *borderColor
  47 ;; -borderwidth         .borderWidth
  48 ;; -bw                  .borderWidth
  49 ;; -display             .display
  50 ;; -fg                  *foreground
  51 ;; -fn                  *font
  52 ;; -font                *font
  53 ;; -foreground          *foreground
  54 ;; -geometry            .geometry
  55 ;; -iconic              .iconic
  56 ;; -name                .name
  57 ;; -reverse             *reverseVideo
  58 ;; -rv                  *reverseVideo
  59 ;; -selectionTimeout    .selectionTimeout
  60 ;; -synchronous         *synchronous
  61 ;; -xrm
  62
  63 ;; An alist of X options and the function which handles them.  See
  64 ;; ../startup.el.
  65
  66 ;; (if (not (eq window-system 'mac))
  67 ;;     (error "%s: Loading mac-win.el but not compiled for Mac" (invocation-name)))
  68
  69 (require 'frame)
  70 (require 'mouse)
  71 (require 'scroll-bar)
  72 (require 'faces)
  73 (require 'select)
  74 (require 'menu-bar)
  75 (require 'fontset)
  76 (require 'dnd)
  77
  78 (defvar mac-charset-info-alist)
  79 (defvar mac-service-selection)
  80 (defvar mac-system-script-code)
  81 (defvar mac-apple-event-map)
  82 (defvar mac-font-panel-mode)
  83 (defvar mac-ts-active-input-overlay)
  84 (defvar mac-ts-active-input-buf)
  85 (defvar x-invocation-args)
  86 (declare-function mac-code-convert-string "mac.c")
  87 (declare-function mac-coerce-ae-data "mac.c")
  88 (declare-function mac-resume-apple-event "macselect.c")
  89 ;; Suppress warning when compiling on non-Mac.
  90 (declare-function mac-font-panel-mode "mac-win.el")
  91 (declare-function mac-atsu-font-face-attributes "macfns.c")
  92 (declare-function mac-ae-set-reply-parameter "macselect.c")
  93 (declare-function mac-clear-font-name-table "macfns.c")
  94
  95 (defvar x-command-line-resources nil)
  96
  97 ;; Handler for switches of the form "-switch value" or "-switch".
  98 (defun x-handle-switch (switch)
  99   (let ((aelt (assoc switch command-line-x-option-alist)))
 100     (if aelt
 101         (let ((param (nth 3 aelt))
 102               (value (nth 4 aelt)))
 103           (if value
 104               (setq default-frame-alist
 105                     (cons (cons param value)
 106                           default-frame-alist))
 107             (setq default-frame-alist
 108                   (cons (cons param
 109                               (car x-invocation-args))
 110                         default-frame-alist)
 111                   x-invocation-args (cdr x-invocation-args)))))))
 112
 113 ;; Handler for switches of the form "-switch n"
 114 (defun x-handle-numeric-switch (switch)
 115   (let ((aelt (assoc switch command-line-x-option-alist)))
 116     (if aelt
 117         (let ((param (nth 3 aelt)))
 118           (setq default-frame-alist
 119                 (cons (cons param
 120                             (string-to-number (car x-invocation-args)))
 121                       default-frame-alist)
 122                 x-invocation-args
 123                 (cdr x-invocation-args))))))
 124
 125 ;; Handle options that apply to initial frame only
 126 (defun x-handle-initial-switch (switch)
 127   (let ((aelt (assoc switch command-line-x-option-alist)))
 128     (if aelt
 129         (let ((param (nth 3 aelt))
 130               (value (nth 4 aelt)))
 131           (if value
 132               (setq initial-frame-alist
 133                     (cons (cons param value)
 134                           initial-frame-alist))
 135             (setq initial-frame-alist
 136                   (cons (cons param
 137                               (car x-invocation-args))
 138                         initial-frame-alist)
 139                   x-invocation-args (cdr x-invocation-args)))))))
 140
 141 ;; Make -iconic apply only to the initial frame!
 142 (defun x-handle-iconic (switch)
 143   (setq initial-frame-alist
 144         (cons '(visibility . icon) initial-frame-alist)))
 145
 146 ;; Handle the -xrm option.
 147 (defun x-handle-xrm-switch (switch)
 148   (unless (consp x-invocation-args)
 149     (error "%s: missing argument to `%s' option" (invocation-name) switch))
 150   (setq x-command-line-resources
 151         (if (null x-command-line-resources)
 152             (car x-invocation-args)
 153           (concat x-command-line-resources "\n" (car x-invocation-args))))
 154   (setq x-invocation-args (cdr x-invocation-args)))
 155
 156 (declare-function x-parse-geometry "frame.c" (string))
 157
 158 ;; Handle the geometry option
 159 (defun x-handle-geometry (switch)
 160   (let* ((geo (x-parse-geometry (car x-invocation-args)))
 161          (left (assq 'left geo))
 162          (top (assq 'top geo))
 163          (height (assq 'height geo))
 164          (width (assq 'width geo)))
 165     (if (or height width)
 166         (setq default-frame-alist
 167               (append default-frame-alist
 168                       '((user-size . t))
 169                       (if height (list height))
 170                       (if width (list width)))
 171               initial-frame-alist
 172               (append initial-frame-alist
 173                       '((user-size . t))
 174                       (if height (list height))
 175                       (if width (list width)))))
 176     (if (or left top)
 177         (setq initial-frame-alist
 178               (append initial-frame-alist
 179                       '((user-position . t))
 180                       (if left (list left))
 181                       (if top (list top)))))
 182     (setq x-invocation-args (cdr x-invocation-args))))
 183
 184 (defvar x-resource-name)
 185
 186 ;; Handle the -name option.  Set the variable x-resource-name
 187 ;; to the option's operand; set the name of
 188 ;; the initial frame, too.
 189 (defun x-handle-name-switch (switch)
 190   (or (consp x-invocation-args)
 191       (error "%s: missing argument to `%s' option" (invocation-name) switch))
 192   (setq x-resource-name (car x-invocation-args)
 193         x-invocation-args (cdr x-invocation-args))
 194   (setq initial-frame-alist (cons (cons 'name x-resource-name)
 195                                   initial-frame-alist)))
 196
 197 (defvar x-display-name nil
 198   "The display name specifying server and frame.")
 199
 200 (defun x-handle-display (switch)
 201   (setq x-display-name (car x-invocation-args)
 202         x-invocation-args (cdr x-invocation-args)))
 203
 204 (defun x-handle-args (args)
 205   "Process the X-related command line options in ARGS.
 206 This is done before the user's startup file is loaded.  They are copied to
 207 `x-invocation-args', from which the X-related things are extracted, first
 208 the switch (e.g., \"-fg\") in the following code, and possible values
 209 \(e.g., \"black\") in the option handler code (e.g., x-handle-switch).
 210 This function returns ARGS minus the arguments that have been processed."
 211   ;; We use ARGS to accumulate the args that we don't handle here, to return.
 212   (setq x-invocation-args args
 213         args nil)
 214   (while (and x-invocation-args
 215               (not (equal (car x-invocation-args) "--")))
 216     (let* ((this-switch (car x-invocation-args))
 217            (orig-this-switch this-switch)
 218            completion argval aelt handler)
 219       (setq x-invocation-args (cdr x-invocation-args))
 220       ;; Check for long options with attached arguments
 221       ;; and separate out the attached option argument into argval.
 222       (if (string-match "^--[^=]*=" this-switch)
 223           (setq argval (substring this-switch (match-end 0))
 224                 this-switch (substring this-switch 0 (1- (match-end 0)))))
 225       ;; Complete names of long options.
 226       (if (string-match "^--" this-switch)
 227           (progn
 228             (setq completion (try-completion this-switch command-line-x-option-alist))
 229             (if (eq completion t)
 230                 ;; Exact match for long option.
 231                 nil
 232               (if (stringp completion)
 233                   (let ((elt (assoc completion command-line-x-option-alist)))
 234                     ;; Check for abbreviated long option.
 235                     (or elt
 236                         (error "Option `%s' is ambiguous" this-switch))
 237                     (setq this-switch completion))))))
 238       (setq aelt (assoc this-switch command-line-x-option-alist))
 239       (if aelt (setq handler (nth 2 aelt)))
 240       (if handler
 241           (if argval
 242               (let ((x-invocation-args
 243                      (cons argval x-invocation-args)))
 244                 (funcall handler this-switch))
 245             (funcall handler this-switch))
 246         (setq args (cons orig-this-switch args)))))
 247   (nconc (nreverse args) x-invocation-args))
 248
 249 \f
 250 ;;
 251 ;; Standard Mac cursor shapes
 252 ;;
 253
 254 (defconst mac-pointer-arrow 0)
 255 (defconst mac-pointer-copy-arrow 1)
 256 (defconst mac-pointer-alias-arrow 2)
 257 (defconst mac-pointer-contextual-menu-arrow 3)
 258 (defconst mac-pointer-I-beam 4)
 259 (defconst mac-pointer-cross 5)
 260 (defconst mac-pointer-plus 6)
 261 (defconst mac-pointer-watch 7)
 262 (defconst mac-pointer-closed-hand 8)
 263 (defconst mac-pointer-open-hand 9)
 264 (defconst mac-pointer-pointing-hand 10)
 265 (defconst mac-pointer-counting-up-hand 11)
 266 (defconst mac-pointer-counting-down-hand 12)
 267 (defconst mac-pointer-counting-up-and-down-hand 13)
 268 (defconst mac-pointer-spinning 14)
 269 (defconst mac-pointer-resize-left 15)
 270 (defconst mac-pointer-resize-right 16)
 271 (defconst mac-pointer-resize-left-right 17)
 272 ;; Mac OS X 10.2 and later
 273 (defconst mac-pointer-not-allowed 18)
 274 ;; Mac OS X 10.3 and later
 275 (defconst mac-pointer-resize-up 19)
 276 (defconst mac-pointer-resize-down 20)
 277 (defconst mac-pointer-resize-up-down 21)
 278 (defconst mac-pointer-poof 22)
 279
 280 ;;
 281 ;; Standard X cursor shapes that have Mac counterparts
 282 ;;
 283
 284 (defconst x-pointer-left-ptr mac-pointer-arrow)
 285 (defconst x-pointer-xterm mac-pointer-I-beam)
 286 (defconst x-pointer-crosshair mac-pointer-cross)
 287 (defconst x-pointer-plus mac-pointer-plus)
 288 (defconst x-pointer-watch mac-pointer-watch)
 289 (defconst x-pointer-hand2 mac-pointer-pointing-hand)
 290 (defconst x-pointer-left-side mac-pointer-resize-left)
 291 (defconst x-pointer-right-side mac-pointer-resize-right)
 292 (defconst x-pointer-sb-h-double-arrow mac-pointer-resize-left-right)
 293 (defconst x-pointer-top-side mac-pointer-resize-up)
 294 (defconst x-pointer-bottom-side mac-pointer-resize-down)
 295 (defconst x-pointer-sb-v-double-arrow mac-pointer-resize-up-down)
 296
 297 \f
 298 ;;
 299 ;; Available colors
 300 ;;
 301 ;; The ordering of the colors is chosen for the user's convenience in
 302 ;; `list-colors-display', which displays the reverse of this list.
 303 ;; Roughly speaking, `list-colors-display' orders by (i) named shades
 304 ;; of grey with hue 0.0, sorted by value (ii) named colors with
 305 ;; saturation 1.0, sorted by hue, (iii) named non-white colors with
 306 ;; saturation less than 1.0, sorted by hue, (iv) other named shades of
 307 ;; white, (v) numbered colors sorted by hue, and (vi) numbered shades
 308 ;; of grey.
 309
 310 (defvar x-colors
 311   '("gray100" "gray99" "gray98" "gray97" "gray96" "gray95" "gray94" "gray93" "gray92"
 312     "gray91" "gray90" "gray89" "gray88" "gray87" "gray86" "gray85" "gray84" "gray83"
 313     "gray82" "gray81" "gray80" "gray79" "gray78" "gray77" "gray76" "gray75" "gray74"
 314     "gray73" "gray72" "gray71" "gray70" "gray69" "gray68" "gray67" "gray66" "gray65"
 315     "gray64" "gray63" "gray62" "gray61" "gray60" "gray59" "gray58" "gray57" "gray56"
 316     "gray55" "gray54" "gray53" "gray52" "gray51" "gray50" "gray49" "gray48" "gray47"
 317     "gray46" "gray45" "gray44" "gray43" "gray42" "gray41" "gray40" "gray39" "gray38"
 318     "gray37" "gray36" "gray35" "gray34" "gray33" "gray32" "gray31" "gray30" "gray29"
 319     "gray28" "gray27" "gray26" "gray25" "gray24" "gray23" "gray22" "gray21" "gray20"
 320     "gray19" "gray18" "gray17" "gray16" "gray15" "gray14" "gray13" "gray12" "gray11"
 321     "gray10" "gray9" "gray8" "gray7" "gray6" "gray5" "gray4" "gray3" "gray2" "gray1"
 322     "gray0" "LightPink1" "LightPink2" "LightPink3" "LightPink4" "pink1" "pink2" "pink3"
 323     "pink4" "PaleVioletRed1" "PaleVioletRed2" "PaleVioletRed3" "PaleVioletRed4"
 324     "LavenderBlush1" "LavenderBlush2" "LavenderBlush3" "LavenderBlush4" "VioletRed1"
 325     "VioletRed2" "VioletRed3" "VioletRed4" "HotPink1" "HotPink2" "HotPink3" "HotPink4"
 326     "DeepPink1" "DeepPink2" "DeepPink3" "DeepPink4" "maroon1" "maroon2" "maroon3"
 327     "maroon4" "orchid1" "orchid2" "orchid3" "orchid4" "plum1" "plum2" "plum3" "plum4"
 328     "thistle1" "thistle2" "thistle3" "thistle4" "MediumOrchid1" "MediumOrchid2"
 329     "MediumOrchid3" "MediumOrchid4" "DarkOrchid1" "DarkOrchid2" "DarkOrchid3"
 330     "DarkOrchid4" "purple1" "purple2" "purple3" "purple4" "MediumPurple1"
 331     "MediumPurple2" "MediumPurple3" "MediumPurple4" "SlateBlue1" "SlateBlue2"
 332     "SlateBlue3" "SlateBlue4" "RoyalBlue1" "RoyalBlue2" "RoyalBlue3" "RoyalBlue4"
 333     "LightSteelBlue1" "LightSteelBlue2" "LightSteelBlue3" "LightSteelBlue4" "SlateGray1"
 334     "SlateGray2" "SlateGray3" "SlateGray4" "DodgerBlue1" "DodgerBlue2" "DodgerBlue3"
 335     "DodgerBlue4" "SteelBlue1" "SteelBlue2" "SteelBlue3" "SteelBlue4" "SkyBlue1"
 336     "SkyBlue2" "SkyBlue3" "SkyBlue4" "LightSkyBlue1" "LightSkyBlue2" "LightSkyBlue3"
 337     "LightSkyBlue4" "LightBlue1" "LightBlue2" "LightBlue3" "LightBlue4" "CadetBlue1"
 338     "CadetBlue2" "CadetBlue3" "CadetBlue4" "azure1" "azure2" "azure3" "azure4"
 339     "LightCyan1" "LightCyan2" "LightCyan3" "LightCyan4" "PaleTurquoise1"
 340     "PaleTurquoise2" "PaleTurquoise3" "PaleTurquoise4" "DarkSlateGray1" "DarkSlateGray2"
 341     "DarkSlateGray3" "DarkSlateGray4" "aquamarine1" "aquamarine2" "aquamarine3"
 342     "aquamarine4" "SeaGreen1" "SeaGreen2" "SeaGreen3" "SeaGreen4" "honeydew1"
 343     "honeydew2" "honeydew3" "honeydew4" "DarkSeaGreen1" "DarkSeaGreen2" "DarkSeaGreen3"
 344     "DarkSeaGreen4" "PaleGreen1" "PaleGreen2" "PaleGreen3" "PaleGreen4"
 345     "DarkOliveGreen1" "DarkOliveGreen2" "DarkOliveGreen3" "DarkOliveGreen4" "OliveDrab1"
 346     "OliveDrab2" "OliveDrab3" "OliveDrab4" "ivory1" "ivory2" "ivory3" "ivory4"
 347     "LightYellow1" "LightYellow2" "LightYellow3" "LightYellow4" "khaki1" "khaki2"
 348     "khaki3" "khaki4" "LemonChiffon1" "LemonChiffon2" "LemonChiffon3" "LemonChiffon4"
 349     "LightGoldenrod1" "LightGoldenrod2" "LightGoldenrod3" "LightGoldenrod4" "cornsilk1"
 350     "cornsilk2" "cornsilk3" "cornsilk4" "goldenrod1" "goldenrod2" "goldenrod3"
 351     "goldenrod4" "DarkGoldenrod1" "DarkGoldenrod2" "DarkGoldenrod3" "DarkGoldenrod4"
 352     "wheat1" "wheat2" "wheat3" "wheat4" "NavajoWhite1" "NavajoWhite2" "NavajoWhite3"
 353     "NavajoWhite4" "burlywood1" "burlywood2" "burlywood3" "burlywood4" "AntiqueWhite1"
 354     "AntiqueWhite2" "AntiqueWhite3" "AntiqueWhite4" "bisque1" "bisque2" "bisque3"
 355     "bisque4" "tan1" "tan2" "tan3" "tan4" "PeachPuff1" "PeachPuff2" "PeachPuff3"
 356     "PeachPuff4" "seashell1" "seashell2" "seashell3" "seashell4" "chocolate1"
 357     "chocolate2" "chocolate3" "chocolate4" "sienna1" "sienna2" "sienna3" "sienna4"
 358     "LightSalmon1" "LightSalmon2" "LightSalmon3" "LightSalmon4" "salmon1" "salmon2"
 359     "salmon3" "salmon4" "coral1" "coral2" "coral3" "coral4" "tomato1" "tomato2"
 360     "tomato3" "tomato4" "MistyRose1" "MistyRose2" "MistyRose3" "MistyRose4" "snow1"
 361     "snow2" "snow3" "snow4" "RosyBrown1" "RosyBrown2" "RosyBrown3" "RosyBrown4"
 362     "IndianRed1" "IndianRed2" "IndianRed3" "IndianRed4" "firebrick1" "firebrick2"
 363     "firebrick3" "firebrick4" "brown1" "brown2" "brown3" "brown4" "magenta1" "magenta2"
 364     "magenta3" "magenta4" "blue1" "blue2" "blue3" "blue4" "DeepSkyBlue1" "DeepSkyBlue2"
 365     "DeepSkyBlue3" "DeepSkyBlue4" "turquoise1" "turquoise2" "turquoise3" "turquoise4"
 366     "cyan1" "cyan2" "cyan3" "cyan4" "SpringGreen1" "SpringGreen2" "SpringGreen3"
 367     "SpringGreen4" "green1" "green2" "green3" "green4" "chartreuse1" "chartreuse2"
 368     "chartreuse3" "chartreuse4" "yellow1" "yellow2" "yellow3" "yellow4" "gold1" "gold2"
 369     "gold3" "gold4" "orange1" "orange2" "orange3" "orange4" "DarkOrange1" "DarkOrange2"
 370     "DarkOrange3" "DarkOrange4" "OrangeRed1" "OrangeRed2" "OrangeRed3" "OrangeRed4"
 371     "red1" "red2" "red3" "red4" "lavender blush" "ghost white" "lavender" "alice blue"
 372     "azure" "light cyan" "mint cream" "honeydew" "ivory" "light goldenrod yellow"
 373     "light yellow" "beige" "floral white" "old lace" "blanched almond" "moccasin"
 374     "papaya whip" "bisque" "antique white" "linen" "peach puff" "seashell" "misty rose"
 375     "snow" "light pink" "pink" "hot pink" "deep pink" "maroon" "pale violet red"
 376     "violet red" "medium violet red" "violet" "plum" "thistle" "orchid" "medium orchid"
 377     "dark orchid" "purple" "blue violet" "medium purple" "light slate blue"
 378     "medium slate blue" "slate blue" "dark slate blue" "midnight blue" "navy"
 379     "dark blue" "light steel blue" "cornflower blue" "dodger blue" "royal blue"
 380     "light slate gray" "slate gray" "dark slate gray" "steel blue" "cadet blue"
 381     "light sky blue" "sky blue" "light blue" "powder blue" "pale turquoise" "turquoise"
 382     "medium turquoise" "dark cyan" "aquamarine" "medium aquamarine" "light sea green"
 383     "medium sea green" "sea green" "dark sea green" "pale green" "lime green"
 384     "forest green" "light green" "green yellow" "yellow green" "olive drab"
 385     "dark olive green" "lemon chiffon" "khaki" "dark khaki" "cornsilk"
 386     "pale goldenrod" "light goldenrod" "goldenrod" "dark goldenrod" "wheat"
 387     "navajo white" "tan" "burlywood" "sandy brown" "peru" "chocolate" "saddle brown"
 388     "sienna" "rosy brown" "dark salmon" "coral" "tomato" "light salmon" "salmon"
 389     "light coral" "indian red" "firebrick" "brown" "dark red" "magenta"
 390     "dark magenta" "dark violet" "medium blue" "blue" "deep sky blue"
 391     "cyan" "medium spring green" "spring green" "green" "lawn green" "chartreuse"
 392     "yellow" "gold" "orange" "dark orange" "orange red" "red" "white" "white smoke"
 393     "gainsboro" "light grey" "gray" "dark grey" "dim gray" "black" )
 394   "The list of X colors from the `rgb.txt' file.
 395 XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp")
 396
 397 (defun xw-defined-colors (&optional frame)
 398   "Internal function called by `defined-colors', which see."
 399   (or frame (setq frame (selected-frame)))
 400   (let ((all-colors x-colors)
 401         (this-color nil)
 402         (defined-colors nil))
 403     (while all-colors
 404       (setq this-color (car all-colors)
 405             all-colors (cdr all-colors))
 406       (and (color-supported-p this-color frame t)
 407            (setq defined-colors (cons this-color defined-colors))))
 408     defined-colors))
 409 \f
 410 ;;;; Function keys
 411
 412 (defun x-setup-function-keys (frame)
 413   "Setup Function Keys for mac."
 414   ;; Don't do this twice on the same display, or it would break
 415   ;; normal-erase-is-backspace-mode.
 416   (unless (terminal-parameter frame 'x-setup-function-keys)
 417     (with-selected-frame frame
 418       ;; Map certain keypad keys into ASCII characters
 419       ;; that people usually expect.
 420       (define-key local-function-key-map [backspace] [?\d])
 421       (define-key local-function-key-map [delete] [?\d])
 422       (define-key local-function-key-map [tab] [?\t])
 423       (define-key local-function-key-map [linefeed] [?\n])
 424       (define-key local-function-key-map [clear] [?\C-l])
 425       (define-key local-function-key-map [return] [?\C-m])
 426       (define-key local-function-key-map [escape] [?\e])
 427       (define-key local-function-key-map [M-backspace] [?\M-\d])
 428       (define-key local-function-key-map [M-delete] [?\M-\d])
 429       (define-key local-function-key-map [M-tab] [?\M-\t])
 430       (define-key local-function-key-map [M-linefeed] [?\M-\n])
 431       (define-key local-function-key-map [M-clear] [?\M-\C-l])
 432       (define-key local-function-key-map [M-return] [?\M-\C-m])
 433       (define-key local-function-key-map [M-escape] [?\M-\e])
 434       (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
 435                                  local-function-key-map global-map))
 436     (set-terminal-parameter frame 'x-setup-function-keys t)))
 437
 438 ;; These tell read-char how to convert
 439 ;; these special chars to ASCII.
 440 (put 'backspace 'ascii-character ?\d)
 441 (put 'delete 'ascii-character ?\d)
 442 (put 'tab 'ascii-character ?\t)
 443 (put 'linefeed 'ascii-character ?\n)
 444 (put 'clear 'ascii-character ?\C-l)
 445 (put 'return 'ascii-character ?\C-m)
 446 (put 'escape 'ascii-character ?\e)
 447
 448 ;; Modifier name `ctrl' is an alias of `control'.
 449 (put 'ctrl 'modifier-value (get 'control 'modifier-value))
 450
 451 \f
 452 ;;;; Script codes and coding systems
 453 (defconst mac-script-code-coding-systems
 454   '((0 . mac-roman)                     ; smRoman
 455     (1 . japanese-shift-jis)            ; smJapanese
 456     (2 . chinese-big5)                  ; smTradChinese
 457     (3 . korean-iso-8bit)               ; smKorean
 458     (7 . mac-cyrillic)                  ; smCyrillic
 459     (25 . chinese-iso-8bit)             ; smSimpChinese
 460     (29 . mac-centraleurroman)          ; smCentralEuroRoman
 461     )
 462   "Alist of Mac script codes vs Emacs coding systems.")
 463
 464 (defun mac-add-charset-info (xlfd-charset mac-text-encoding)
 465   "Add a character set to display with Mac fonts.
 466 Create an entry in `mac-charset-info-alist'.
 467 XLFD-CHARSET is a string which will appear in the XLFD font name
 468 to identify the character set.  MAC-TEXT-ENCODING is the
 469 correspoinding TextEncodingBase value."
 470   (add-to-list 'mac-charset-info-alist
 471                (list xlfd-charset mac-text-encoding
 472                      (cdr (assq mac-text-encoding
 473                                 mac-script-code-coding-systems)))))
 474
 475 (setq mac-charset-info-alist nil)
 476 (mac-add-charset-info "mac-roman" 0)
 477 (mac-add-charset-info "jisx0208.1983-sjis" 1)
 478 (mac-add-charset-info "jisx0201.1976-0" 1)
 479 (mac-add-charset-info "big5-0" 2)
 480 (mac-add-charset-info "ksc5601.1989-0" 3)
 481 (mac-add-charset-info "mac-cyrillic" 7)
 482 (mac-add-charset-info "gb2312.1980-0" 25)
 483 (mac-add-charset-info "mac-centraleurroman" 29)
 484 (mac-add-charset-info "mac-symbol" 33)
 485 (mac-add-charset-info "adobe-fontspecific" 33) ; for X-Symbol
 486 (mac-add-charset-info "mac-dingbats" 34)
 487 (mac-add-charset-info "iso10646-1" 126) ; for ATSUI
 488
 489 (define-charset 'mac-centraleurroman
 490   "Mac Central European Roman"
 491   :short-name "Mac CE"
 492   :ascii-compatible-p t
 493   :code-space [0 255]
 494   :map
 495   (let ((tbl
 496          [?\Ä ?\Ā ?\ā ?\É ?\Ą ?\Ö ?\Ü ?\á ?\ą ?\Č ?\ä ?\č ?\Ć ?\ć ?\é ?\Ź
 497           ?\ź ?\Ď ?\í ?\ď ?\Ē ?\ē ?\Ė ?\ó ?\ė ?\ô ?\ö ?\õ ?\ú ?\Ě ?\ě ?\ü
 498           ?\† ?\° ?\Ę ?\£ ?\§ ?\• ?\¶ ?\ß ?\® ?\© ?\™ ?\ę ?\¨ ?\≠ ?\ģ ?\Į
 499           ?\į ?\Ī ?\≤ ?\≥ ?\ī ?\Ķ ?\∂ ?\∑ ?\ł ?\Ļ ?\ļ ?\Ľ ?\ľ ?\Ĺ ?\ĺ ?\Ņ
 500           ?\ņ ?\Ń ?\¬ ?\√ ?\ń ?\Ň ?\∆ ?\« ?\» ?\… ?\  ?\ň ?\Ő ?\Õ ?\ő ?\Ō
 501           ?\– ?\— ?\“ ?\” ?\‘ ?\’ ?\÷ ?\◊ ?\ō ?\Ŕ ?\ŕ ?\Ř ?\‹ ?\› ?\ř ?\Ŗ
 502           ?\ŗ ?\Š ?\‚ ?\„ ?\š ?\Ś ?\ś ?\Á ?\Ť ?\ť ?\Í ?\Ž ?\ž ?\Ū ?\Ó ?\Ô
 503           ?\ū ?\Ů ?\Ú ?\ů ?\Ű ?\ű ?\Ų ?\ų ?\Ý ?\ý ?\ķ ?\Ż ?\Ł ?\ż ?\Ģ ?\ˇ])
 504         (map (make-vector 512 nil)))
 505     (or (= (length tbl) 128)
 506         (error "Invalid vector length: %d" (length tbl)))
 507     (dotimes (i 128)
 508       (aset map (* i 2) i)
 509       (aset map (1+ (* i 2)) i))
 510     (dotimes (i 128)
 511       (aset map (+ 256 (* i 2)) (+ 128 i))
 512       (aset map (+ 256 (1+ (* i 2))) (aref tbl i)))
 513     map))
 514
 515 (define-coding-system 'mac-centraleurroman
 516   "Mac Central European Roman Encoding (MIME:x-mac-centraleurroman)."
 517   :coding-type 'charset
 518   :mnemonic ?*
 519   :charset-list '(mac-centraleurroman)
 520   :mime-charset 'x-mac-centraleurroman)
 521
 522 (define-charset 'mac-cyrillic
 523   "Mac Cyrillic"
 524   :short-name "Mac CYRILLIC"
 525   :ascii-compatible-p t
 526   :code-space [0 255]
 527   :map
 528   (let ((tbl
 529          [?\А ?\Б ?\В ?\Г ?\Д ?\Е ?\Ж ?\З ?\И ?\Й ?\К ?\Л ?\М ?\Н ?\О ?\П
 530           ?\Р ?\С ?\Т ?\У ?\Ф ?\Х ?\Ц ?\Ч ?\Ш ?\Щ ?\Ъ ?\Ы ?\Ь ?\Э ?\Ю ?\Я
 531           ?\† ?\° ?\Ґ ?\£ ?\§ ?\• ?\¶ ?\І ?\® ?\© ?\™ ?\Ђ ?\ђ ?\≠ ?\Ѓ ?\ѓ
 532           ?\∞ ?\± ?\≤ ?\≥ ?\і ?\µ ?\ґ ?\Ј ?\Є ?\є ?\Ї ?\ї ?\Љ ?\љ ?\Њ ?\њ
 533           ?\ј ?\Ѕ ?\¬ ?\√ ?\ƒ ?\≈ ?\∆ ?\« ?\» ?\… ?\  ?\Ћ ?\ћ ?\Ќ ?\ќ ?\ѕ
 534           ?\– ?\— ?\“ ?\” ?\‘ ?\’ ?\÷ ?\„ ?\Ў ?\ў ?\Џ ?\џ ?\№ ?\Ё ?\ё ?\я
 535           ?\а ?\б ?\в ?\г ?\д ?\е ?\ж ?\з ?\и ?\й ?\к ?\л ?\м ?\н ?\о ?\п
 536           ?\р ?\с ?\т ?\у ?\ф ?\х ?\ц ?\ч ?\ш ?\щ ?\ъ ?\ы ?\ь ?\э ?\ю ?\€])
 537         (map (make-vector 512 nil)))
 538     (or (= (length tbl) 128)
 539         (error "Invalid vector length: %d" (length tbl)))
 540     (dotimes (i 128)
 541       (aset map (* i 2) i)
 542       (aset map (1+ (* i 2)) i))
 543     (dotimes (i 128)
 544       (aset map (+ 256 (* i 2)) (+ 128 i))
 545       (aset map (+ 256 (1+ (* i 2))) (aref tbl i)))
 546     map))
 547
 548 (define-coding-system 'mac-cyrillic
 549   "Mac Cyrillic Encoding (MIME:x-mac-cyrillic)."
 550   :coding-type 'charset
 551   :mnemonic ?*
 552   :charset-list '(mac-cyrillic)
 553   :mime-charset 'x-mac-cyrillic)
 554
 555 (define-charset 'mac-symbol
 556   "Mac Symbol"
 557   :short-name "Mac SYMBOL"
 558   :code-space [32 254]
 559   :map
 560   (let ((tbl-32-126
 561          [?\  ?\! ?\∀ ?\# ?\∃ ?\% ?\& ?\∍ ?\( ?\) ?\∗ ?\+ ?\, ?\− ?\. ?\/
 562           ?\0 ?\1 ?\2 ?\3 ?\4 ?\5 ?\6 ?\7 ?\8 ?\9 ?\: ?\; ?\< ?\= ?\> ?\?
 563           ?\≅ ?\Α ?\Β ?\Χ ?\Δ ?\Ε ?\Φ ?\Γ ?\Η ?\Ι ?\ϑ ?\Κ ?\Λ ?\Μ ?\Ν ?\Ο
 564           ?\Π ?\Θ ?\Ρ ?\Σ ?\Τ ?\Υ ?\ς ?\Ω ?\Ξ ?\Ψ ?\Ζ ?\[ ?\∴ ?\] ?\⊥ ?\_
 565           ?\ ?\α ?\β ?\χ ?\δ ?\ε ?\φ ?\γ ?\η ?\ι ?\ϕ ?\κ ?\λ ?\μ ?\ν ?\ο
 566           ?\π ?\θ ?\ρ ?\σ ?\τ ?\υ ?\ϖ ?\ω ?\ξ ?\ψ ?\ζ ?\{ ?\| ?\} ?\∼])
 567         (map-32-126 (make-vector (* (1+ (- 126 32)) 2) nil))
 568         (tbl-160-254
 569          ;; Mapping of the following characters are changed from the
 570          ;; original one:
 571          ;; 0xE2 0x00AE+0xF87F->0x00AE # REGISTERED SIGN, alternate: sans serif
 572          ;; 0xE3 0x00A9+0xF87F->0x00A9 # COPYRIGHT SIGN, alternate: sans serif
 573          ;; 0xE4 0x2122+0xF87F->0x2122 # TRADE MARK SIGN, alternate: sans serif
 574          [?\€ ?\ϒ ?\′ ?\≤ ?\⁄ ?\∞ ?\ƒ ?\♣ ?\♦ ?\♥ ?\♠ ?\↔ ?\← ?\↑ ?\→ ?\↓
 575           ?\° ?\± ?\″ ?\≥ ?\× ?\∝ ?\∂ ?\• ?\÷ ?\≠ ?\≡ ?\≈ ?\… ?\⏐ ?\⎯ ?\↵
 576           ?\ℵ ?\ℑ ?\ℜ ?\℘ ?\⊗ ?\⊕ ?\∅ ?\∩ ?\∪ ?\⊃ ?\⊇ ?\⊄ ?\⊂ ?\⊆ ?\∈ ?\∉
 577           ?\∠ ?\∇ ?\® ?\© ?\™ ?\∏ ?\√ ?\⋅ ?\¬ ?\∧ ?\∨ ?\⇔ ?\⇐ ?\⇑ ?\⇒ ?\⇓
 578           ?\◊ ?\〈 ?\® ?\© ?\™ ?\∑ ?\⎛ ?\⎜ ?\⎝ ?\⎡ ?\⎢ ?\⎣ ?\⎧ ?\⎨ ?\⎩ ?\⎪
 579           ?\ ?\〉 ?\∫ ?\⌠ ?\⎮ ?\⌡ ?\⎞ ?\⎟ ?\⎠ ?\⎤ ?\⎥ ?\⎦ ?\⎫ ?\⎬ ?\⎭])
 580         (map-160-254 (make-vector (* (1+ (- 254 160)) 2) nil)))
 581     (dotimes (i (1+ (- 126 32)))
 582       (aset map-32-126 (* i 2) (+ 32 i))
 583       (aset map-32-126 (1+ (* i 2)) (aref tbl-32-126 i)))
 584     (dotimes (i (1+ (- 254 160)))
 585       (aset map-160-254 (* i 2) (+ 160 i))
 586       (aset map-160-254 (1+ (* i 2)) (aref tbl-160-254 i)))
 587     (vconcat map-32-126 map-160-254)))
 588
 589 (define-charset 'mac-dingbats
 590   "Mac Dingbats"
 591   :short-name "Mac Dingbats"
 592   :code-space [32 254]
 593   :map
 594   (let ((tbl-32-126
 595          [?\  ?\✁ ?\✂ ?\✃ ?\✄ ?\☎ ?\✆ ?\✇ ?\✈ ?\✉ ?\☛ ?\☞ ?\✌ ?\✍ ?\✎ ?\✏
 596           ?\✐ ?\✑ ?\✒ ?\✓ ?\✔ ?\✕ ?\✖ ?\✗ ?\✘ ?\✙ ?\✚ ?\✛ ?\✜ ?\✝ ?\✞ ?\✟
 597           ?\✠ ?\✡ ?\✢ ?\✣ ?\✤ ?\✥ ?\✦ ?\✧ ?\★ ?\✩ ?\✪ ?\✫ ?\✬ ?\✭ ?\✮ ?\✯
 598           ?\✰ ?\✱ ?\✲ ?\✳ ?\✴ ?\✵ ?\✶ ?\✷ ?\✸ ?\✹ ?\✺ ?\✻ ?\✼ ?\✽ ?\✾ ?\✿
 599           ?\❀ ?\❁ ?\❂ ?\❃ ?\❄ ?\❅ ?\❆ ?\❇ ?\❈ ?\❉ ?\❊ ?\❋ ?\● ?\❍ ?\■ ?\❏
 600           ?\❐ ?\❑ ?\❒ ?\▲ ?\▼ ?\◆ ?\❖ ?\◗ ?\❘ ?\❙ ?\❚ ?\❛ ?\❜ ?\❝ ?\❞])
 601         (map-32-126 (make-vector (* (1+ (- 126 32)) 2) nil))
 602         (tbl-128-141
 603          [?\❨ ?\❩ ?\❪ ?\❫ ?\❬ ?\❭ ?\❮ ?\❯ ?\❰ ?\❱ ?\❲ ?\❳ ?\❴ ?\❵])
 604         (map-128-141 (make-vector (* (1+ (- 141 128)) 2) nil))
 605         (tbl-161-239
 606          [?\❡ ?\❢ ?\❣ ?\❤ ?\❥ ?\❦ ?\❧ ?\♣ ?\♦ ?\♥ ?\♠ ?\① ?\② ?\③ ?\④
 607           ?\⑤ ?\⑥ ?\⑦ ?\⑧ ?\⑨ ?\⑩ ?\❶ ?\❷ ?\❸ ?\❹ ?\❺ ?\❻ ?\❼ ?\❽ ?\❾ ?\❿
 608           ?\➀ ?\➁ ?\➂ ?\➃ ?\➄ ?\➅ ?\➆ ?\➇ ?\➈ ?\➉ ?\➊ ?\➋ ?\➌ ?\➍ ?\➎ ?\➏
 609           ?\➐ ?\➑ ?\➒ ?\➓ ?\➔ ?\→ ?\↔ ?\↕ ?\➘ ?\➙ ?\➚ ?\➛ ?\➜ ?\➝ ?\➞ ?\➟
 610           ?\➠ ?\➡ ?\➢ ?\➣ ?\➤ ?\➥ ?\➦ ?\➧ ?\➨ ?\➩ ?\➪ ?\➫ ?\➬ ?\➭ ?\➮ ?\➯])
 611         (map-161-239 (make-vector (* (1+ (- 239 161)) 2) nil))
 612         (tbl-241-254
 613          [?\➱ ?\➲ ?\➳ ?\➴ ?\➵ ?\➶ ?\➷ ?\➸ ?\➹ ?\➺ ?\➻ ?\➼ ?\➽ ?\➾])
 614         (map-241-254 (make-vector (* (1+ (- 254 241)) 2) nil)))
 615     (dotimes (i (1+ (- 126 32)))
 616       (aset map-32-126 (* i 2) (+ 32 i))
 617       (aset map-32-126 (1+ (* i 2)) (aref tbl-32-126 i)))
 618     (dotimes (i (1+ (- 141 128)))
 619       (aset map-128-141 (* i 2) (+ 128 i))
 620       (aset map-128-141 (1+ (* i 2)) (aref tbl-128-141 i)))
 621     (dotimes (i (1+ (- 239 161)))
 622       (aset map-161-239 (* i 2) (+ 161 i))
 623       (aset map-161-239 (1+ (* i 2)) (aref tbl-161-239 i)))
 624     (dotimes (i (1+ (- 254 241)))
 625       (aset map-241-254 (* i 2) (+ 241 i))
 626       (aset map-241-254 (1+ (* i 2)) (aref tbl-241-254 i)))
 627     (vconcat map-32-126 map-128-141 map-161-239 map-241-254)))
 628
 629 (defconst mac-system-coding-system
 630   (let ((base (or (cdr (assq mac-system-script-code
 631                              mac-script-code-coding-systems))
 632                   'mac-roman)))
 633     (if (eq system-type 'darwin)
 634         base
 635       (coding-system-change-eol-conversion base 'mac)))
 636   "Coding system derived from the system script code.")
 637
 638 (set-selection-coding-system mac-system-coding-system)
 639
 640 \f
 641 ;;;; Keyboard layout/language change events
 642 (defun mac-handle-language-change (event)
 643   "Set keyboard coding system to what is specified in EVENT."
 644   (interactive "e")
 645   (let ((coding-system
 646          (cdr (assq (car (cadr event)) mac-script-code-coding-systems))))
 647     (set-keyboard-coding-system (or coding-system 'mac-roman))
 648     ;; MacJapanese maps reverse solidus to ?\x80.
 649     (if (eq coding-system 'japanese-shift-jis)
 650         (define-key key-translation-map [?\x80] "\\"))))
 651
 652 (define-key special-event-map [language-change] 'mac-handle-language-change)
 653
 654 \f
 655 ;;;; Conversion between common flavors and Lisp string.
 656
 657 (defconst mac-text-encoding-ascii #x600
 658   "ASCII text encoding.")
 659
 660 (defconst mac-text-encoding-mac-japanese-basic-variant #x20001
 661   "MacJapanese text encoding without Apple double-byte extensions.")
 662
 663 (defun mac-utxt-to-string (data &optional coding-system)
 664   (or coding-system (setq coding-system mac-system-coding-system))
 665   (let* ((encoding
 666           (and (eq system-type 'darwin)
 667                (eq (coding-system-base coding-system) 'japanese-shift-jis)
 668                mac-text-encoding-mac-japanese-basic-variant))
 669          (str (and (fboundp 'mac-code-convert-string)
 670                    (mac-code-convert-string data nil
 671                                             (or encoding coding-system)))))
 672     (when str
 673       (setq str (decode-coding-string str coding-system))
 674       (if (eq encoding mac-text-encoding-mac-japanese-basic-variant)
 675           ;; Does it contain Apple one-byte extensions other than
 676           ;; reverse solidus?
 677           (if (string-match "[\xa0\xfd-\xff]" str)
 678               (setq str nil)
 679             ;; ASCII-only?
 680             (unless (mac-code-convert-string data nil mac-text-encoding-ascii)
 681               (subst-char-in-string ?\x5c ?\¥ str t)
 682               (subst-char-in-string ?\x80 ?\\ str t)))))
 683     (or str
 684         (decode-coding-string data
 685                               (if (eq (byteorder) ?B) 'utf-16be 'utf-16le)))))
 686
 687 (defun mac-string-to-utxt (string &optional coding-system)
 688   (or coding-system (setq coding-system mac-system-coding-system))
 689   (let (data encoding)
 690     (when (and (fboundp 'mac-code-convert-string)
 691                (memq (coding-system-base coding-system)
 692                      (find-coding-systems-string string)))
 693       (setq coding-system
 694             (coding-system-change-eol-conversion coding-system 'mac))
 695       (let ((str string))
 696         (when (and (eq system-type 'darwin)
 697                    (eq coding-system 'japanese-shift-jis-mac))
 698           (setq encoding mac-text-encoding-mac-japanese-basic-variant)
 699           (setq str (subst-char-in-string ?\\ ?\x80 str))
 700           (subst-char-in-string ?\¥ ?\x5c str t)
 701           ;; ASCII-only?
 702           (if (string-match "\\`[\x00-\x7f]*\\'" str)
 703               (setq str nil)))
 704         (and str
 705              (setq data (mac-code-convert-string
 706                          (encode-coding-string str coding-system)
 707                          (or encoding coding-system) nil)))))
 708     (or data (encode-coding-string string (if (eq (byteorder) ?B)
 709                                               'utf-16be-mac
 710                                             'utf-16le-mac)))))
 711
 712 (defun mac-TEXT-to-string (data &optional coding-system)
 713   (or coding-system (setq coding-system mac-system-coding-system))
 714   (prog1 (setq data (decode-coding-string data coding-system))
 715     (when (eq (coding-system-base coding-system) 'japanese-shift-jis)
 716       ;; (subst-char-in-string ?\x5c ?\¥ data t)
 717       (subst-char-in-string ?\x80 ?\\ data t))))
 718
 719 (defun mac-string-to-TEXT (string &optional coding-system)
 720   (or coding-system (setq coding-system mac-system-coding-system))
 721   (let ((encodables (find-coding-systems-string string))
 722         (rest mac-script-code-coding-systems))
 723     (unless (memq (coding-system-base coding-system) encodables)
 724       (while (and rest (not (memq (cdar rest) encodables)))
 725         (setq rest (cdr rest)))
 726       (if rest
 727           (setq coding-system (cdar rest)))))
 728   (setq coding-system
 729         (coding-system-change-eol-conversion coding-system 'mac))
 730   (when (eq coding-system 'japanese-shift-jis-mac)
 731     ;; (setq string (subst-char-in-string ?\\ ?\x80 string))
 732     (setq string (subst-char-in-string ?\¥ ?\x5c string)))
 733   (encode-coding-string string coding-system))
 734
 735 (defun mac-furl-to-string (data)
 736   ;; Remove a trailing nul character.
 737   (let ((len (length data)))
 738     (if (and (> len 0) (= (aref data (1- len)) ?\0))
 739         (substring data 0 (1- len))
 740       data)))
 741
 742 (defun mac-TIFF-to-string (data &optional text)
 743   (prog1 (or text (setq text (copy-sequence " ")))
 744     (put-text-property 0 (length text) 'display (create-image data 'tiff t)
 745                        text)))
 746 \f
 747 ;;;; Selections
 748
 749 ;;; We keep track of the last text selected here, so we can check the
 750 ;;; current selection against it, and avoid passing back our own text
 751 ;;; from x-get-selection-value.
 752 (defvar x-last-selected-text-clipboard nil
 753   "The value of the CLIPBOARD selection last time we selected or
 754 pasted text.")
 755 (defvar x-last-selected-text-primary nil
 756   "The value of the PRIMARY X selection last time we selected or
 757 pasted text.")
 758
 759 (defcustom x-select-enable-clipboard t
 760   "*Non-nil means cutting and pasting uses the clipboard.
 761 This is in addition to the primary selection."
 762   :type 'boolean
 763   :group 'killing)
 764
 765 ;;; Make TEXT, a string, the primary X selection.
 766 (defun x-select-text (text &optional push)
 767   (x-set-selection 'PRIMARY text)
 768   (setq x-last-selected-text-primary text)
 769   (if (not x-select-enable-clipboard)
 770       (setq x-last-selected-text-clipboard nil)
 771     (x-set-selection 'CLIPBOARD text)
 772     (setq x-last-selected-text-clipboard text))
 773   )
 774
 775 (declare-function x-get-selection-internal "xselect.c"
 776                   (selection-symbol target-type &optional time-stamp))
 777
 778 (defun x-get-selection (&optional type data-type)
 779   "Return the value of a selection.
 780 The argument TYPE (default `PRIMARY') says which selection,
 781 and the argument DATA-TYPE (default `STRING') says
 782 how to convert the data.
 783
 784 TYPE may be any symbol \(but nil stands for `PRIMARY').  However,
 785 only a few symbols are commonly used.  They conventionally have
 786 all upper-case names.  The most often used ones, in addition to
 787 `PRIMARY', are `SECONDARY' and `CLIPBOARD'.
 788
 789 DATA-TYPE is usually `STRING', but can also be one of the symbols
 790 in `selection-converter-alist', which see."
 791   (let ((data (x-get-selection-internal (or type 'PRIMARY)
 792                                         (or data-type 'STRING)))
 793         (coding (or next-selection-coding-system
 794                     selection-coding-system)))
 795     (when (and (stringp data)
 796                (setq data-type (get-text-property 0 'foreign-selection data)))
 797       (cond ((eq data-type 'public.utf16-plain-text)
 798              (setq data (mac-utxt-to-string data coding)))
 799             ((eq data-type 'com.apple.traditional-mac-plain-text)
 800              (setq data (mac-TEXT-to-string data coding)))
 801             ((eq data-type 'public.file-url)
 802              (setq data (mac-furl-to-string data))))
 803       (put-text-property 0 (length data) 'foreign-selection data-type data))
 804     data))
 805
 806 (defun x-selection-value (type)
 807   (let ((data-types '(public.utf16-plain-text
 808                       com.apple.traditional-mac-plain-text
 809                       public.file-url))
 810         text tiff-image)
 811     (while (and (null text) data-types)
 812       (setq text (condition-case nil
 813                      (x-get-selection type (car data-types))
 814                    (error nil)))
 815       (setq data-types (cdr data-types)))
 816     (if text
 817         (remove-text-properties 0 (length text) '(foreign-selection nil) text))
 818     (setq tiff-image (condition-case nil
 819                          (x-get-selection type 'public.tiff)
 820                        (error nil)))
 821     (when tiff-image
 822       (remove-text-properties 0 (length tiff-image)
 823                               '(foreign-selection nil) tiff-image)
 824       (setq text (mac-TIFF-to-string tiff-image text)))
 825     text))
 826
 827 ;;; Return the value of the current selection.
 828 ;;; Treat empty strings as if they were unset.
 829 ;;; If this function is called twice and finds the same text,
 830 ;;; it returns nil the second time.  This is so that a single
 831 ;;; selection won't be added to the kill ring over and over.
 832 (defun x-get-selection-value ()
 833   (let (clip-text primary-text)
 834     (if (not x-select-enable-clipboard)
 835         (setq x-last-selected-text-clipboard nil)
 836       (setq clip-text (x-selection-value 'CLIPBOARD))
 837       (if (string= clip-text "") (setq clip-text nil))
 838
 839       ;; Check the CLIPBOARD selection for 'newness', is it different
 840       ;; from what we remebered them to be last time we did a
 841       ;; cut/paste operation.
 842       (setq clip-text
 843             (cond;; check clipboard
 844              ((or (not clip-text) (string= clip-text ""))
 845               (setq x-last-selected-text-clipboard nil))
 846              ((eq      clip-text x-last-selected-text-clipboard) nil)
 847              ((string= clip-text x-last-selected-text-clipboard)
 848               ;; Record the newer string,
 849               ;; so subsequent calls can use the `eq' test.
 850               (setq x-last-selected-text-clipboard clip-text)
 851               nil)
 852              (t
 853               (setq x-last-selected-text-clipboard clip-text))))
 854       )
 855
 856     (setq primary-text (x-selection-value 'PRIMARY))
 857     ;; Check the PRIMARY selection for 'newness', is it different
 858     ;; from what we remebered them to be last time we did a
 859     ;; cut/paste operation.
 860     (setq primary-text
 861           (cond;; check primary selection
 862            ((or (not primary-text) (string= primary-text ""))
 863             (setq x-last-selected-text-primary nil))
 864            ((eq      primary-text x-last-selected-text-primary) nil)
 865            ((string= primary-text x-last-selected-text-primary)
 866             ;; Record the newer string,
 867             ;; so subsequent calls can use the `eq' test.
 868             (setq x-last-selected-text-primary primary-text)
 869             nil)
 870            (t
 871             (setq x-last-selected-text-primary primary-text))))
 872
 873     ;; As we have done one selection, clear this now.
 874     (setq next-selection-coding-system nil)
 875
 876     ;; At this point we have recorded the current values for the
 877     ;; selection from clipboard (if we are supposed to) and primary,
 878     ;; So return the first one that has changed (which is the first
 879     ;; non-null one).
 880     (or clip-text primary-text)
 881     ))
 882
 883 (put 'CLIPBOARD 'mac-scrap-name "com.apple.scrap.clipboard")
 884 (when (eq system-type 'darwin)
 885   (put 'FIND 'mac-scrap-name "com.apple.scrap.find")
 886   (put 'PRIMARY 'mac-scrap-name
 887        (format "org.gnu.Emacs.%d.selection.PRIMARY" (emacs-pid))))
 888 (put 'com.apple.traditional-mac-plain-text 'mac-ostype "TEXT")
 889 (put 'public.utf16-plain-text 'mac-ostype "utxt")
 890 (put 'public.tiff 'mac-ostype "TIFF")
 891 (put 'public.file-url 'mac-ostype "furl")
 892
 893 (defun mac-select-convert-to-string (selection type value)
 894   (let ((str (cdr (xselect-convert-to-string selection nil value)))
 895         (coding (or next-selection-coding-system selection-coding-system)))
 896     (when str
 897       ;; If TYPE is nil, this is a local request, thus return STR as
 898       ;; is.  Otherwise, encode STR.
 899       (if (not type)
 900           str
 901         (let ((inhibit-read-only t))
 902           (remove-text-properties 0 (length str) '(composition nil) str)
 903           (cond
 904            ((eq type 'public.utf16-plain-text)
 905             (setq str (mac-string-to-utxt str coding)))
 906            ((eq type 'com.apple.traditional-mac-plain-text)
 907             (setq str (mac-string-to-TEXT str coding)))
 908            (t
 909             (error "Unknown selection type: %S" type))
 910            )))
 911
 912       (setq next-selection-coding-system nil)
 913       (cons type str))))
 914
 915 (defun mac-select-convert-to-file-url (selection type value)
 916   (let ((filename (xselect-convert-to-filename selection type value))
 917         (coding (or file-name-coding-system default-file-name-coding-system)))
 918     (if (and filename coding)
 919         (setq filename (encode-coding-string filename coding)))
 920     (and filename
 921          (concat "file://localhost"
 922                  (mapconcat 'url-hexify-string
 923                             (split-string filename "/") "/")))))
 924
 925 (setq selection-converter-alist
 926       (nconc
 927        '((public.utf16-plain-text . mac-select-convert-to-string)
 928          (com.apple.traditional-mac-plain-text . mac-select-convert-to-string)
 929          ;; This is not enabled by default because the `Import Image'
 930          ;; menu makes Emacs crash or hang for unknown reasons.
 931          ;; (public.tiff . nil)
 932          (public.file-url . mac-select-convert-to-file-url)
 933          )
 934        selection-converter-alist))
 935 \f
 936 ;;;; Apple events, HICommand events, and Services menu
 937
 938 ;;; Event classes
 939 (put 'core-event     'mac-apple-event-class "aevt") ; kCoreEventClass
 940 (put 'internet-event 'mac-apple-event-class "GURL") ; kAEInternetEventClass
 941
 942 ;;; Event IDs
 943 ;; kCoreEventClass
 944 (put 'open-application     'mac-apple-event-id "oapp") ; kAEOpenApplication
 945 (put 'reopen-application   'mac-apple-event-id "rapp") ; kAEReopenApplication
 946 (put 'open-documents       'mac-apple-event-id "odoc") ; kAEOpenDocuments
 947 (put 'print-documents      'mac-apple-event-id "pdoc") ; kAEPrintDocuments
 948 (put 'open-contents        'mac-apple-event-id "ocon") ; kAEOpenContents
 949 (put 'quit-application     'mac-apple-event-id "quit") ; kAEQuitApplication
 950 (put 'application-died     'mac-apple-event-id "obit") ; kAEApplicationDied
 951 (put 'show-preferences     'mac-apple-event-id "pref") ; kAEShowPreferences
 952 (put 'autosave-now         'mac-apple-event-id "asav") ; kAEAutosaveNow
 953 ;; kAEInternetEventClass
 954 (put 'get-url              'mac-apple-event-id "GURL") ; kAEGetURL
 955 ;; Converted HI command events
 956 (put 'about                'mac-apple-event-id "abou") ; kHICommandAbout
 957 (put 'show-hide-font-panel 'mac-apple-event-id "shfp") ; kHICommandShowHideFontPanel
 958
 959 (defmacro mac-event-spec (event)
 960   `(nth 1 ,event))
 961
 962 (defmacro mac-event-ae (event)
 963   `(nth 2 ,event))
 964
 965 (defun mac-ae-parameter (ae &optional keyword type)
 966   (or keyword (setq keyword "----")) ;; Direct object.
 967   (if (not (and (consp ae) (equal (car ae) "aevt")))
 968       (error "Not an Apple event: %S" ae)
 969     (let ((type-data (cdr (assoc keyword (cdr ae))))
 970           data)
 971       (when (and type type-data (not (equal type (car type-data))))
 972         (setq data (mac-coerce-ae-data (car type-data) (cdr type-data) type))
 973         (setq type-data (if data (cons type data) nil)))
 974       type-data)))
 975
 976 (defun mac-ae-list (ae &optional keyword type)
 977   (or keyword (setq keyword "----")) ;; Direct object.
 978   (let ((desc (mac-ae-parameter ae keyword "list")))
 979     (cond ((null desc)
 980            nil)
 981           ((not (equal (car desc) "list"))
 982            (error "Parameter for \"%s\" is not a list" keyword))
 983           (t
 984            (if (null type)
 985                (cdr desc)
 986              (mapcar
 987               (lambda (type-data)
 988                 (mac-coerce-ae-data (car type-data) (cdr type-data) type))
 989               (cdr desc)))))))
 990
 991 (defun mac-ae-number (ae keyword)
 992   (let ((type-data (mac-ae-parameter ae keyword))
 993         str)
 994     (if (and type-data
 995              (setq str (mac-coerce-ae-data (car type-data)
 996                                            (cdr type-data) "TEXT")))
 997         (let ((num (string-to-number str)))
 998           ;; Mac OS Classic may return "0e+0" as the coerced value for
 999           ;; the type "magn" and the data "\000\000\000\000".
1000           (if (= num 0.0) 0 num))
1001       nil)))
1002
1003 (defun mac-bytes-to-integer (bytes &optional from to)
1004   (or from (setq from 0))
1005   (or to (setq to (length bytes)))
1006   (let* ((len (- to from))
1007          (extended-sign-len (- (1+ (ceiling (log most-positive-fixnum 2)))
1008                                (* 8 len)))
1009          (result 0))
1010     (dotimes (i len)
1011       (setq result (logior (lsh result 8)
1012                            (aref bytes (+ from (if (eq (byteorder) ?B) i
1013                                                  (- len i 1)))))))
1014     (if (> extended-sign-len 0)
1015         (ash (lsh result extended-sign-len) (- extended-sign-len))
1016       result)))
1017
1018 (defun mac-ae-selection-range (ae)
1019 ;; #pragma options align=mac68k
1020 ;; typedef struct SelectionRange {
1021 ;;   short unused1; // 0 (not used)
1022 ;;   short lineNum; // line to select (<0 to specify range)
1023 ;;   long startRange; // start of selection range (if line < 0)
1024 ;;   long endRange; // end of selection range (if line < 0)
1025 ;;   long unused2; // 0 (not used)
1026 ;;   long theDate; // modification date/time
1027 ;; } SelectionRange;
1028 ;; #pragma options align=reset
1029   (let ((range-bytes (cdr (mac-ae-parameter ae "kpos" "TEXT"))))
1030     (and range-bytes
1031          (list (mac-bytes-to-integer range-bytes 2 4)
1032                (mac-bytes-to-integer range-bytes 4 8)
1033                (mac-bytes-to-integer range-bytes 8 12)
1034                (mac-bytes-to-integer range-bytes 16 20)))))
1035
1036 ;; On Mac OS X 10.4 and later, the `open-document' event contains an
1037 ;; optional parameter keyAESearchText from the Spotlight search.
1038 (defun mac-ae-text-for-search (ae)
1039   (let ((utf8-text (cdr (mac-ae-parameter ae "stxt" "utf8"))))
1040     (and utf8-text
1041          (decode-coding-string utf8-text 'utf-8))))
1042
1043 (defun mac-ae-text (ae)
1044   (or (cdr (mac-ae-parameter ae nil "TEXT"))
1045       (error "No text in Apple event.")))
1046
1047 (defun mac-ae-frame (ae &optional keyword type)
1048   (let ((bytes (cdr (mac-ae-parameter ae keyword type))))
1049     (if (or (null bytes) (/= (length bytes) 4))
1050         (error "No window reference in Apple event.")
1051       (let ((window-id (mac-coerce-ae-data "long" bytes "TEXT"))
1052             (rest (frame-list))
1053             frame)
1054         (while (and (null frame) rest)
1055           (if (string= (frame-parameter (car rest) 'window-id) window-id)
1056               (setq frame (car rest)))
1057           (setq rest (cdr rest)))
1058         frame))))
1059
1060 (defun mac-ae-script-language (ae keyword)
1061 ;; struct WritingCode {
1062 ;;   ScriptCode          theScriptCode;
1063 ;;   LangCode            theLangCode;
1064 ;; };
1065   (let ((bytes (cdr (mac-ae-parameter ae keyword "intl"))))
1066     (and bytes
1067          (cons (mac-bytes-to-integer bytes 0 2)
1068                (mac-bytes-to-integer bytes 2 4)))))
1069
1070 (defun mac-bytes-to-text-range (bytes &optional from to)
1071 ;; struct TextRange {
1072 ;;   long                fStart;
1073 ;;   long                fEnd;
1074 ;;   short               fHiliteStyle;
1075 ;; };
1076   (or from (setq from 0))
1077   (or to (setq to (length bytes)))
1078   (and (= (- to from) (+ 4 4 2))
1079        (list (mac-bytes-to-integer bytes from (+ from 4))
1080              (mac-bytes-to-integer bytes (+ from 4) (+ from 8))
1081              (mac-bytes-to-integer bytes (+ from 8) to))))
1082
1083 (defun mac-ae-text-range-array (ae keyword)
1084 ;; struct TextRangeArray {
1085 ;;   short               fNumOfRanges;
1086 ;;   TextRange           fRange[1];
1087 ;; };
1088   (let* ((bytes (cdr (mac-ae-parameter ae keyword "tray")))
1089          (len (length bytes))
1090          nranges result)
1091     (when (and bytes (>= len 2)
1092                (progn
1093                  (setq nranges (mac-bytes-to-integer bytes 0 2))
1094                  (= len (+ 2 (* nranges 10)))))
1095       (setq result (make-vector nranges nil))
1096       (dotimes (i nranges)
1097         (aset result i
1098               (mac-bytes-to-text-range bytes (+ (* i 10) 2)
1099                                        (+ (* i 10) 12)))))
1100     result))
1101
1102 (defconst mac-keyboard-modifier-mask-alist
1103   (mapcar
1104    (lambda (modifier-bit)
1105      (cons (car modifier-bit) (lsh 1 (cdr modifier-bit))))
1106    '((command  . 8)                     ; cmdKeyBit
1107      (shift    . 9)                     ; shiftKeyBit
1108      (option   . 11)                    ; optionKeyBit
1109      (control  . 12)                    ; controlKeyBit
1110      (function . 17)))                  ; kEventKeyModifierFnBit
1111   "Alist of Mac keyboard modifier symbols vs masks.")
1112
1113 (defun mac-ae-keyboard-modifiers (ae)
1114   (let ((modifiers-value (mac-ae-number ae "kmod"))
1115         modifiers)
1116     (if modifiers-value
1117         (dolist (modifier-mask mac-keyboard-modifier-mask-alist)
1118           (if (/= (logand modifiers-value (cdr modifier-mask)) 0)
1119               (setq modifiers (cons (car modifier-mask) modifiers)))))
1120     modifiers))
1121
1122 (defun mac-ae-reopen-application (event)
1123   "Show some frame in response to the Apple event EVENT.
1124 The frame to be shown is chosen from visible or iconified frames
1125 if possible.  If there's no such frame, a new frame is created."
1126   (interactive "e")
1127   (unless (frame-visible-p (selected-frame))
1128     (let ((frame (or (car (visible-frame-list))
1129                      (car (filtered-frame-list 'frame-visible-p)))))
1130       (if frame
1131           (select-frame frame)
1132         (switch-to-buffer-other-frame "*scratch*"))))
1133   (select-frame-set-input-focus (selected-frame)))
1134
1135 (defun mac-ae-open-documents (event)
1136   "Open the documents specified by the Apple event EVENT."
1137   (interactive "e")
1138   (let ((ae (mac-event-ae event)))
1139     (dolist (file-name (mac-ae-list ae nil 'undecoded-file-name))
1140       (if file-name
1141           (dnd-open-local-file
1142            (concat "file://"
1143                    (mapconcat 'url-hexify-string
1144                               (split-string file-name "/") "/")) nil)))
1145     (let ((selection-range (mac-ae-selection-range ae))
1146           (search-text (mac-ae-text-for-search ae)))
1147       (cond (selection-range
1148              (let ((line (car selection-range))
1149                    (start (cadr selection-range))
1150                    (end (nth 2 selection-range)))
1151                (if (>= line 0)
1152                    (goto-line (1+ line))
1153                  (if (and (>= start 0) (>= end 0))
1154                      (progn (set-mark (1+ start))
1155                             (goto-char (1+ end)))))))
1156             ((stringp search-text)
1157              (re-search-forward
1158               (mapconcat 'regexp-quote (split-string search-text) "\\|")
1159               nil t)))))
1160   (select-frame-set-input-focus (selected-frame)))
1161
1162 (defun mac-ae-quit-application (event)
1163   "Quit the application Emacs with the Apple event EVENT."
1164   (interactive "e")
1165   (let ((ae (mac-event-ae event)))
1166     (unwind-protect
1167         (save-buffers-kill-emacs)
1168       ;; Reaches here if the user has canceled the quit.
1169       (mac-resume-apple-event ae -128)))) ; userCanceledErr
1170
1171 ;; url-generic-parse-url is autoloaded from url-parse.
1172 (declare-function url-type "url-parse" t t) ; defstruct
1173
1174 (defun mac-ae-get-url (event)
1175   "Open the URL specified by the Apple event EVENT.
1176 Currently the `mailto' scheme is supported."
1177   (interactive "e")
1178   (let* ((ae (mac-event-ae event))
1179          (parsed-url (url-generic-parse-url (mac-ae-text ae))))
1180     (if (string= (url-type parsed-url) "mailto")
1181         (progn
1182           (url-mailto parsed-url)
1183           (select-frame-set-input-focus (selected-frame)))
1184       (mac-resume-apple-event ae t))))
1185
1186 (setq mac-apple-event-map (make-sparse-keymap))
1187
1188 ;; Received when Emacs is launched without associated documents.
1189 ;; Accept it as an Apple event, but no Emacs event is generated so as
1190 ;; not to erase the splash screen.
1191 (define-key mac-apple-event-map [core-event open-application] 0)
1192
1193 ;; Received when a dock or application icon is clicked and Emacs is
1194 ;; already running.
1195 (define-key mac-apple-event-map [core-event reopen-application]
1196   'mac-ae-reopen-application)
1197
1198 (define-key mac-apple-event-map [core-event open-documents]
1199   'mac-ae-open-documents)
1200 (define-key mac-apple-event-map [core-event show-preferences] 'customize)
1201 (define-key mac-apple-event-map [core-event quit-application]
1202   'mac-ae-quit-application)
1203
1204 (define-key mac-apple-event-map [internet-event get-url] 'mac-ae-get-url)
1205
1206 (define-key mac-apple-event-map [hi-command about] 'about-emacs)
1207
1208 (declare-function tool-bar-mode "tool-bar" (&optional arg))
1209
1210 ;;; Converted Carbon Events
1211 (defun mac-handle-toolbar-switch-mode (event)
1212   "Toggle visibility of tool-bars in response to EVENT.
1213 With no keyboard modifiers, it toggles the visibility of the
1214 frame where the tool-bar toggle button was pressed.  With some
1215 modifiers, it changes the global tool-bar visibility setting."
1216   (interactive "e")
1217   (let ((ae (mac-event-ae event)))
1218     (if (mac-ae-keyboard-modifiers ae)
1219         ;; Globally toggle tool-bar-mode if some modifier key is pressed.
1220         (tool-bar-mode 'toggle)
1221       (let ((frame (mac-ae-frame ae)))
1222         (set-frame-parameter frame 'tool-bar-lines
1223                              (if (= (frame-parameter frame 'tool-bar-lines) 0)
1224                                  1 0))))))
1225
1226 ;; kEventClassWindow/kEventWindowToolbarSwitchMode
1227 (define-key mac-apple-event-map [window toolbar-switch-mode]
1228   'mac-handle-toolbar-switch-mode)
1229
1230 ;;; Font panel
1231 (when (fboundp 'mac-set-font-panel-visible-p)
1232
1233 (define-minor-mode mac-font-panel-mode
1234   "Toggle use of the font panel.
1235 With numeric ARG, display the font panel if and only if ARG is positive."
1236   :init-value nil
1237   :global t
1238   :group 'mac
1239   (mac-set-font-panel-visible-p mac-font-panel-mode))
1240
1241 (defun mac-handle-font-panel-closed (event)
1242   "Update internal status in response to font panel closed EVENT."
1243   (interactive "e")
1244   ;; Synchronize with the minor mode variable.
1245   (mac-font-panel-mode 0))
1246
1247 (defun mac-handle-font-selection (event)
1248   "Change default face attributes according to font selection EVENT."
1249   (interactive "e")
1250   (let* ((ae (mac-event-ae event))
1251          (fm-font-size (mac-ae-number ae "fmsz"))
1252          (atsu-font-id (mac-ae-number ae "auid"))
1253          (attribute-values (and atsu-font-id
1254                                 (mac-atsu-font-face-attributes atsu-font-id))))
1255     (if fm-font-size
1256         (setq attribute-values
1257               `(:height ,(* 10 fm-font-size) ,@attribute-values)))
1258     (apply 'set-face-attribute 'default (selected-frame) attribute-values)))
1259
1260 ;; kEventClassFont/kEventFontPanelClosed
1261 (define-key mac-apple-event-map [font panel-closed]
1262   'mac-handle-font-panel-closed)
1263 ;; kEventClassFont/kEventFontSelection
1264 (define-key mac-apple-event-map [font selection] 'mac-handle-font-selection)
1265 (define-key mac-apple-event-map [hi-command show-hide-font-panel]
1266   'mac-font-panel-mode)
1267
1268 (define-key-after menu-bar-showhide-menu [mac-font-panel-mode]
1269   (menu-bar-make-mm-toggle mac-font-panel-mode
1270                            "Font Panel"
1271                            "Show the font panel as a floating dialog")
1272   'showhide-speedbar)
1273
1274 ) ;; (fboundp 'mac-set-font-panel-visible-p)
1275
1276 ;;; Text Services
1277 (defvar mac-ts-update-active-input-area-seqno 0
1278   "Number of processed update-active-input-area events.")
1279 (setq mac-ts-active-input-overlay (make-overlay 0 0))
1280
1281 (defface mac-ts-caret-position
1282   '((t :inverse-video t))
1283   "Face for caret position in Mac TSM active input area.
1284 This is used when the active input area is displayed either in
1285 the echo area or in a buffer where the cursor is not displayed."
1286   :group 'mac)
1287
1288 (defface mac-ts-raw-text
1289   '((t :underline t))
1290   "Face for raw text in Mac TSM active input area."
1291   :group 'mac)
1292
1293 (defface mac-ts-selected-raw-text
1294   '((t :underline t))
1295   "Face for selected raw text in Mac TSM active input area."
1296   :group 'mac)
1297
1298 (defface mac-ts-converted-text
1299   '((((background dark)) :underline "gray20")
1300     (t :underline "gray80"))
1301   "Face for converted text in Mac TSM active input area."
1302   :group 'mac)
1303
1304 (defface mac-ts-selected-converted-text
1305   '((t :underline t))
1306   "Face for selected converted text in Mac TSM active input area."
1307   :group 'mac)
1308
1309 (defface mac-ts-block-fill-text
1310   '((t :underline t))
1311   "Face for block fill text in Mac TSM active input area."
1312   :group 'mac)
1313
1314 (defface mac-ts-outline-text
1315   '((t :underline t))
1316   "Face for outline text in Mac TSM active input area."
1317   :group 'mac)
1318
1319 (defface mac-ts-selected-text
1320   '((t :underline t))
1321   "Face for selected text in Mac TSM active input area."
1322   :group 'mac)
1323
1324 (defface mac-ts-no-hilite
1325   '((t :inherit default))
1326   "Face for no hilite in Mac TSM active input area."
1327   :group 'mac)
1328
1329 (defconst mac-ts-hilite-style-faces
1330   '((2 . mac-ts-raw-text)                ; kTSMHiliteRawText
1331     (3 . mac-ts-selected-raw-text)       ; kTSMHiliteSelectedRawText
1332     (4 . mac-ts-converted-text)          ; kTSMHiliteConvertedText
1333     (5 . mac-ts-selected-converted-text) ; kTSMHiliteSelectedConvertedText
1334     (6 . mac-ts-block-fill-text)         ; kTSMHiliteBlockFillText
1335     (7 . mac-ts-outline-text)            ; kTSMHiliteOutlineText
1336     (8 . mac-ts-selected-text)           ; kTSMHiliteSelectedText
1337     (9 . mac-ts-no-hilite))              ; kTSMHiliteNoHilite
1338   "Alist of Mac TSM hilite style vs Emacs face.")
1339
1340 (defun mac-ts-update-active-input-buf (text fix-len hilite-rng update-rng)
1341   (let ((buf-len (length mac-ts-active-input-buf))
1342         confirmed)
1343     (if (or (null update-rng)
1344             (/= (% (length update-rng) 2) 0))
1345         ;; The parameter is missing (or in a bad format).  The
1346         ;; existing inline input session is completely replaced with
1347         ;; the new text.
1348         (setq mac-ts-active-input-buf text)
1349       ;; Otherwise, the current subtext specified by the (2*j)-th
1350       ;; range is replaced with the new subtext specified by the
1351       ;; (2*j+1)-th range.
1352       (let ((tail buf-len)
1353             (i (length update-rng))
1354             segments rng)
1355         (while (> i 0)
1356           (setq i (- i 2))
1357           (setq rng (aref update-rng i))
1358           (if (and (<= 0 (cadr rng)) (< (cadr rng) tail)
1359                    (<= tail buf-len))
1360               (setq segments
1361                     (cons (substring mac-ts-active-input-buf (cadr rng) tail)
1362                           segments)))
1363           (setq tail (car rng))
1364           (setq rng (aref update-rng (1+ i)))
1365           (if (and (<= 0 (car rng)) (< (car rng) (cadr rng))
1366                    (<= (cadr rng) (length text)))
1367               (setq segments
1368                     (cons (substring text (car rng) (cadr rng))
1369                           segments))))
1370         (if (and (< 0 tail) (<= tail buf-len))
1371             (setq segments
1372                   (cons (substring mac-ts-active-input-buf 0 tail)
1373                         segments)))
1374         (setq mac-ts-active-input-buf (apply 'concat segments))))
1375     (setq buf-len (length mac-ts-active-input-buf))
1376     ;; Confirm (a part of) inline input session.
1377     (cond ((< fix-len 0)
1378            ;; Entire inline session is being confirmed.
1379            (setq confirmed mac-ts-active-input-buf)
1380            (setq mac-ts-active-input-buf ""))
1381           ((= fix-len 0)
1382            ;; None of the text is being confirmed (yet).
1383            (setq confirmed ""))
1384           (t
1385            (if (> fix-len buf-len)
1386                (setq fix-len buf-len))
1387            (setq confirmed (substring mac-ts-active-input-buf 0 fix-len))
1388            (setq mac-ts-active-input-buf
1389                  (substring mac-ts-active-input-buf fix-len))))
1390     (setq buf-len (length mac-ts-active-input-buf))
1391     ;; Update highlighting and the caret position in the new inline
1392     ;; input session.
1393     (remove-text-properties 0 buf-len '(cursor nil) mac-ts-active-input-buf)
1394     (mapc (lambda (rng)
1395             (cond ((and (= (nth 2 rng) 1) ; kTSMHiliteCaretPosition
1396                         (<= 0 (car rng)) (< (car rng) buf-len))
1397                    (put-text-property (car rng) buf-len
1398                                       'cursor t mac-ts-active-input-buf))
1399                   ((and (<= 0 (car rng)) (< (car rng) (cadr rng))
1400                         (<= (cadr rng) buf-len))
1401                    (put-text-property (car rng) (cadr rng) 'face
1402                                       (cdr (assq (nth 2 rng)
1403                                                  mac-ts-hilite-style-faces))
1404                                       mac-ts-active-input-buf))))
1405           hilite-rng)
1406     confirmed))
1407
1408 (defun mac-split-string-by-property-change (string)
1409   (let ((tail (length string))
1410         head result)
1411     (unless (= tail 0)
1412       (while (setq head (previous-property-change tail string)
1413                    result (cons (substring string (or head 0) tail) result)
1414                    tail head)))
1415     result))
1416
1417 (defun mac-replace-untranslated-utf-8-chars (string &optional to-string)
1418   (or to-string (setq to-string "\e$,3u=\e(B"))
1419   (mapconcat
1420    (lambda (str)
1421      (if (get-text-property 0 'untranslated-utf-8 str) to-string str))
1422    (mac-split-string-by-property-change string)
1423    ""))
1424
1425 (defun mac-keyboard-translate-char (ch)
1426   (if (and (characterp ch)
1427            (or (char-table-p keyboard-translate-table)
1428                (and (or (stringp keyboard-translate-table)
1429                         (vectorp keyboard-translate-table))
1430                     (> (length keyboard-translate-table) ch))))
1431       (or (aref keyboard-translate-table ch) ch)
1432     ch))
1433
1434 (defun mac-unread-string (string)
1435   ;; Unread characters and insert them in a keyboard macro being
1436   ;; defined.
1437   (apply 'isearch-unread
1438          (mapcar 'mac-keyboard-translate-char
1439                  (mac-replace-untranslated-utf-8-chars string))))
1440
1441 (defun mac-ts-update-active-input-area (event)
1442   "Update Mac TSM active input area according to EVENT.
1443 The confirmed text is converted to Emacs input events and pushed
1444 into `unread-command-events'.  The unconfirmed text is displayed
1445 either in the current buffer or in the echo area."
1446   (interactive "e")
1447   (let* ((ae (mac-event-ae event))
1448          (type-text (mac-ae-parameter ae "tstx"))
1449          (text (or (cdr type-text) ""))
1450          (decode-fun (if (equal (car type-text) "TEXT")
1451                          'mac-TEXT-to-string 'mac-utxt-to-string))
1452          (script-language (mac-ae-script-language ae "tssl"))
1453          (coding (or (cdr (assq (car script-language)
1454                                 mac-script-code-coding-systems))
1455                      'mac-roman))
1456          (fix-len (mac-ae-number ae "tsfx"))
1457          ;; Optional parameters
1458          (hilite-rng (mac-ae-text-range-array ae "tshi"))
1459          (update-rng (mac-ae-text-range-array ae "tsup"))
1460          ;;(pin-rng (mac-bytes-to-text-range (cdr (mac-ae-parameter ae "tspn" "txrn"))))
1461          ;;(clause-offsets (cdr (mac-ae-parameter ae "tscl" "ofay")))
1462          (seqno (mac-ae-number ae "tsSn"))
1463          confirmed)
1464     (unless (= seqno mac-ts-update-active-input-area-seqno)
1465       ;; Reset internal states if sequence number is out of sync.
1466       (setq mac-ts-active-input-buf ""))
1467     (setq confirmed
1468           (mac-ts-update-active-input-buf text fix-len hilite-rng update-rng))
1469     (let ((use-echo-area
1470            (or isearch-mode
1471                (and cursor-in-echo-area (current-message))
1472                ;; Overlay strings are not shown in some cases.
1473                (get-char-property (point) 'invisible)
1474                (and (not (bobp))
1475                     (or (and (get-char-property (point) 'display)
1476                              (eq (get-char-property (1- (point)) 'display)
1477                                  (get-char-property (point) 'display)))
1478                         (and (get-char-property (point) 'composition)
1479                              (eq (get-char-property (1- (point)) 'composition)
1480                                  (get-char-property (point) 'composition)))))))
1481           active-input-string caret-seen)
1482       ;; Decode the active input area text with inheriting faces and
1483       ;; the caret position.
1484       (setq active-input-string
1485             (mapconcat
1486              (lambda (str)
1487                (let ((decoded (funcall decode-fun str coding)))
1488                  (put-text-property 0 (length decoded) 'face
1489                                     (get-text-property 0 'face str) decoded)
1490                  (when (and (not caret-seen)
1491                             (get-text-property 0 'cursor str))
1492                    (setq caret-seen t)
1493                    (if (or use-echo-area (null cursor-type))
1494                        (put-text-property 0 1 'face 'mac-ts-caret-position
1495                                           decoded)
1496                      (put-text-property 0 1 'cursor t decoded)))
1497                  decoded))
1498              (mac-split-string-by-property-change mac-ts-active-input-buf)
1499              ""))
1500       (put-text-property 0 (length active-input-string)
1501                          'mac-ts-active-input-string t active-input-string)
1502       (if use-echo-area
1503           (let ((msg (current-message))
1504                 message-log-max)
1505             (if (and msg
1506                      ;; Don't get confused by previously displayed
1507                      ;; `active-input-string'.
1508                      (null (get-text-property 0 'mac-ts-active-input-string
1509                                               msg)))
1510                 (setq msg (propertize msg 'display
1511                                       (concat msg active-input-string)))
1512               (setq msg active-input-string))
1513             (message "%s" msg)
1514             (overlay-put mac-ts-active-input-overlay 'before-string nil))
1515         (move-overlay mac-ts-active-input-overlay
1516                       (point) (point) (current-buffer))
1517         (overlay-put mac-ts-active-input-overlay 'before-string
1518                      active-input-string))
1519       (mac-unread-string (funcall decode-fun confirmed coding)))
1520     ;; The event is successfully processed.  Sync the sequence number.
1521     (setq mac-ts-update-active-input-area-seqno (1+ seqno))))
1522
1523 (defun mac-ts-unicode-for-key-event (event)
1524   "Convert Unicode key EVENT to Emacs key events and unread them."
1525   (interactive "e")
1526   (let* ((ae (mac-event-ae event))
1527          (text (cdr (mac-ae-parameter ae "tstx" "utxt")))
1528          (script-language (mac-ae-script-language ae "tssl"))
1529          (coding (or (cdr (assq (car script-language)
1530                                 mac-script-code-coding-systems))
1531                      'mac-roman)))
1532     (if text
1533         (mac-unread-string (mac-utxt-to-string text coding)))))
1534
1535 ;; kEventClassTextInput/kEventTextInputUpdateActiveInputArea
1536 (define-key mac-apple-event-map [text-input update-active-input-area]
1537   'mac-ts-update-active-input-area)
1538 ;; kEventClassTextInput/kEventTextInputUnicodeForKeyEvent
1539 (define-key mac-apple-event-map [text-input unicode-for-key-event]
1540   'mac-ts-unicode-for-key-event)
1541
1542 ;;; Services
1543 (defun mac-service-open-file ()
1544   "Open the file specified by the selection value for Services."
1545   (interactive)
1546   ;; The selection seems not to contain the file name as
1547   ;; public.utf16-plain-text data on Mac OS X 10.4.
1548   (dnd-open-file (x-get-selection mac-service-selection 'public.file-url) nil))
1549
1550 (defun mac-service-open-selection ()
1551   "Create a new buffer containing the selection value for Services."
1552   (interactive)
1553   (switch-to-buffer (generate-new-buffer "*untitled*"))
1554   (insert (x-selection-value mac-service-selection))
1555   (sit-for 0)
1556   (save-buffer) ; It pops up the save dialog.
1557   )
1558
1559 (defun mac-service-mail-selection ()
1560   "Prepare a mail buffer containing the selection value for Services."
1561   (interactive)
1562   (compose-mail)
1563   (rfc822-goto-eoh)
1564   (forward-line 1)
1565   (insert (x-selection-value mac-service-selection) "\n"))
1566
1567 (defun mac-service-mail-to ()
1568   "Prepare a mail buffer to be sent to the selection value for Services."
1569   (interactive)
1570   (compose-mail (x-selection-value mac-service-selection)))
1571
1572 (defun mac-service-insert-text ()
1573   "Insert the selection value for Services."
1574   (interactive)
1575   (let ((text (x-selection-value mac-service-selection)))
1576     (if (not buffer-read-only)
1577         (insert text)
1578       (kill-new text)
1579       (message "%s"
1580        (substitute-command-keys
1581         "The text from the Services menu can be accessed with \\[yank]")))))
1582
1583 ;; kEventClassService/kEventServicePaste
1584 (define-key mac-apple-event-map [service paste] 'mac-service-insert-text)
1585 ;; kEventClassService/kEventServicePerform
1586 (define-key mac-apple-event-map [service perform open-file]
1587   'mac-service-open-file)
1588 (define-key mac-apple-event-map [service perform open-selection]
1589   'mac-service-open-selection)
1590 (define-key mac-apple-event-map [service perform mail-selection]
1591   'mac-service-mail-selection)
1592 (define-key mac-apple-event-map [service perform mail-to]
1593   'mac-service-mail-to)
1594
1595 (defun mac-dispatch-apple-event (event)
1596   "Dispatch EVENT according to the keymap `mac-apple-event-map'."
1597   (interactive "e")
1598   (let* ((binding (lookup-key mac-apple-event-map (mac-event-spec event)))
1599          (ae (mac-event-ae event))
1600          (service-message (and (keymapp binding)
1601                                (cdr (mac-ae-parameter ae "svmg")))))
1602     (when service-message
1603       (setq service-message
1604             (intern (decode-coding-string service-message 'utf-8)))
1605       (setq binding (lookup-key binding (vector service-message))))
1606     ;; Replace (cadr event) with a dummy position so that event-start
1607     ;; returns it.
1608     (setcar (cdr event) (list (selected-window) (point) '(0 . 0) 0))
1609     (if (null (mac-ae-parameter ae 'emacs-suspension-id))
1610         (command-execute binding nil (vector event) t)
1611       (condition-case err
1612           (progn
1613             (command-execute binding nil (vector event) t)
1614             (mac-resume-apple-event ae))
1615         (error
1616          (mac-ae-set-reply-parameter ae "errs"
1617                                      (cons "TEXT" (error-message-string err)))
1618          (mac-resume-apple-event ae -10000)))))) ; errAEEventFailed
1619
1620 (define-key special-event-map [mac-apple-event] 'mac-dispatch-apple-event)
1621
1622 ;; Processing of Apple events are deferred at the startup time.  For
1623 ;; example, files dropped onto the Emacs application icon can only be
1624 ;; processed when the initial frame has been created: this is where
1625 ;; the files should be opened.
1626 (add-hook 'after-init-hook 'mac-process-deferred-apple-events)
1627
1628 (run-with-idle-timer 5 t 'mac-cleanup-expired-apple-events)
1629
1630 \f
1631 ;;;; Drag and drop
1632
1633 (defcustom mac-dnd-types-alist
1634   '(("furl" . mac-dnd-handle-furl)
1635     ("hfs " . mac-dnd-handle-hfs)
1636     ("utxt" . mac-dnd-insert-utxt)
1637     ("TEXT" . mac-dnd-insert-TEXT)
1638     ("TIFF" . mac-dnd-insert-TIFF))
1639   "Which function to call to handle a drop of that type.
1640 The function takes three arguments, WINDOW, ACTION and DATA.
1641 WINDOW is where the drop occurred, ACTION is always `private' on
1642 Mac.  DATA is the drop data.  Unlike the x-dnd counterpart, the
1643 return value of the function is not significant.
1644
1645 See also `mac-dnd-known-types'."
1646   :version "22.1"
1647   :type 'alist
1648   :group 'mac)
1649
1650 (defun mac-dnd-handle-furl (window action data)
1651   (dnd-handle-one-url window action (mac-furl-to-string data)))
1652
1653 (defun mac-dnd-handle-hfs (window action data)
1654 ;; struct HFSFlavor {
1655 ;;   OSType fileType;
1656 ;;   OSType fileCreator;
1657 ;;   UInt16 fdFlags;
1658 ;;   FSSpec fileSpec;
1659 ;; };
1660   (let* ((file-name (mac-coerce-ae-data "fss " (substring data 10)
1661                                         'undecoded-file-name))
1662          (url (concat "file://"
1663                       (mapconcat 'url-hexify-string
1664                                  (split-string file-name "/") "/"))))
1665     (dnd-handle-one-url window action url)))
1666
1667 (defun mac-dnd-insert-utxt (window action data)
1668   (dnd-insert-text window action (mac-utxt-to-string data)))
1669
1670 (defun mac-dnd-insert-TEXT (window action data)
1671   (dnd-insert-text window action (mac-TEXT-to-string data)))
1672
1673 (defun mac-dnd-insert-TIFF (window action data)
1674   (dnd-insert-text window action (mac-TIFF-to-string data)))
1675
1676 (defun mac-dnd-drop-data (event frame window data type &optional action)
1677   (or action (setq action 'private))
1678   (let* ((type-info (assoc type mac-dnd-types-alist))
1679          (handler (cdr type-info))
1680          (w (posn-window (event-start event))))
1681     (when handler
1682       (if (and (window-live-p w)
1683                (not (window-minibuffer-p w))
1684                (not (window-dedicated-p w)))
1685           ;; If dropping in an ordinary window which we could use,
1686           ;; let dnd-open-file-other-window specify what to do.
1687           (progn
1688             (when (not mouse-yank-at-point)
1689               (goto-char (posn-point (event-start event))))
1690             (funcall handler window action data))
1691         ;; If we can't display the file here,
1692         ;; make a new window for it.
1693         (let ((dnd-open-file-other-window t))
1694           (select-frame frame)
1695           (funcall handler window action data))))))
1696
1697 (defun mac-dnd-handle-drag-n-drop-event (event)
1698   "Receive drag and drop events."
1699   (interactive "e")
1700   (let ((window (posn-window (event-start event)))
1701         (ae (mac-event-ae event))
1702         action)
1703     (when (windowp window) (select-window window))
1704     (if (memq 'option (mac-ae-keyboard-modifiers ae))
1705         (setq action 'copy))
1706     (dolist (item (mac-ae-list ae))
1707       (if (not (equal (car item) "null"))
1708           (mac-dnd-drop-data event (selected-frame) window
1709                              (cdr item) (car item) action)))))
1710 \f
1711 (setq font-encoding-alist
1712       (append
1713        '(("mac-roman" . mac-roman)
1714          ("mac-centraleurroman" . mac-centraleurroman)
1715          ("mac-cyrillic" . mac-cyrillic)
1716          ("mac-symbol" . mac-symbol)
1717          ("mac-dingbats" . mac-dingbats))
1718        font-encoding-alist))
1719
1720 (declare-function set-fontset-font "fontset.c"
1721                   (name target font-spec &optional frame add))
1722
1723 (defun fontset-add-mac-fonts (fontset &optional base-family)
1724   (dolist (elt `((latin . (,(or base-family "Monaco") . "mac-roman"))
1725                  (mac-roman . (,base-family . "mac-roman"))
1726                  (mac-centraleurroman . (,base-family . "mac-centraleurroman"))
1727                  (mac-cyrillic . (,base-family . "mac-cyrillic"))
1728                  (mac-symbol . (,base-family . "mac-symbol"))
1729                  (mac-dingbats . (,base-family . "mac-dingbats"))))
1730     (set-fontset-font fontset (car elt) (cdr elt))))
1731
1732 (declare-function new-fontset "fontset.c" (name fontlist))
1733
1734 (defun create-fontset-from-mac-roman-font (font &optional resolved-font
1735                                                 fontset-name)
1736   "Create a fontset from a Mac roman font FONT.
1737
1738 Optional 1st arg RESOLVED-FONT is a resolved name of FONT.  If
1739 omitted, `x-resolve-font-name' is called to get the resolved name.  At
1740 this time, if FONT is not available, error is signaled.
1741
1742 Optional 2nd arg FONTSET-NAME is a string to be used in
1743 `<CHARSET_ENCODING>' fields of a new fontset name.  If it is omitted,
1744 an appropriate name is generated automatically.
1745
1746 It returns a name of the created fontset."
1747   (or resolved-font
1748       (setq resolved-font (x-resolve-font-name font)))
1749   (let ((base-family (aref (x-decompose-font-name resolved-font)
1750                            xlfd-regexp-family-subnum)))
1751     (if (string= base-family "*")
1752         (setq base-family nil))
1753     (new-fontset fontset-name (list (cons 'ascii resolved-font)))
1754     (fontset-add-mac-fonts fontset-name base-family)))
1755
1756 (defun x-win-suspend-error ()
1757   (error "Suspending an Emacs running under Mac makes no sense"))
1758
1759 (defalias 'x-cut-buffer-or-selection-value 'x-get-selection-value)
1760
1761 (defvar mac-initialized nil
1762   "Non-nil if the w32 window system has been initialized.")
1763
1764 (defun mac-initialize-window-system ()
1765   "Initialize Emacs for Mac GUI frames."
1766
1767 ;;; Do the actual Windows setup here; the above code just defines
1768 ;;; functions and variables that we use now.
1769
1770 (setq command-line-args (x-handle-args command-line-args))
1771
1772 ;;; Make sure we have a valid resource name.
1773 (or (stringp x-resource-name)
1774     (let (i)
1775       (setq x-resource-name (invocation-name))
1776
1777       ;; Change any . or * characters in x-resource-name to hyphens,
1778       ;; so as not to choke when we use it in X resource queries.
1779       (while (setq i (string-match "[.*]" x-resource-name))
1780         (aset x-resource-name i ?-))))
1781
1782 (declare-function x-display-list "macfns.c" ())
1783 (declare-function x-open-connection "macfns.c"
1784                   (display &optional xrm-string must-succeed))
1785
1786 (if (x-display-list)
1787     ;; On Mac OS 8/9, Most coding systems used in code conversion for
1788     ;; font names are not ready at the time when the terminal frame is
1789     ;; created.  So we reconstruct font name table for the initial
1790     ;; frame.
1791     (mac-clear-font-name-table)
1792   (x-open-connection "Mac"
1793                      x-command-line-resources
1794                      ;; Exit Emacs with fatal error if this fails.
1795                      t))
1796
1797 (add-hook 'suspend-hook 'x-win-suspend-error)
1798
1799 ;;; Arrange for the kill and yank functions to set and check the clipboard.
1800 (setq interprogram-cut-function 'x-select-text)
1801 (setq interprogram-paste-function 'x-get-selection-value)
1802
1803
1804
1805
1806 ;;; Turn off window-splitting optimization; Mac is usually fast enough
1807 ;;; that this is only annoying.
1808 (setq split-window-keep-point t)
1809
1810 ;; Don't show the frame name; that's redundant.
1811 (setq-default mode-line-frame-identification "  ")
1812
1813 ;; Turn on support for mouse wheels.
1814 (mouse-wheel-mode 1)
1815
1816
1817 ;; Enable CLIPBOARD copy/paste through menu bar commands.
1818 (menu-bar-enable-clipboard)
1819
1820
1821 ;; Initiate drag and drop
1822
1823 (define-key special-event-map [drag-n-drop] 'mac-dnd-handle-drag-n-drop-event)
1824
1825 \f
1826 ;;;; Non-toolkit Scroll bars
1827
1828 (unless (and (boundp 'x-toolkit-scroll-bars) x-toolkit-scroll-bars)
1829
1830 ;; for debugging
1831 ;; (defun mac-handle-scroll-bar-event (event) (interactive "e") (princ event))
1832
1833 ;;(global-set-key [vertical-scroll-bar mouse-1] 'mac-handle-scroll-bar-event)
1834
1835 (global-set-key
1836  [vertical-scroll-bar down-mouse-1]
1837  'mac-handle-scroll-bar-event)
1838
1839 (global-unset-key [vertical-scroll-bar drag-mouse-1])
1840 (global-unset-key [vertical-scroll-bar mouse-1])
1841
1842 ;; Adjust Courier font specifications in x-fixed-font-alist.
1843 (let ((courier-fonts (assoc "Courier" x-fixed-font-alist)))
1844   (if courier-fonts
1845       (dolist (label-fonts (cdr courier-fonts))
1846         (setcdr label-fonts
1847                 (mapcar
1848                  (lambda (font)
1849                    (if (string-match "\\`-adobe-courier-\\([^-]*\\)-\\(.\\)-\\(.*\\)-iso8859-1\\'" font)
1850                        (replace-match
1851                         (if (string= (match-string 2 font) "o")
1852                             "-*-courier-\\1-i-\\3-*-*"
1853                           "-*-courier-\\1-\\2-\\3-*-*")
1854                         t nil font)
1855                      font))
1856                  (cdr label-fonts))))))
1857
1858 ;; Setup the default fontset.
1859 (setup-default-fontset)
1860
1861 ;; Create a fontset that uses mac-roman font.  With this fontset,
1862 ;; characters belonging to mac-roman charset (that contains ASCII and
1863 ;; more Latin characters) are displayed by a mac-roman font.
1864 (create-fontset-from-mac-roman-font
1865  "-*-Monaco-*-*-*-*-12-*-*-*-*-*-mac-roman" nil
1866  "-apple-Monaco-normal-r-*-*-12-*-*-*-*-*-fontset-standard")
1867
1868 ;; Create fontset specified in X resources "Fontset-N" (N is 0, 1, ...).
1869 (create-fontset-from-x-resource)
1870
1871 (declare-function x-get-resource "frame.c"
1872                   (attribute class &optional component subclass))
1873
1874 ;; Apply a geometry resource to the initial frame.  Put it at the end
1875 ;; of the alist, so that anything specified on the command line takes
1876 ;; precedence.
1877 (let* ((res-geometry (x-get-resource "geometry" "Geometry"))
1878        parsed)
1879   (if res-geometry
1880       (progn
1881         (setq parsed (x-parse-geometry res-geometry))
1882         ;; If the resource specifies a position,
1883         ;; call the position and size "user-specified".
1884         (if (or (assq 'top parsed) (assq 'left parsed))
1885             (setq parsed (cons '(user-position . t)
1886                                (cons '(user-size . t) parsed))))
1887         ;; All geometry parms apply to the initial frame.
1888         (setq initial-frame-alist (append initial-frame-alist parsed))
1889         ;; The size parms apply to all frames.  Don't set it if there are
1890         ;; sizes there already (from command line).
1891         (if (and (assq 'height parsed)
1892                  (not (assq 'height default-frame-alist)))
1893             (setq default-frame-alist
1894                   (cons (cons 'height (cdr (assq 'height parsed)))
1895                         default-frame-alist)))
1896         (if (and (assq 'width parsed)
1897                  (not (assq 'width default-frame-alist)))
1898             (setq default-frame-alist
1899                   (cons (cons 'width (cdr (assq 'width parsed)))
1900                         default-frame-alist))))))
1901
1902 ;; Check the reverseVideo resource.
1903 (let ((case-fold-search t))
1904   (let ((rv (x-get-resource "reverseVideo" "ReverseVideo")))
1905     (if (and rv
1906              (string-match "^\\(true\\|yes\\|on\\)$" rv))
1907         (setq default-frame-alist
1908               (cons '(reverse . t) default-frame-alist)))))
1909
1910 (setq mac-initialized t)))
1911
1912 (defun mac-handle-scroll-bar-event (event)
1913   "Handle scroll bar EVENT to emulate Mac Toolbox style scrolling."
1914   (interactive "e")
1915   (let* ((position (event-start event))
1916          (window (nth 0 position))
1917          (bar-part (nth 4 position)))
1918     (select-window window)
1919     (cond
1920      ((eq bar-part 'up)
1921       (goto-char (window-start window))
1922       (mac-scroll-down-line))
1923      ((eq bar-part 'above-handle)
1924       (mac-scroll-down))
1925      ((eq bar-part 'handle)
1926       (scroll-bar-drag event))
1927      ((eq bar-part 'below-handle)
1928       (mac-scroll-up))
1929      ((eq bar-part 'down)
1930       (goto-char (window-start window))
1931       (mac-scroll-up-line)))))
1932
1933 (defun mac-scroll-ignore-events ()
1934   ;; Ignore confusing non-mouse events
1935   (while (not (memq (car-safe (read-event))
1936                     '(mouse-1 double-mouse-1 triple-mouse-1))) nil))
1937
1938 (defun mac-scroll-down ()
1939   (track-mouse
1940     (mac-scroll-ignore-events)
1941     (scroll-down)))
1942
1943 (defun mac-scroll-down-line ()
1944   (track-mouse
1945     (mac-scroll-ignore-events)
1946     (scroll-down 1)))
1947
1948 (defun mac-scroll-up ()
1949   (track-mouse
1950     (mac-scroll-ignore-events)
1951     (scroll-up)))
1952
1953 (defun mac-scroll-up-line ()
1954   (track-mouse
1955     (mac-scroll-ignore-events)
1956     (scroll-up 1)))
1957
1958
1959 \f
1960 ;;;; Others
1961
1962 (unless (eq system-type 'darwin)
1963   ;; This variable specifies the Unix program to call (as a process) to
1964   ;; determine the amount of free space on a file system (defaults to
1965   ;; df).  If it is not set to nil, ls-lisp will not work correctly
1966   ;; unless an external application df is implemented on the Mac.
1967   (setq directory-free-space-program nil)
1968
1969   ;; Set this so that Emacs calls subprocesses with "sh" as shell to
1970   ;; expand filenames Note no subprocess for the shell is actually
1971   ;; started (see run_mac_command in sysdep.c).
1972   (setq shell-file-name "sh")
1973
1974   ;; Some system variables are encoded with the system script code.
1975   (dolist (v '(system-name
1976                emacs-build-system       ; Mac OS 9 version cannot dump
1977                user-login-name user-real-login-name user-full-name))
1978     (set v (decode-coding-string (symbol-value v) mac-system-coding-system))))
1979
1980 ;; Now the default directory is changed to the user's home directory
1981 ;; in emacs.c if invoked from the WindowServer (with -psn_* option).
1982 ;; (if (string= default-directory "/")
1983 ;;     (cd "~"))
1984
1985 ;; Darwin 6- pty breakage is now controlled from the C code so that
1986 ;; it applies to all builds on darwin.  See s/darwin.h PTY_ITERATION.
1987 ;; (setq process-connection-type t)
1988
1989 ;; Assume that fonts are always scalable on the Mac.  This sometimes
1990 ;; results in characters with jagged edges.  However, without it,
1991 ;; fonts with both truetype and bitmap representations but no italic
1992 ;; or bold bitmap versions will not display these variants correctly.
1993 (setq scalable-fonts-allowed t)
1994
1995 (add-to-list 'handle-args-function-alist '(mac . x-handle-args))
1996 (add-to-list 'frame-creation-function-alist '(mac . x-create-frame-with-faces))
1997 (add-to-list 'window-system-initialization-alist '(mac . mac-initialize-window-system))
1998
1999 (provide 'mac-win)
2000
2001 ;; arch-tag: 71dfcd14-cde8-4d66-b05c-85ec94fb23a6
2002 ;;; mac-win.el ends here